urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-24 11:24:21 +03:00
Code Issues Packages Projects Releases Wiki Activity
5a6b859a07
shrub/pkg/arvo/sys/arvo.hoon
Philip Monk 3b9bcf64b0
arvo: remove unneeded top-level mock
2019-12-02 20:52:59 -08:00

988 lines
34 KiB
Plaintext
Raw Blame History

:::::: ::::::::::::::::::::::::::::::::::::::::::::::::::::::
:::::: :::::: Postface ::::::
:::::: ::::::::::::::::::::::::::::::::::::::::::::::::::::::
~> %slog.[0 leaf+"%arvo-assembly"]
=- ~> %slog.[0 leaf+"%arvo-assembled"]
-
=< ::
:: Arvo formal interface
::
:: this lifecycle wrapper makes the arvo door (multi-armed core)
:: look like a gate (function or single-armed core), to fit
:: urbit's formal lifecycle function. a practical interpreter
:: can ignore it.
::
|= [now=@da ovo=*]
^- *
~> %slog.[0 leaf+"arvo-event"]
.(+> +:(poke now ovo))
:::::: ::::::::::::::::::::::::::::::::::::::::::::::::::::::
:::::: :::::: volume 3, Arvo models and skeleton ::::::
:::::: ::::::::::::::::::::::::::::::::::::::::::::::::::::::
=>
|%
++ arch {fil/(unit @uvI) dir/(map @ta $~)} :: fundamental node
++ arvo (wind {p/term q/mill} mill) :: arvo card
++ beam {{p/ship q/desk r/case} s/path} :: global name
++ beak {p/ship q/desk r/case} :: garnish with beak
++ bone @ud :: opaque duct
++ case :: version
$% {$da p/@da} :: date
{$tas p/@tas} :: label
{$ud p/@ud} :: sequence
== ::
++ desk @tas :: ship desk case spur
++ dock (pair @p term) :: message target
++ cage (cask vase) :: global metadata
++ cask |*(a/mold (pair mark a)) :: global data
++ curd {p/@tas q/*} :: typeless card
++ duct (list wire) :: causal history
++ hypo |*(a/mold (pair type a)) :: type associated
++ hobo |* a/mold :: kiss wrapper
$? $% {$soft p/*} ::
== ::
a ::
== ::
++ mark @tas :: content type
++ mash |=(* (mass +<)) :: producing mass
++ mass $~ [%$ [%& ~]] :: memory usage
(pair cord (each noun (list mash))) ::
++ mill (each vase milt) :: vase+metavase
++ milt {p/* q/*} :: metavase
++ monk (each ship {p/@tas q/@ta}) :: general identity
++ muse {p/@tas q/duct r/arvo s/@ud} :: sourced move
++ move {p/duct q/arvo} :: arvo move
++ ovum {p/wire q/curd} :: typeless ovum
++ pane (list {p/@tas q/vase}) :: kernel modules
++ pone (list {p/@tas q/vise}) :: kernel modules old
+$ scry-sample
[fur=(unit (set monk)) ren=@tas why=shop syd=desk lot=coin tyl=path]
+$ vane-sample
[our=ship now=@da eny=@uvJ ski=slyd]
++ ship @p :: network identity
++ sink (trel bone ship path) :: subscription
++ sley $- {* (unit (set monk)) term beam} :: namespace function
(unit (unit cage)) ::
++ slyd $- {* (unit (set monk)) term beam} :: super advanced
(unit (unit (cask milt))) ::
++ slyt $-({* *} (unit (unit))) :: old namespace
+$ vane [=vase =worm]
++ vile :: reflexive constants
$: typ/type :: -:!>(*type)
duc/type :: -:!>(*duct)
pah/type :: -:!>(*path)
mev/type :: -:!>([%meta *vase])
== ::
++ wind :: new kernel action
|* {a/mold b/mold} :: forward+reverse
$% {$pass p/path q/a} :: advance
{$slip p/a} :: lateral
{$give p/b} :: retreat
== ::
++ wire path :: event pretext
--
=>
~% %hex +> ~
|%
::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: section 3bE, Arvo core ::
::
++ sloy
:: +sloy: adapter from old style scrys to new style scrys
::
:: This does path parsing which shows up hot, but removing the last +slay
:: here requires deeper interface changes.
::
!:
~/ %sloy
|= sod/slyd
^- slyt
|= {ref/* raw/*}
=+ pux=((soft path) raw)
?~ pux ~
?. ?=({@ @ @ @ *} u.pux) ~
=+ :* hyr=(slaw %tas i.u.pux)
fal=(slaw %p i.t.u.pux)
dyc=(slaw %tas i.t.t.u.pux)
ved=(slay i.t.t.t.u.pux)
tyl=t.t.t.t.u.pux
==
?~ hyr ~
?~ fal ~
?~ dyc ~
?. ?=(^ ved) ~
=/ ron=@tas u.hyr
=/ bed=beam
[[u.fal u.dyc (case p.u.ved)] (flop tyl)]
=/ bop=(unit (unit (cask milt)))
(sod ref ~ ron bed)
?~ bop ~
?~ u.bop [~ ~]
:: XX figure out wth to do about hoon-version
::
?. ?& ?=([?(%151 %141) *] ref)
-:(~(nets wa *worm) +.ref -.q.u.u.bop)
==
~>(%slog.[0 leaf+"arvo: scry-lost"] ~)
[~ ~ +.q.u.u.bop]
:: +sloy-light: minimal parsing version of sloy
::
:: There are several places inside vanes where we manually call the scry
:: function raw, instead of passing it into +mink. In those cases, we're
:: paying the price to render the arguments as text, and then are
:: immediately parsing the passed in data. We can avoid that.
::
:: TODO: The entire scrying system needs to be cleaned up in a more
:: permanent way. This hack fixes up some print/parse costs, but doesn't
:: recover the print/parse costs of the scry itself, which we could prevent
:: if we didn't send (list @ta), but instead sent (list dime).
::
++ sloy-light
~/ %sloy-light
|= sod/slyd
|= [ref=* ron=@tas fal=@p dyc=@tas ved=case tyl=path]
:: we do not flop tyl because tyl wouldn't have been flopped by +en-beam
::
=/ bed=beam
[[fal dyc ved] tyl]
=/ bop=(unit (unit (cask milt)))
(sod ref ~ ron bed)
?~ bop ~
?~ u.bop [~ ~]
:: XX figure out wth to do about hoon-version
::
?. ?& ?=([?(%151 %141) *] ref)
-:(~(nets wa *worm) +.ref -.q.u.u.bop)
==
~>(%slog.[0 leaf+"arvo: scry-dark"] ~)
[~ ~ +.q.u.u.bop]
::
++ symp :: symbol or empty
|= a=* ^- @tas
?.(&(?=(@ a) ((sane %tas) a)) %$ a)
::
++ vent :: vane core
|= [who=ship lal=@tas vil=vile bud=vase =vane]
~% %vent +>+ ~
|%
++ ruck :: update vase
|= {pax/path txt/@ta}
^+ +>
=- ?:(?=(%| -.res) ((slog p.res) +>.$) p.res)
^= res %- mule |.
:: XX should use real entropy and the real date
::
=/ arg=vane-sample
[who ~2000.1.1 *@uvJ =>(~ |~(* ~))]
=+ rig=(slym vase.vane arg)
=+ gen=(rain pax txt)
=+ rev=(slym (slap bud gen) bud)
=+ syg=(slym rev arg)
:: update the vane itself
::
:: We don't cache the n+slap/+slam types because they're only used once
:: right here; they'll never be used again.
::
=. vase.vane
~| %load-lost
(slam (slap syg [%limb %load]) (slap rig [%limb %stay]))
:: prime the new compiler cache
::
prime
:: reset and prime the worm cache for scrys
::
:: If the +slap/+slym in scry isn't cached, we spend the majority of
:: the time in a scry in the compiler. The +scry gate cannot have side
:: effects so we can't modify the cache at access time. So we seed the
:: cache with all the things +scry will need when we install the vane
::
++ prime
^+ ..prime
::
%_ ..prime
worm.vane
:: reset cache and add in vane activation entry
::
=^ rig worm.vane
(~(slym wa *worm) vase.vane *vane-sample)
:: cache the access of the %scry arm
::
+:(~(slap wa worm.vane) rig [%limb %scry])
==
::
++ wink :: deploy
|= {now/@da eny/@ ski/slyd}
=^ rig worm.vane
~| [%failed-vane-activation-for lal]
(~(slym wa worm.vane) vase.vane `vane-sample`[who +<]) :: activate vane
~% %wink +>+> ~
|%
++ slid
|= {hed/mill tal/mill}
^- mill
?: &(?=(%& -.hed) ?=(%& -.tal))
[%& (slop p.hed p.tal)]
[%| [%cell p.p.hed p.p.tal] [q.p.hed q.p.tal]]
::
++ slix
|= hil/mill
^- mill
?- -.hil
%& [%& (slop [typ.vil p.p.hil] p.hil)]
%| [%| [%cell typ.vil p.p.hil] p.hil]
==
::
++ slur :: call gate on
|= {gat/vase hil/mill}
^- (unit (pair vase worm))
=^ sam worm.vane
~| [%failed-slot-in lal]
(~(slot wa worm.vane) 6 gat)
=^ hig worm.vane
~| [%failed-nest-in lal]
?- -.hil
%& (~(nest wa worm.vane) p.sam p.p.hil)
%| (~(nets wa worm.vane) p.sam p.p.hil)
==
?. hig
~
~| [%failed-slym-in lal]
`(~(slym wa worm.vane) gat +>.hil)
::
++ slur-a ~/(%slur-a |=({gat/vase hil/mill} =+(%a (slur gat hil))))
++ slur-b ~/(%slur-b |=({gat/vase hil/mill} =+(%b (slur gat hil))))
++ slur-c ~/(%slur-c |=({gat/vase hil/mill} =+(%c (slur gat hil))))
++ slur-d ~/(%slur-d |=({gat/vase hil/mill} =+(%d (slur gat hil))))
++ slur-e ~/(%slur-e |=({gat/vase hil/mill} =+(%e (slur gat hil))))
++ slur-f ~/(%slur-f |=({gat/vase hil/mill} =+(%f (slur gat hil))))
++ slur-g ~/(%slur-g |=({gat/vase hil/mill} =+(%g (slur gat hil))))
++ slur-i ~/(%slur-i |=({gat/vase hil/mill} =+(%i (slur gat hil))))
++ slur-j ~/(%slur-j |=({gat/vase hil/mill} =+(%j (slur gat hil))))
++ slur-z ~/(%slur-z |=({gat/vase hil/mill} =+(%z (slur gat hil))))
::
++ slur-pro :: profiling slur
~/ %slur-pro
|= {lal/@tas gat/vase hil/mill}
?+ lal (slur-z gat hil)
$a (slur-a gat hil)
$b (slur-b gat hil)
$c (slur-c gat hil)
$d (slur-d gat hil)
$e (slur-e gat hil)
$f (slur-f gat hil)
$g (slur-g gat hil)
$i (slur-i gat hil)
$j (slur-j gat hil)
==
::
++ song :: reduce metacard
~/ %song ::
|= mex/vase :: mex: vase of card
^- (unit (pair mill worm)) ::
=^ hip worm.vane (~(nell wa worm.vane) p.mex) ::
?. hip ~ :: a card is a cell
?. ?=($meta -.q.mex) `[[%& mex] worm.vane] :: ordinary card
=^ tiv worm.vane (~(slot wa worm.vane) 3 mex) ::
=^ hip worm.vane (~(nell wa worm.vane) p.tiv) ::
?. hip ~ :: a vase is a cell
=^ vax worm.vane (~(slot wa worm.vane) 2 tiv) ::
=^ hip worm.vane (~(nest wa worm.vane) typ.vil p.vax) ::
?. hip ~ :: vase head is type
%+ biff ::
=+ mut=(milt q.tiv) :: card type, value
|- ^- (unit (pair milt worm)) ::
?. ?=({$meta p/* q/milt} q.mut) `[mut worm.vane] :: ordinary metacard
=^ hip worm.vane (~(nets wa worm.vane) mev.vil p.mut)::
?. hip ~ :: meta-metacard
$(mut +.q.mut) :: descend into meta
|=(a/(pair milt worm) `[[%| p.a] q.a]) :: milt to mill
::
++ sump :: vase to move
~/ %sump
|= wec/vase
^- (unit (pair move worm))
%+ biff ((soft duct) -.q.wec)
|= a/duct
%+ bind
=- ?- -.har
%| ~& [%dead-card p.har] ~ :: XX properly log?
%& (some p.har)
==
^= har ^- (each (pair arvo worm) term)
=^ caq worm.vane (~(spot wa worm.vane) 3 wec)
?+ q.caq [%| (cat 3 %funk (symp q.caq))]
::
{$pass p/* q/@tas r/{p/@tas q/*}}
%- (bond |.([%| p.r.q.caq]))
%+ biff ((soft @) q.q.caq)
|= lal/@tas
?. ((sane %tas) lal) ~
%+ biff ((soft path) p.q.caq)
|= pax/path
=^ xav worm.vane (~(spot wa worm.vane) 7 caq)
=^ yav worm.vane (~(spot wa worm.vane) 3 xav)
%+ bind (song yav)
|= {hil/mill vel/worm}
[%& [%pass pax lal hil] vel]
::
{$give p/{p/@tas q/*}}
%- (bond |.([%| p.p.q.caq]))
=^ yav worm.vane (~(spot wa worm.vane) 3 caq)
%+ bind (song yav)
|= {hil/mill vel/worm}
[%& [%give hil] vel]
::
{$slip p/@tas q/{p/@tas q/*}}
%- (bond |.([%| p.q.q.caq]))
%+ biff ((soft @) p.q.caq)
|= lal/@tas
?. ((sane %tas) lal) ~
=^ xav worm.vane (~(spot wa worm.vane) 3 caq)
=^ yav worm.vane (~(spot wa worm.vane) 3 xav)
%+ bind (song yav)
|= {hil/mill vel/worm}
[%& [%slip lal hil] vel]
==
|=(b/(pair arvo worm) [`move`[a p.b] q.b])
::
++ said :: vase to (list move)
|= vud/vase
|- ^- (pair (list move) worm)
?: =(~ q.vud) [~ worm.vane]
=^ hed worm.vane (~(slot wa worm.vane) 2 vud)
=^ tal worm.vane (~(slot wa worm.vane) 3 vud)
=^ mov worm.vane (need (sump hed))
=^ moz worm.vane $(vud tal)
[[mov moz] worm.vane]
::
++ scry :: read namespace
~/ %scry
|= $: fur/(unit (set monk))
ren/@t
bed/beam
==
^- (unit (unit (cask milt)))
:: ~& [%arvo-scry ren bed]
=/ old=scry-sample
:* fur
ren
[%& p.bed]
q.bed
`coin`[%$ r.bed]
(flop s.bed)
==
^- (unit (unit (cask milt)))
=+ fun=-:(~(slap wa worm.vane) rig [%limb %scry])
::
%- (unit (unit (cask milt)))
(slum q.fun old)
::
++ soar :: scrub vane
|= sev/vase
^- vase
?: &(=(-.q.vase.vane -.q.sev) =(+>.q.vase.vane +>.q.sev))
vase.vane :: unchanged, use old
=| sam=vane-sample
sev(+<.q sam(ski =>(~ |~(* ~)))) :: clear to stop leak
::
++ swim
~/ %swim
|= $: org/@tas
pux/(unit wire)
hen/duct
hil/mill
==
^- [(list move) _vane]
~| [%failed-swim lal org pux]
:: ~& [%swim-wyt `@ud`~(wyt in worm.vane)]
=+ ^= pru
?~ pux
~| [%swim-call-vane lal (symp ?@(+.p.hil +.p.hil +<.p.hil))]
=^ vax worm.vane (~(slap wa worm.vane) rig [%limb %call])
%^ slur-pro lal vax
(slid [%& duc.vil hen] (slix hil))
~| [%swim-take-vane lal (symp ?@(+.p.hil +.p.hil +<.p.hil))]
=^ vax worm.vane (~(slap wa worm.vane) rig [%limb %take])
%^ slur-pro lal vax
;: slid
[%& pah.vil u.pux]
[%& duc.vil hen]
(slix (slid [%& [%atom %tas `org] org] hil))
==
?~ pru
~& [%swim-lost lal (symp +>-.hil)]
[~ [vase.vane worm.vane]]
=^ pro worm.vane (need pru)
=^ moz worm.vane (~(slot wa worm.vane) 2 pro)
=^ vem worm.vane (~(slot wa worm.vane) 3 pro)
=^ sad worm.vane (said moz)
[sad [(soar vem) worm.vane]]
--
--
::
++ vint :: create vane
|= $: who=ship
lal=@tas
vil=vile
bud=vase
pax=path
txt=@ta
==
=- ?:(?=(%| -.res) ((slog p.res) ~) (some p.res))
^= res %- mule |.
~| [%failed-vint lal]
=+ gen=(rain pax txt)
~& [%vane-parsed `@p`(mug gen)]
=+ pro=(vent who lal vil bud [(slym (slap bud gen) bud) *worm])
~& [%vane-compiled `@p`(mug pro)]
prime:pro
::
++ viol :: vane tools
|= but/type
^- vile
=+ pal=|=(a/@t ^-(type (~(play ut but) (vice a))))
:* typ=(pal '$:type')
duc=(pal '$:duct')
pah=(pal '$:path')
mev=(pal '$:{$meta $vase}')
==
::
++ is :: operate in time
|= [who=ship vil=vile eny=@ bud=vase vanes=(list [label=@tas =vane])]
|_ now/@da
++ beck
^- slyd
|= {typ/* fur/(unit (set monk)) ron/term bed/beam}
^- (unit (unit (cask milt)))
=> .(fur ?^(fur fur `[[%& p.bed] ~ ~])) :: XX heinous
=+ lal=(end 3 1 ron)
=+ ren=(@t (rsh 3 1 ron))
|- ^- (unit (unit (cask milt)))
?~ vanes ~
?. =(lal label.i.vanes) $(vanes t.vanes)
~| [%failed-scry ron bed]
%- scry:(wink:(vent who lal vil bud vane.i.vanes) now eny ..^$)
[fur ren bed]
::
++ dink :: vase by char
|= din/@tas ^- vase
?~(vanes !! ?:(=(din label.i.vanes) vase.vane.i.vanes $(vanes t.vanes)))
::
++ dint :: input routing
|= hap/path ^- @tas
?+ hap ~|([%bad-dint hap] !!)
{@ $ames *} %a
{@ $boat *} %c
{@ $newt *} %a
{@ $sync *} %c
{@ $term *} %d
{@ $http-client *} %i
{@ $http-server *} %e
{@ $behn *} %b
==
::
++ hurl :: start loop
|= {lac/? ovo/ovum}
~? !lac ["" %unix -.q.ovo p.ovo now]
:: ^- {p/(list ovum) q/(pair worm (list {p/@tas q/vase}))}
^- {p/(list ovum) q=(list [label=@tas =vane])}
?> ?=(^ p.ovo)
%+ kick lac
:~ :* i.p.ovo
~
:^ %pass t.p.ovo
(dint p.ovo)
:+ %&
[%cell [%atom %tas `%soft] %noun]
[%soft q.ovo]
0
==
==
::
++ race :: take
|= {org/@tas lal/@tas pux/(unit wire) hen/duct hil/mill =vane}
^- [p=(list move) q=_vane]
=+ ven=(vent who lal vil bud vane)
~| [%failed-take lal]
=+ win=(wink:ven now eny beck)
(swim:win org pux hen hil)
::
++ fire :: execute
|= {org/term deh/@ud lal/term pux/(unit wire) hen/duct hil/mill}
^- {{p/(list ovum) q/(list muse)} _vanes}
?: &(?=(^ pux) ?=($~ hen))
[[[[lal u.pux] (curd +>.hil)]~ ~] vanes]
=+ naf=vanes
|- ^- {{p/(list ovum) q/(list muse)} _vanes}
?~ naf [[~ ~] ~]
?. =(lal label.i.naf)
~| [%lal lal label.i.naf]
=+ tuh=$(naf t.naf)
[-.tuh [+<.tuh [i.naf +>.tuh]]]
::
=+ fiq=(race org lal pux hen hil vane.i.naf)
:- [~ (turn p.fiq |=(a/move [lal p.a q.a +(deh)]))]
[[label.i.naf q.fiq] t.naf]
::
++ jack :: dispatch card
|= {lac/? gum/muse}
^- {{p/(list ovum) q/(list muse)} _vanes}
~| %failed-jack
:: =. lac |(lac ?=(?(%g %f) p.gum))
:: =. lac &(lac !?=($b p.gum))
%^ fire
p.gum
s.gum
?- -.r.gum
$pass
~? &(!lac !=(%$ p.gum))
:- (runt [s.gum '|'] "")
:^ %pass [p.gum p.q.r.gum]
?: ?=(?(%deal %deal-gall) +>-.q.q.r.gum)
:- :- +>-.q.q.r.gum
(,[[ship ship] term term] [+>+< +>+>- +>+>+<]:q.q.r.gum)
p.r.gum
[(symp +>-.q.q.r.gum) p.r.gum]
q.gum
[p.q.r.gum ~ [[p.gum p.r.gum] q.gum] q.q.r.gum]
::
$give
?. &(?=(^ q.gum) ?=(^ i.q.gum))
~| [%jack-bad-duct q.gum]
~| [%jack-bad-card p.gum (symp +>-.p.r.gum)]
!!
~? &(!lac |(!=(%blit +>-.p.r.gum) !=(%d p.gum)))
:- (runt [s.gum '|'] "")
:^ %give p.gum
?: ?=(%unto +>-.p.r.gum)
[+>-.p.r.gum (term +>+<.p.r.gum)]
(symp +>-.p.r.gum)
`duct`q.gum
[i.i.q.gum [~ t.i.q.gum] t.q.gum p.r.gum]
::
$slip
~? !lac
:- (runt [s.gum '|'] "")
[%slip p.gum (symp +>-.q.p.r.gum) q.gum]
[p.p.r.gum ~ q.gum q.p.r.gum]
==
::
++ kick :: new main loop
|= {lac/? mor/(list muse)}
=| ova/(list ovum)
|- ^- {p/(list ovum) q=(list [label=@tas =vane])}
?~ mor
[ova vanes]
=^ nyx vanes (jack lac i.mor)
:: we emit ova to unix in fifo order, but emit internal moves depth-first
::
$(ova (weld ova p.nyx), mor (weld q.nyx t.mor))
:: +spam: kick every vane with :ovum
::
++ spam
|= [lac=? ovo=ovum]
^- [(list ovum) (list [label=@tas =vane])]
=/ card
:+ %&
[%cell [%atom %tas `%soft] %noun]
[%soft q.ovo]
%+ kick lac
%+ turn vanes
|=([label=@tas *] [label ~ [%pass p.ovo label card] 0])
--
--
=< :: Arvo larval stage
::
:: The true Arvo kernel knows who it is. It should not *maybe*
:: have an identity, nor should it contain multitudes. This outer
:: kernel exists to accumulate identity, entropy, and the
:: standard library. Upon having done so, it upgrades itself into
:: the true Arvo kernel. Subsequent upgrades will fall through
:: the larval stage directly into the actual kernel.
::
:: For convenience, this larval stage also supports hoon compilation
:: with +wish and vane installation with the %veer event.
::
=/ pit=vase !>(..is)
=| $: :: who: our identity once we know it
:: eny: entropy once we learn it
:: bod: %zuse once we receive it
::
who=(unit ship)
eny=(unit @)
bod=(unit vase)
==
:: larval Arvo structural interface
::
|%
++ come ^come :: 4
++ load ^load :: 10
++ peek |=(* ~) :: 46
::
++ poke |= * :: 47
^- [(list ovum) *]
=> .(+< ;;([now=@da ovo=ovum] +<))
^- [(list ovum) *]
=. +>.$
?+ -.q.ovo
:: ignore unrecognized
::
~& [%larval-ignore p.ovo -.q.ovo]
+>.$
:: install %zuse or vane
::
%veer
^+ +>.$
:: use the maximum comet if we don't know who we are yet
::
=/ our
?^ who
u.who
=/ fip=ship (dec (bex 128))
~>(%slog.[0 leaf+"arvo: larval identity {(scow %p fip)}"] fip)
=. ..veer (veer our now q.ovo)
+>.$(bod ?^(bod bod `bud.^poke))
:: add entropy
::
%wack
^+ +>.$
?> ?=(@ q.q.ovo)
+>.$(eny `q.q.ovo)
:: become who you were born to be
::
%whom
^+ +>.$
?> ?=(@ q.q.ovo)
+>.$(who `q.q.ovo)
==
:: upgrade once we've accumulated identity, entropy, and %zuse
::
?. &(?=(^ who) ?=(^ eny) ?=(^ bod))
[~ +>.$]
~> %slog.[0 leaf+"arvo: metamorphosis"]
=/ nyf
(turn vanes.^poke |=([label=@tas =vane] [label vase.vane]))
(load u.who now u.eny ova=~ u.bod nyf)
::
++ wish |= txt=* :: 22
?> ?=(@ txt)
q:(slap ?~(bod pit u.bod) (ream txt))
--
::
:: persistent arvo state
::
=/ pit=vase !>(..is) ::
=/ vil=vile (viol p.pit) :: cached reflexives
=| $: lac=_& :: laconic bit
eny=@ :: entropy
our=ship :: identity
bud=vase :: %zuse
vanes=(list [label=@tas =vane]) :: modules
== ::
=< :: Arvo structural interface
::
|%
++ come |= [@ @ @ (list ovum) vise pone] :: 4
^- [(list ovum) _+>]
~& %hoon-come
=^ rey +>+ (^come +<)
[rey +>.$]
::
++ load |= [@ @ @ (list ovum) vase pane] :: 10
^- [(list ovum) _+>]
~& %hoon-load
=^ rey +>+ (^load +<)
[rey +>.$]
::
++ peek |= * :: 46
=/ rob (^peek ;;([@da path] +<))
?~ rob ~
?~ u.rob ~
[~ u.u.rob]
::
++ poke |= * :: 47
=> .(+< ;;([now=@da ovo=ovum] +<))
=^ ova +>+.$ (^poke now ovo)
=| out=(list ovum)
|- ^- [(list ovum) *]
?~ ova
[(flop out) +>.^$]
:: upgrade the kernel
::
?: ?=(%lyra -.q.i.ova)
%+ fall
(vega now t.ova ;;([@ @] +.q.i.ova))
[~ +>.^$]
:: iterate over effects, handling those on arvo proper
:: and passing the rest through as output
::
=^ vov +>+.^$ (feck now i.ova)
=? out ?=(^ vov) [+.vov out]
$(ova t.ova)
::
++ wish |=(* (^wish ;;(@ta +<))) :: 22
--
:: Arvo implementation core
::
|%
++ come :: load incompatible
|= [who=ship now=@da yen=@ ova=(list ovum) dub=vise nyf=pone]
^+ [ova +>]
=/ fyn (turn nyf |=([a=@tas b=vise] [a (slim b)]))
(load who now yen ova (slim dub) fyn)
::
++ load :: load compatible
|= [who=ship now=@da yen=@ ova=(list ovum) dub=vase nyf=pane]
^+ [ova +>]
=: our who
eny yen
bud dub
vanes (turn nyf |=({a/@tas b/vise} [a [b *worm]]))
==
=| out=(list ovum)
|- ^- [(list ovum) _+>.^$]
?~ ova
[(flop out) +>.^$]
:: iterate over effects, handling those on arvo proper
:: and passing the rest through as output
::
:: In practice, the pending effects after an upgrade
:: are the %veer moves to install %zuse and the vanes,
:: plus a %vega notification that the upgrade is complete.
::
:: N.B. this implementation assumes that %vega will be
:: at the end of :ova.
::
?: ?=(%vega -.q.i.ova)
=^ zef vanes
(~(spam (is our vil eny bud vanes) now) lac i.ova)
$(out [i.ova out], ova (weld t.ova zef))
::
=^ vov +>.^$ (feck now i.ova)
=? out ?=(^ vov) [+.vov out]
$(ova t.ova)
::
++ peek :: external inspect
|= {now/@da hap/path}
^- (unit (unit))
?~ hap [~ ~ hoon-version]
((sloy ~(beck (is our vil eny bud vanes) now)) [151 %noun] hap)
::
++ poke :: external apply
|= [now=@da ovo=ovum]
=. eny (shaz (cat 3 eny now))
^- [(list ovum) _+>.$]
::
:: These external events are actually effects on arvo proper.
:: They can also be produced as the effects of other events.
:: In either case, they fall through here to be handled
:: after the fact in +feck.
::
?: ?=(?(%veer %verb %wack %warn) -.q.ovo)
[[ovo ~] +>.$]
::
:: These external events (currently only %trim) are global
:: notifications, spammed to every vane
::
?: ?=(%trim -.q.ovo)
=> .(ovo ;;((pair wire [%trim p=@ud]) ovo))
=^ zef vanes
(~(spam (is our vil eny bud vanes) now) lac ovo)
:: clear compiler caches if high-priority
::
=? vanes =(0 p.q.ovo)
~> %slog.[0 leaf+"arvo: trim: clearing caches"]
(turn vanes |=([a=@tas =vane] [a vase.vane *worm]))
[zef +>.$]
::
:: Normal events are routed to a single vane
::
=^ zef vanes
(~(hurl (is our vil eny bud vanes) now) lac ovo)
[zef +>.$]
:: +feck: handle an arvo effect
::
++ feck
|= [now=@da ovo=ovum]
^- [(unit ovum) _+>.$]
?+ -.q.ovo
:: pass through unrecognized effect
::
[[~ ovo] +>.$]
:: toggle event verbose event printfs
::
%verb
[~ +>.$(lac !lac)]
:: install %zuse or vane
::
%veer
[~ (veer our now q.ovo)]
:: add data to memory profile
::
%mass
=. q.q.ovo
:- %userspace
:- %|
:~ hoon+&+pit
zuse+&+bud
:+ %caches %|
%+ turn
%+ sort vanes
|=([a=[lab=@tas *] b=[lab=@tas *]] (aor lab.a lab.b))
|=([label=@tas =vane] [(cat 3 %vane- label) %& worm.vane])
q.q.ovo
:+ %vases %|
%+ turn
%+ sort vanes
|=([a=[lab=@tas *] b=[lab=@tas *]] (aor lab.a lab.b))
|=([label=@tas =vane] [(cat 3 %vane- label) %& vase.vane])
dot+&+.
==
[[~ ovo] +>.$]
:: add entropy
::
%wack
?> ?=(@ q.q.ovo)
=. eny (shaz (cat 3 eny q.q.ovo))
[~ +>.$]
:: learn of event-replacement failure
::
%warn
:_ +>.$
?. ?=(^ +.q.ovo)
~
=/ msg=tape
:(weld "(for %" (trip (symp +<.q.ovo)) ") failed")
~> %slog.[0 leaf+(weld "arvo: replacement event " msg)]
?: lac
~
=/ rep
%- mule |.
((slog (tang +>.q.ovo)) ~)
?.(?=(%& -.rep) ~ p.rep)
==
::
++ vega :: reboot kernel
|= $: :: now: current date
:: ova: actions to process after reboot
:: hun: hoon.hoon source
:: arv: arvo.hoon source
::
now=@da
ova=(list ovum)
hun=@t
van=@t
==
^- (unit (pair (list ovum) *))
:: virtualize; dump error if we fail
::
=- ?:(?=(%| -.res) ((slog p.res) ~) `p.res)
^= res %- mule |.
:: produce a new kernel and an effect list
::
^- (pair (list ovum) *)
:: compile the hoon.hoon source with the current compiler
::
=/ raw
~& [%hoon-compile `@p`(mug hun)]
(ride %noun hun)
:: activate the new compiler gate, producing +ride
::
=/ cop .*(0 +.raw)
:: find the hoon version number of the new kernel
::
=/ nex
(@ .*(cop q:(~(mint ut p.raw) %noun [%limb %hoon-version])))
?> |(=(nex hoon-version) =(+(nex) hoon-version))
:: if we're upgrading language versions, recompile the compiler
::
:: hot: raw compiler formula
::
=> ?: =(nex hoon-version)
[hot=`*`raw .]
~& [%hoon-compile-upgrade nex]
=/ hot (slum cop [%noun hun])
.(cop .*(0 +.hot))
:: extract the hoon core from the outer gate (+ride)
::
=/ hoc .*(cop [%0 7])
:: compute the type of the hoon.hoon core
::
=/ hyp -:(slum cop [-.hot '+>'])
:: compile arvo
::
=/ rav
~& [%arvo-compile `@p`(mug hyp) `@p`(mug van)]
(slum cop [hyp van])
:: activate arvo, and extract the arvo core from the outer gate
::
=/ voc .*(hoc [%7 +.rav %0 7])
:: entry gate: ++load for the normal case, ++come for upgrade
::
=/ gat
=/ arm ?:(=(nex hoon-version) 'load' 'come')
:: compute the type of the arvo.hoon core
::
=/ vip -:(slum cop [-.rav '+>'])
:: compute the formula for the upgrade gate
::
=/ fol +:(slum cop [vip arm])
:: produce the upgrade gate
::
.*(voc fol)
:: upgrade gate sample
::
=/ sam
:* our
now
eny
:: tack a notification onto the pending effects
::
(weld ova [`ovum`[/ %vega ~] ~])
bud
(turn vanes |=([label=@tas =vane] [label vase.vane]))
==
:: call into the new kernel
::
=/ out (slum gat sam)
:: add types to the product
::
[((list ovum) -.out) +.out]
:: +veer: install %zuse or a vane
::
:: Identity is in the sample so the larval stage
:: can use this as well.
::
++ veer
|= [who=ship now=@da fav=curd]
=> .(fav ;;({$veer lal/@ta pax/path txt/@t} fav))
=- ?:(?=(%| -.res) ((slog p.res) +>.$) p.res)
^= res %- mule |.
?: =(%$ lal.fav)
~& [%tang pax.fav `@p`(mug txt.fav)]
=+ gen=(rain pax.fav txt.fav)
=+ vax=(slap pit gen)
+>.^$(bud vax)
%_ +>.^$
vanes
|- ^+ vanes
?~ vanes
~& [%vane `@tas`lal.fav pax.fav `@p`(mug txt.fav)]
=+ vin=(vint who lal.fav vil bud pax.fav txt.fav)
?~ vin
vanes
[[lal.fav vane:u.vin] vanes]
?. =(lal.fav label.i.vanes)
[i.vanes $(vanes t.vanes)]
~& [%vane `@tas`lal.fav pax.fav `@p`(mug txt.fav)]
:_ t.vanes
:- label.i.vanes
~| [%failed-vane-activation now lal.fav]
vane:(ruck:(vent who lal.fav vil bud [vase.vane.i.vanes *worm]) pax.fav txt.fav)
==
::
++ wish :: external compute
|= txt/@
q:(slap bud (ream txt))
--
Reference in New Issue View Git Blame Copy Permalink