aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/concurrency/space.lux150
-rw-r--r--stdlib/test/test/lux/concurrency/space.lux23
-rw-r--r--stdlib/test/tests.lux2
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]