diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/concurrency/actor.lux | 338 |
1 files changed, 209 insertions, 129 deletions
diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index 0b9c1032f..91e4f7a4a 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -7,7 +7,7 @@ (data text/format (coll [list "L/" Monoid<List> Monad<List>]) [product]) - [macro #+ with-gensyms] + [macro #+ with-gensyms Monad<Lux>] (macro [code] ["s" syntax #+ syntax: Syntax] (syntax ["cs" common] @@ -41,14 +41,22 @@ (type: #export (Behavior s) {#;doc "An actor's behavior when messages are received."} - {#step (-> (Message s) s (Actor s) (T;Task s)) + {#handle (-> (Message s) s (Actor s) (T;Task s)) #end (-> Text s (P;Promise Unit))}) ## [Values] -(def: #export (spawn init behavior) +(def: #export (default-handle message state self) + (All [s] (-> (Message s) s (Actor s) (T;Task s))) + (message state self)) + +(def: #export (default-end cause state) + (All [s] (-> Text s (P;Promise Unit))) + (P/wrap [])) + +(def: #export (spawn behavior init) {#;doc "Given a behavior and initial state, spawns an actor and returns it."} - (All [s] (-> s (Behavior s) (IO (Actor s)))) - (io (let [[step end] behavior + (All [s] (-> (Behavior s) s (IO (Actor s)))) + (io (let [[handle end] behavior self (: (Actor ($ +0)) {#mailbox (stm;var (:! (Message ($ +0)) [])) #kill-switch (P;promise Unit) @@ -69,7 +77,7 @@ (#;Some [message messages']) (do P;Monad<Promise> [#let [_ (io;run (stm;write! messages' |mailbox|))] - ?state' (step message state self)] + ?state' (handle message state self)] (case ?state' (#;Left error) (do @ @@ -125,137 +133,209 @@ actor)) ## [Syntax] -(type: Method - {#name Text - #vars (List Text) - #args (List [Text Code]) - #state Text - #self Text - #return Code - #body Code}) - -(def: method^ - (Syntax Method) - (s;form (do p;Monad<Parser> - [vars (p;default (list) (s;tuple (p;some s;local-symbol))) - [name args state self] (s;form ($_ p;seq - s;local-symbol - (p;some csr;typed-input) - s;local-symbol - s;local-symbol - )) - return s;any - body s;any] - (wrap {#name name - #vars vars - #args args - #state state - #self self - #return return - #body body})))) - -(def: stop^ - (Syntax [[Text Text] Code]) - (s;form (p;seq (s;tuple (p;seq s;local-symbol - s;local-symbol)) - s;any))) +(do-template [<with> <resolve> <tag> <desc>] + [(def: (<with> name) + (-> Ident cs;Annotations cs;Annotations) + (|>. (#;Cons [(ident-for <tag>) + (code;tag name)]))) + + (def: (<resolve> name) + (-> Ident (Lux Ident)) + (do Monad<Lux> + [name (macro;normalize name) + [_ annotations _] (macro;find-def name)] + (case (macro;get-ident-ann (ident-for <tag>) annotations) + (#;Some actor-name) + (wrap actor-name) + + _ + (macro;fail (format "Definition is not " <desc> ".")))))] + + [with-actor resolve-actor #;;actor "an actor"] + [with-message resolve-message #;;message "a message"] + ) (def: actor-decl^ - (Syntax [(List Text) Text (List [Text Code])]) - (p;seq (p;default (list) (s;tuple (p;some s;local-symbol))) - (p;either (s;form (p;seq s;local-symbol (p;many csr;typed-input))) - (p;seq s;local-symbol (:: p;Monad<Parser> wrap (list)))))) + (Syntax [Text (List Text)]) + (p;either (s;form (p;seq s;local-symbol (p;some s;local-symbol))) + (p;seq s;local-symbol (:: p;Monad<Parser> wrap (list))))) + +(do-template [<name> <desc>] + [(def: <name> + (-> Text Text) + (|>. (format <desc> "@")))] + + [state-name "State"] + [behavior-name "Behavior"] + [new-name "new"] + ) + +(type: HandleC + [[Text Text Text] Code]) + +(type: StopC + [[Text Text] Code]) + +(type: BehaviorC + [(Maybe HandleC) (Maybe StopC)]) + +(def: behavior^ + (s;Syntax BehaviorC) + (let [handle-args ($_ p;seq s;local-symbol s;local-symbol s;local-symbol) + stop-args ($_ p;seq s;local-symbol s;local-symbol)] + (p;seq (p;opt (s;form (p;seq (s;form (p;after (s;this (' handle)) handle-args)) + s;any))) + (p;opt (s;form (p;seq (s;form (p;after (s;this (' stop)) stop-args)) + s;any)))))) (syntax: #export (actor: [export csr;export] - [[_vars _name _args] actor-decl^] + [[_name _vars] actor-decl^] + [annotations (p;default cs;empty-annotations csr;annotations)] state-type - [methods (p;some method^)] - [?stop (p;opt stop^)]) - {#;doc (doc "Defines an actor, with internal state and methods that can be called on it." - "A method can access the actor's state through the state parameter." - "A method can also access the actor itself through the self parameter." - "A method may succeed or fail (in case of failure, the actor dies). This is handled through the Either type." - "A method's output must be a promise containing a 2-tuple with the updated state and a return value." - "All methods are run implicitly within the Promise monad." - + [[?handle ?stop] behavior^]) + {#;doc (doc "Defines an actor, with its behavior and internal state." (actor: #export Counter - Int + Nat - ((count! [increment Int] state self) - [Int Int] - (if (i.>= 0 increment) - (let [state' (i.+ increment state)] - (T;return [state' [state state']])) - (T;fail "Cannot add negative numbers!"))) - - ([cause state] + ((stop cause state) (:: P;Monad<Promise> wrap (log! (if (ex;match? ;;Killed cause) - (format "Counter was killed: " (%i state)) - cause)))) - ))} + (format "Counter was killed: " (%n state)) + cause))))) + + (actor: #export (Stack a) + (List a) + + ((handle message state self) + (do T;Monad<Task> + [#let [_ (log! "BEFORE")] + output (message state self) + #let [_ (log! "AFTER")]] + (wrap output)))))} (with-gensyms [g!message g!self g!state g!init g!error g!return g!output] - (let [g!state-type (code;symbol ["" (format _name "//Actor:State")]) - g!behavior (code;symbol ["" (format _name "//Actor:Behavior")]) - g!actor (code;symbol ["" _name]) - g!methods (L/map (: (-> Method Code) - (function [(^slots [#name #vars #args #state #self #return #body])] - (let [g!method (code;symbol ["" name]) - g!vars (L/map (|>. [""] code;symbol) vars) - g!var-refs (: (List Code) - (if (list;empty? vars) - (list) - (|> vars list;size n.dec - (list;n.range +0) (L/map (|>. code;nat (~) ($) (`)))))) - g!args-names (L/map (|>. product;left [""] code;symbol) args) - g!arg-types (L/map product;right args) - g!state (code;symbol ["" state]) - g!self (code;symbol ["" self])] - (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!args-names) (~ g!self)) - (All [(~@ g!vars)] - (-> (~@ g!arg-types) (~ g!actor) (T;Task (~ return)))) - (let [(~ g!output) (T;task (~ return))] - (exec (;;send (function [(~ g!state) (~ g!self)] - (do P;Monad<Promise> - [(~ g!return) (: (T;Task [((~ g!state-type) (~@ g!var-refs)) - (~ return)]) - (~ body))] - (case (~ g!return) - (#;Right [(~ g!state) (~ g!return)]) - (exec (io;run (P;resolve (#;Right (~ g!return)) (~ g!output))) - (T;return (~ g!state))) - - (#;Left (~ g!error)) - (exec (io;run (P;resolve (#;Left (~ g!error)) (~ g!output))) - (T;fail (~ g!error)))))) - (~ g!self)) - (~ g!output)))))))) - methods) - g!new (code;symbol ["" (format "new-" _name)]) - g!vars (L/map (|>. [""] code;symbol) _vars)] - (wrap (list& (` (type: (~@ (csw;export export)) ((~ g!state-type) (~@ g!vars)) - (~ state-type))) - (` (type: (~@ (csw;export export)) ((~ g!actor) (~@ g!vars)) - (;;Actor ((~ g!state-type) (~@ g!vars))))) - (` (def: (~@ (csw;export export)) (~ g!behavior) - (All [(~@ g!vars)] - (Behavior ((~ g!state-type) (~@ g!vars)))) - {#step (function [(~' message) (~' state) (~' self)] - ((~' message) (~' state) (~' self))) - #end (~ (case ?stop - (#;Some [[cause state] body]) - (let [g!cause (code;symbol ["" cause]) - g!state (code;symbol ["" state])] - (` (function [(~ g!cause) (~ g!state)] - (do P;Monad<Promise> - [] - (~ body))))) - - #;None - (` (:: P;Monad<Promise> (~' wrap) []))))})) - (` (def: (~@ (csw;export export)) ((~ g!new) (~ g!init)) - (All [(~@ g!vars)] - (-> ((~ g!state-type) (~@ g!vars)) (io;IO ((~ g!actor) (~@ g!vars))))) - (;;spawn (~ g!init) (~ g!behavior)))) - g!methods)) + (do @ + [module macro;current-module-name + #let [g!type (code;local-symbol (state-name _name)) + g!behavior (code;local-symbol (behavior-name _name)) + g!actor (code;local-symbol _name) + g!new (code;local-symbol (new-name _name)) + g!vars (L/map code;local-symbol _vars)]] + (wrap (list (` (type: (~@ (csw;export export)) ((~ g!type) (~@ g!vars)) + (~ state-type))) + (` (type: (~@ (csw;export export)) ((~ g!actor) (~@ g!vars)) + (~ (|> annotations + (with-actor [module _name]) + csw;annotations)) + (;;Actor ((~ g!type) (~@ g!vars))))) + (` (def: (~@ (csw;export export)) (~ g!behavior) + (All [(~@ g!vars)] + (;;Behavior ((~ g!type) (~@ g!vars)))) + {#;;handle (~ (case ?handle + #;None + (` ;;default-handle) + + (#;Some [[messageN stateN selfN] bodyC]) + (` (function [(~ (code;local-symbol messageN)) + (~ (code;local-symbol stateN)) + (~ (code;local-symbol selfN))] + (do T;Monad<Task> + [] + (~ bodyC)))))) + #;;end (~ (case ?stop + #;None + (` ;;default-handle) + + (#;Some [[causeN stateN] bodyC]) + (` (function [(~ (code;local-symbol causeN)) + (~ (code;local-symbol stateN))] + (do P;Monad<Promise> + [] + (~ bodyC))))))})) + (` (def: (~@ (csw;export export)) ((~ g!new) (~ g!init)) + (All [(~@ g!vars)] + (-> ((~ g!type) (~@ g!vars)) (io;IO ((~ g!actor) (~@ g!vars))))) + (;;spawn (~ g!behavior) (~ g!init)))))) + ))) + +(type: Signature + {#vars (List Text) + #name Text + #inputs (List [Text Code]) + #state Text + #self Text + #output Code}) + +(def: signature^ + (s;Syntax Signature) + (s;form ($_ p;seq + (p;default (list) (s;tuple (p;some s;local-symbol))) + s;local-symbol + (p;some csr;typed-input) + s;local-symbol + s;local-symbol + s;any))) + +(def: reference^ + (s;Syntax [Ident (List Text)]) + (p;either (s;form (p;seq s;symbol (p;some s;local-symbol))) + (p;seq s;symbol (:: p;Monad<Parser> wrap (list))))) + +(syntax: #export (message: [export csr;export] [[actor-name actor-vars] reference^] + [signature signature^] + [annotations (p;default cs;empty-annotations csr;annotations)] + body) + {#;doc (doc "A message can access the actor's state through the state parameter." + "A message can also access the actor itself through the self parameter." + "A message's output must be a task containing a 2-tuple with the updated state and a return value." + "A message may succeed or fail (in case of failure, the actor dies)." + + (message: #export Counter + (count! [increment Nat] state self Nat) + (let [state' (n.+ increment state)] + (T;return [state' state']))) + + (message: #export (Stack a) + (push [value a] state self (List a)) + (let [state' (#;Cons value state)] + (T;return [state' state']))))} + (with-gensyms [g!return g!error g!task] + (do @ + [actor-name (resolve-actor actor-name) + #let [g!type (code;symbol (product;both id state-name actor-name)) + g!message (code;local-symbol (get@ #name signature)) + g!refs (: (List Code) + (if (list;empty? actor-vars) + (list) + (|> actor-vars list;size n.dec + (list;n.range +0) (L/map (|>. code;nat (~) ($) (`)))))) + g!actor (code;symbol actor-name) + g!tvars (|> (get@ #vars signature) (L/append actor-vars) (L/map code;local-symbol)) + g!inputsC (|> (get@ #inputs signature) (L/map (|>. product;left code;local-symbol))) + g!inputsT (|> (get@ #inputs signature) (L/map product;right)) + g!outputT (get@ #output signature) + g!state (|> signature (get@ #state) code;local-symbol) + g!self (|> signature (get@ #self) code;local-symbol)]] + (wrap (list (` (def: (~@ (csw;export export)) ((~ g!message) (~@ g!inputsC) (~ g!self)) + (~ (|> annotations + (with-message actor-name) + csw;annotations)) + (All [(~@ g!tvars)] (-> (~@ g!inputsT) (~ g!actor) (T;Task (~ g!outputT)))) + (let [(~ g!task) (T;task (~ g!outputT))] + (exec (;;send (function [(~ g!state) (~ g!self)] + (do P;Monad<Promise> + [(~ g!return) (: (T;Task [((~ g!type) (~@ g!refs)) + (~ g!outputT)]) + (~ body))] + (case (~ g!return) + (#;Right [(~ g!state) (~ g!return)]) + (exec (io;run (P;resolve (#;Right (~ g!return)) (~ g!task))) + (T;return (~ g!state))) + + (#;Left (~ g!error)) + (exec (io;run (P;resolve (#;Left (~ g!error)) (~ g!task))) + (T;fail (~ g!error)))) + )) + (~ g!self)) + (~ g!task))))) + )) ))) |