mirror of
https://github.com/urbit/shrub.git
synced 2024-12-22 10:21:31 +03:00
448 lines
11 KiB
Plaintext
448 lines
11 KiB
Plaintext
/- spider
|
|
/+ libthread=thread, default-agent, verb
|
|
=, thread=thread:libthread
|
|
|%
|
|
+$ card card:agent:mall
|
|
+$ imp-thread imp:spider
|
|
+$ iid iid:spider
|
|
+$ imput imput:spider
|
|
+$ imp (list iid)
|
|
+$ imp-form _*eval-form:eval:(thread ,vase)
|
|
+$ trie
|
|
$~ [*imp-form ~]
|
|
[=imp-form kid=(map iid trie)]
|
|
::
|
|
+$ state
|
|
$: started=(map imp vase)
|
|
running=trie
|
|
iid=(map iid imp)
|
|
==
|
|
::
|
|
+$ clean-slate
|
|
$: started=(map imp vase)
|
|
running=(list imp)
|
|
iid=(map iid imp)
|
|
==
|
|
::
|
|
+$ start-args
|
|
[parent=(unit iid) use=(unit iid) file=term =vase]
|
|
--
|
|
::
|
|
:: Trie operations
|
|
::
|
|
|%
|
|
++ get-imp
|
|
|= [=trie =imp]
|
|
^- (unit =imp-form)
|
|
?~ imp
|
|
`imp-form.trie
|
|
=/ son (~(get by kid.trie) i.imp)
|
|
?~ son
|
|
~
|
|
$(trie u.son, imp t.imp)
|
|
::
|
|
++ get-imp-children
|
|
|= [=trie =imp]
|
|
^- (list ^imp)
|
|
?~ imp
|
|
(turn (tap-imp trie) head)
|
|
=/ son (~(get by kid.trie) i.imp)
|
|
?~ son
|
|
~
|
|
$(trie u.son, imp t.imp)
|
|
::
|
|
::
|
|
++ has-imp
|
|
|= [=trie =imp]
|
|
!=(~ (get-imp trie imp))
|
|
::
|
|
++ put-imp
|
|
|= [=trie =imp =imp-form]
|
|
^+ trie
|
|
?~ imp
|
|
trie(imp-form imp-form)
|
|
=/ son (~(gut by kid.trie) i.imp [*^imp-form ~])
|
|
%= trie
|
|
kid
|
|
%+ ~(put by kid.trie) i.imp
|
|
$(trie son, imp t.imp)
|
|
==
|
|
::
|
|
++ del-imp
|
|
|= [=trie =imp]
|
|
^+ trie
|
|
?~ imp
|
|
trie
|
|
|-
|
|
?~ t.imp
|
|
trie(kid (~(del by kid.trie) i.imp))
|
|
=/ son (~(get by kid.trie) i.imp)
|
|
?~ son
|
|
trie
|
|
%= trie
|
|
kid
|
|
%+ ~(put by kid.trie) i.imp
|
|
$(trie u.son, imp t.imp)
|
|
==
|
|
::
|
|
++ tap-imp
|
|
=| =imp
|
|
|= =trie
|
|
^- (list [=^imp =imp-form])
|
|
%+ welp
|
|
?~ imp
|
|
~
|
|
[(flop imp) imp-form.trie]~
|
|
=/ kids ~(tap by kid.trie)
|
|
|- ^- (list [=^imp =imp-form])
|
|
?~ kids
|
|
~
|
|
=/ next-1 ^$(imp [p.i.kids imp], trie q.i.kids)
|
|
=/ next-2 $(kids t.kids)
|
|
(welp next-1 next-2)
|
|
--
|
|
::
|
|
^- agent:mall
|
|
=| =state
|
|
=<
|
|
%+ verb &
|
|
|_ =bowl:mall
|
|
+* this .
|
|
spider-core +>
|
|
sc ~(. spider-core bowl)
|
|
def ~(. (default-agent this %|) bowl)
|
|
::
|
|
++ on-init on-init:def
|
|
++ on-save clean-state:sc
|
|
++ on-load
|
|
|= old-state=vase
|
|
=+ !<(=clean-slate old-state)
|
|
=. iid.state iid.clean-slate
|
|
|- ^- (quip card _this)
|
|
?~ running.clean-slate
|
|
`this
|
|
=^ cards-1 state
|
|
(handle-stop-imp:sc (imp-to-iid i.running.clean-slate) |)
|
|
=^ cards-2 this
|
|
$(running.clean-slate t.running.clean-slate)
|
|
[(weld cards-1 cards-2) this]
|
|
::
|
|
++ on-poke
|
|
|= [=mark =vase]
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ mark (on-poke:def mark vase)
|
|
%spider-imput (on-poke-imput:sc !<(imput vase))
|
|
%spider-start (handle-start-imp:sc !<(start-args vase))
|
|
%spider-stop (handle-stop-imp:sc !<([iid ?] vase))
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-watch
|
|
|= =path
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ path (on-watch:def path)
|
|
[%imp @ *] (on-watch:sc t.path)
|
|
[%imp-result @ ~] (on-watch-result:sc i.t.path)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-leave on-leave:def
|
|
++ on-peek
|
|
|= =path
|
|
^- (unit (unit cage))
|
|
?+ path (on-peek:def path)
|
|
[%x %tree ~]
|
|
``noun+!>((turn (tap-imp running.state) head))
|
|
::
|
|
[%x %started @ ~]
|
|
``noun+!>((has-imp running.state (~(got by iid.state) i.t.t.path)))
|
|
::
|
|
[%x %saxo @ ~]
|
|
``noun+!>((~(got by iid.state) i.t.t.path))
|
|
==
|
|
::
|
|
++ on-agent
|
|
|= [=wire =sign:agent:mall]
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ wire !!
|
|
[%imp @ *] (on-agent:sc i.t.wire t.t.wire sign)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-arvo
|
|
|= [=wire =sign-arvo]
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ wire (on-arvo:def wire sign-arvo)
|
|
[%imp @ *] (handle-sign:sc i.t.wire t.t.wire sign-arvo)
|
|
[%find @ ~] (handle-find:sc i.t.wire sign-arvo)
|
|
[%build @ ~] (handle-build:sc i.t.wire sign-arvo)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-fail on-fail:def
|
|
--
|
|
::
|
|
|_ =bowl:mall
|
|
++ on-poke-imput
|
|
|= imput
|
|
=/ imp (~(got by iid.state) iid)
|
|
(take-input imp ~ %poke cage)
|
|
::
|
|
++ on-watch
|
|
|= [=iid =path]
|
|
(take-input (~(got by iid.state) iid) ~ %watch path)
|
|
::
|
|
++ on-watch-result
|
|
|= =iid
|
|
^- (quip card ^state)
|
|
`state
|
|
::
|
|
++ handle-sign
|
|
|= [=iid =wire =sign-arvo]
|
|
=/ imp (~(get by iid.state) iid)
|
|
?~ imp
|
|
%- (slog leaf+"spider got sign for non-existent {<iid>}" ~)
|
|
`state
|
|
(take-input u.imp ~ %sign wire sign-arvo)
|
|
::
|
|
++ on-agent
|
|
|= [=iid =wire =sign:agent:mall]
|
|
=/ imp (~(get by iid.state) iid)
|
|
?~ imp
|
|
%- (slog leaf+"spider got agent for non-existent {<iid>}" ~)
|
|
`state
|
|
(take-input u.imp ~ %agent wire sign)
|
|
::
|
|
++ handle-start-imp
|
|
|= [parent-iid=(unit iid) use=(unit iid) file=term =vase]
|
|
^- (quip card ^state)
|
|
=/ parent-imp=imp
|
|
?~ parent-iid
|
|
/
|
|
(~(got by iid.state) u.parent-iid)
|
|
=/ new-iid (fall use (scot %uv (sham eny.bowl)))
|
|
=/ =imp (snoc parent-imp new-iid)
|
|
::
|
|
?: (has-imp running.state imp)
|
|
~| [%already-started imp]
|
|
!!
|
|
?: (~(has by started.state) imp)
|
|
~| [%already-starting imp]
|
|
!!
|
|
::
|
|
=: started.state (~(put by started.state) imp vase)
|
|
iid.state (~(put by iid.state) new-iid imp)
|
|
==
|
|
=/ =card
|
|
=/ =schematic:ford [%path [our.bowl %home] %imp file]
|
|
[%pass /find/[new-iid] %arvo %f %build live=%.n schematic]
|
|
[[card ~] state]
|
|
::
|
|
++ handle-find
|
|
|= [=iid =sign-arvo]
|
|
^- (quip card ^state)
|
|
=/ =imp (~(got by iid.state) iid)
|
|
?> (~(has by started.state) imp)
|
|
?> ?=([%f %made *] sign-arvo)
|
|
?: ?=(%incomplete -.result.sign-arvo)
|
|
%- (slog leaf+"{<imp>} find incomplete" tang.result.sign-arvo)
|
|
`state
|
|
=/ =build-result:ford build-result.result.sign-arvo
|
|
?: ?=(%error -.build-result)
|
|
%- (slog leaf+"{<imp>} find error" message.build-result)
|
|
`state
|
|
?. ?=([%path *] +.build-result)
|
|
%- (slog leaf+"{<imp>} find strange" ~)
|
|
`state
|
|
=/ =card
|
|
=/ =schematic:ford [%core rail.build-result]
|
|
[%pass /build/[iid] %arvo %f %build live=%.y schematic]
|
|
[[card ~] state]
|
|
::
|
|
++ handle-build
|
|
|= [=iid =sign-arvo]
|
|
^- (quip card ^state)
|
|
=/ =imp (~(got by iid.state) iid)
|
|
?> (~(has by started.state) imp)
|
|
?> ?=([%f %made *] sign-arvo)
|
|
?: ?=(%incomplete -.result.sign-arvo)
|
|
%- (slog leaf+"{<imp>} build incomplete" tang.result.sign-arvo)
|
|
`state
|
|
=/ =build-result:ford build-result.result.sign-arvo
|
|
?: ?=(%error -.build-result)
|
|
%- (slog leaf+"{<imp>} build error" message.build-result)
|
|
`state
|
|
=/ =cage (result-to-cage:ford build-result)
|
|
?. ?=(%noun p.cage)
|
|
%- (slog leaf+"{<imp>} build not noun, is {<p.cage>}" ~)
|
|
`state
|
|
=/ maybe-imp (mule |.(!<(imp-thread q.cage)))
|
|
?: ?=(%| -.maybe-imp)
|
|
%- (slog leaf+"{<imp>} not valid imp" p.maybe-imp)
|
|
`state
|
|
(start-imp imp p.maybe-imp)
|
|
::
|
|
++ start-imp
|
|
|= [=imp =imp-thread]
|
|
^- (quip card ^state)
|
|
=/ =vase (~(got by started.state) imp)
|
|
=^ cards-1 state
|
|
?. (has-imp running.state imp)
|
|
`state
|
|
(imp-fail imp %updated ~)
|
|
=/ m (thread ,^vase)
|
|
=/ =bowl:spider (convert-bowl imp bowl)
|
|
=/ =eval-form:eval:m
|
|
(from-form:eval:m (imp-thread bowl vase))
|
|
=. running.state (put-imp running.state imp eval-form)
|
|
=^ cards-2 state
|
|
(take-input imp ~)
|
|
[(weld cards-1 cards-2) state]
|
|
::
|
|
++ handle-stop-imp
|
|
|= [=iid nice=?]
|
|
^- (quip card ^state)
|
|
=/ =imp (~(got by iid.state) iid)
|
|
~? !(has-imp running.state imp)
|
|
[%not-started imp]
|
|
?: nice
|
|
(imp-done imp *vase)
|
|
(imp-fail imp %cancelled ~)
|
|
::
|
|
++ take-input
|
|
|= [=imp input=(unit input:thread)]
|
|
^- (quip card ^state)
|
|
=/ m (thread ,vase)
|
|
?. (has-imp running.state imp)
|
|
%- (slog leaf+"spider got input for non-existent {<imp>} 2" ~)
|
|
`state
|
|
=/ =eval-form:eval:m
|
|
imp-form:(need (get-imp running.state imp))
|
|
=| cards=(list card)
|
|
|- ^- (quip card ^state)
|
|
=^ r=[cards=(list card) =eval-result:eval:m] eval-form
|
|
=/ out
|
|
%- mule |.
|
|
(take:eval:m eval-form (convert-bowl imp bowl) input)
|
|
?- -.out
|
|
%& p.out
|
|
%| [[~ [%fail %crash p.out]] eval-form]
|
|
==
|
|
=. running.state (put-imp running.state imp eval-form)
|
|
=/ =iid (imp-to-iid imp)
|
|
=. cards.r
|
|
%+ turn cards.r
|
|
|= =card
|
|
^- ^card
|
|
?+ card card
|
|
[%pass * *] [%pass [%imp iid p.card] q.card]
|
|
[%give %fact *]
|
|
?~ path.p.card
|
|
card
|
|
card(path.p `[%imp iid u.path.p.card])
|
|
::
|
|
[%give %kick *]
|
|
?~ path.p.card
|
|
card
|
|
card(path.p `[%imp iid u.path.p.card])
|
|
==
|
|
=. cards (weld cards cards.r)
|
|
=^ final-cards=(list card) state
|
|
?- -.eval-result.r
|
|
%next `state
|
|
%fail (imp-fail imp err.eval-result.r)
|
|
%done (imp-done imp value.eval-result.r)
|
|
==
|
|
[(weld cards final-cards) state]
|
|
::
|
|
++ imp-fail
|
|
|= [=imp =term =tang]
|
|
^- (quip card ^state)
|
|
%- (slog leaf+"thread {<imp>} failed" leaf+<term> tang)
|
|
=/ =iid (imp-to-iid imp)
|
|
=/ fail-cards=(list card)
|
|
:~ [%give %fact `/imp-result/[iid] %imp-fail !>([term tang])]
|
|
[%give %kick `/imp-result/[iid] ~]
|
|
==
|
|
=^ cards state (imp-clean imp)
|
|
[(weld fail-cards cards) state]
|
|
::
|
|
++ imp-done
|
|
|= [=imp =vase]
|
|
^- (quip card ^state)
|
|
:: %- (slog leaf+"thread {<imp>} finished" (sell vase) ~)
|
|
=/ =iid (imp-to-iid imp)
|
|
=/ done-cards=(list card)
|
|
:~ [%give %fact `/imp-result/[iid] %imp-done vase]
|
|
[%give %kick `/imp-result/[iid] ~]
|
|
==
|
|
=^ cards state (imp-clean imp)
|
|
[(weld done-cards cards) state]
|
|
::
|
|
++ imp-clean
|
|
|= =imp
|
|
^- (quip card ^state)
|
|
=/ children=(list ^imp)
|
|
[imp (get-imp-children running.state imp)]
|
|
|- ^- (quip card ^state)
|
|
?~ children
|
|
`state
|
|
=^ cards-children state $(children t.children)
|
|
=^ cards-our state
|
|
=/ =^imp i.children
|
|
=/ =iid (imp-to-iid imp)
|
|
=: started.state (~(del by started.state) imp)
|
|
running.state (del-imp running.state imp)
|
|
iid.state (~(del by iid.state) iid)
|
|
==
|
|
:_ state
|
|
:- [%pass /build/[iid] %arvo %f %kill ~]
|
|
%+ murn ~(tap by wex.bowl)
|
|
|= [[=wire =ship =term] [acked=? =path]]
|
|
^- (unit card)
|
|
?. ?& ?=([%imp @ *] wire)
|
|
=(iid i.t.wire)
|
|
==
|
|
~
|
|
`[%pass wire %agent [ship term] %leave ~]
|
|
[(welp cards-children cards-our) state]
|
|
::
|
|
++ convert-bowl
|
|
|= [=imp =bowl:mall]
|
|
^- bowl:spider
|
|
:* our.bowl
|
|
src.bowl
|
|
(imp-to-iid imp)
|
|
(imp-to-parent imp)
|
|
wex.bowl
|
|
sup.bowl
|
|
eny.bowl
|
|
now.bowl
|
|
byk.bowl
|
|
==
|
|
::
|
|
++ imp-to-iid
|
|
|= =imp
|
|
^- iid
|
|
=/ fimp (flop imp)
|
|
?> ?=([@ *] fimp)
|
|
i.fimp
|
|
::
|
|
++ imp-to-parent
|
|
|= =imp
|
|
^- (unit iid)
|
|
=/ fimp (flop imp)
|
|
?> ?=([@ *] fimp)
|
|
?~ t.fimp
|
|
~
|
|
`i.t.fimp
|
|
::
|
|
++ clean-state
|
|
!> ^- clean-slate
|
|
state(running (turn (tap-imp running.state) head))
|
|
--
|