diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/concurrency/space.lux | 150 | ||||
| -rw-r--r-- | stdlib/test/test/lux/concurrency/space.lux | 23 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 2 |
3 files changed, 175 insertions, 0 deletions
diff --git a/stdlib/source/lux/concurrency/space.lux b/stdlib/source/lux/concurrency/space.lux new file mode 100644 index 000000000..7092e2395 --- /dev/null +++ b/stdlib/source/lux/concurrency/space.lux @@ -0,0 +1,150 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser]) + (concurrency ["P" promise] + ["T" task] + ["A" actor #+ actor:]) + (data [product] + (coll [list "L/" Functor<List>])) + [io #- run] + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) + +(with-expansions + [<Event> [e (A;Actor Top) (Space e)] + <Action> (as-is (-> <Event> (A;Actor s) (T;Task Unit)))] + (type: #export (Space e) + (A;Actor (List (Ex [s] [(A;Actor s) <Action>])))) + + (type: #export (Event e) + <Event>) + + (type: #export (Action e) + (All [s] <Action>))) + +(exception: #export Closed-Space) + +(def: (send-space message space) + (All [s] (-> (A;Message s) (A;Actor s) (T;Task Unit))) + (P;future (do Monad<IO> + [success? (A;send message space)] + (wrap (if success? + (ex;return []) + (ex;throw Closed-Space "")))))) + +(def: #export (subscribe actor action space) + (All [e s] (-> (A;Actor s) (Action e s) (Space e) (T;Task Unit))) + (send-space (function [subscriptions _] + (T;return (|> subscriptions + (list;filter (|>. product;left (:! []) (is (:! [] actor)) not)) + (#;Cons [actor action])))) + space)) + +(def: #export (un-subscribe actor space) + (All [e s] (-> (A;Actor s) (Space e) (T;Task Unit))) + (send-space (function [subscriptions _] + (T;return (|> subscriptions + (list;filter (|>. product;left (:! []) (is (:! [] actor)) not))))) + space)) + +(def: #export (emit event space sender) + (All [e s] (-> e (Space e) (A;Actor s) (T;Task Unit))) + (send-space (function [subscriptions _] + (exec (monad;map T;Monad<Task> + (function [[receiver action]] + (if (is (:! [] receiver) (:! [] sender)) + (T;return []) + (action [event sender space] receiver))) + subscriptions) + (T;return subscriptions))) + space)) + +(def: #export space + (All [e] (IO (Space e))) + (A;spawn A;default-behavior (list))) + +(type: ActionS + {#action-name Text + #sender-name Text + #space-name Text + #event Code + #state Code + #receiver-name Text}) + +(def: reference^ + (s;Syntax [Ident (List Code)]) + (p;either (s;form (p;seq s;symbol (p;some s;any))) + (p;seq s;symbol (:: p;Monad<Parser> wrap (list))))) + +(def: action^ + (s;Syntax ActionS) + (s;form ($_ p;seq + s;local-symbol + s;local-symbol + s;local-symbol + s;any + s;any + s;local-symbol))) + +(def: type-vars^ + (s;Syntax (List Text)) + (p;either (s;tuple (p;some s;local-symbol)) + (:: p;Monad<Parser> wrap (list)))) + +(def: #hidden _future P;future) + +(syntax: #export (on: [export csr;export] + [t-vars type-vars^] + [[actor-name actor-params] reference^] + eventT + [declaration action^] + [annotations (p;default cs;empty-annotations csr;annotations)] + body) + {#;doc (doc (type: Move + #Ping + #Pong) + + (actor: #export Player {} + {#hits Nat}) + + (on: #export Move (counter move space hits self) + (do @ + [_ (emit (case move + #;Ping #;Pong + #;Pong #;Ping) + space + self)] + (wrap (n.inc hits)))))} + (with-gensyms [g!_] + (do @ + [actor-name (A;resolve-actor actor-name) + #let [stateT (` ((~ (code;symbol (product;both id A;state-name actor-name))) + (~@ actor-params))) + g!actionL (code;local-symbol (get@ #action-name declaration)) + g!senderL (code;local-symbol (get@ #sender-name declaration)) + g!spaceL (code;local-symbol (get@ #space-name declaration)) + g!receiverL (code;local-symbol (get@ #receiver-name declaration)) + g!event (get@ #event declaration) + g!state (get@ #state declaration)]] + (wrap (list (` (def: (~@ (csw;export export)) ((~ g!actionL) [(~ g!event) (~ g!senderL) (~ g!spaceL)] (~ g!receiverL)) + (~ (csw;annotations annotations)) + (All [(~@ (L/map code;local-symbol t-vars))] + (;;Action (~ eventT) (~ stateT))) + (monad;do T;Monad<Task> + [(~ g!_) (T;from-promise + (_future + (A;send (function [(~ g!state) (~ g!receiverL)] + (: (T;Task (~ stateT)) + (do T;Monad<Task> + [] + (~ body)))) + (~ g!receiverL))))] + ((~' wrap) [])) + )))) + ))) diff --git a/stdlib/test/test/lux/concurrency/space.lux b/stdlib/test/test/lux/concurrency/space.lux new file mode 100644 index 000000000..d99733958 --- /dev/null +++ b/stdlib/test/test/lux/concurrency/space.lux @@ -0,0 +1,23 @@ +(;module: + lux + (lux (control [monad #+ do]) + (concurrency ["T" task] + ["A" actor #+ actor:] + ["S" space #+ on:]) + [io])) + +(type: Move + #Ping + #Pong) + +(A;actor: #export Player {} + {#hits Nat}) + +(on: Player Move (reply! who where what state self) + (do @ + [_ (S;emit (case what + #Ping #Pong + #Pong #Ping) + where + self)] + (wrap (update@ #hits n.inc state)))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 39ac02d5e..2f1da760f 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -13,6 +13,7 @@ ["_;" duration] ["_;" date]) (concurrency ["_;" actor] + ["_;" space] ["_;" atom] ["_;" frp] ["_;" promise] @@ -71,6 +72,7 @@ )) (lux (control [contract] [concatenative]) + (concurrency [space]) (data [env] [trace] [store] |