diff options
| -rw-r--r-- | stdlib/source/lux/control/effect.lux | 344 | ||||
| -rw-r--r-- | stdlib/test/test/lux/control/effect.lux | 72 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 3 |
3 files changed, 1 insertions, 418 deletions
diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux deleted file mode 100644 index d1e472ce6..000000000 --- a/stdlib/source/lux/control/effect.lux +++ /dev/null @@ -1,344 +0,0 @@ -(;module: {#;doc "Algebraic effects."} - lux - (lux (control ["F" functor] - applicative - ["M" monad #*] - ["p" parser]) - [io #- run] - (data (coll [list "List/" Monad<List> Monoid<List>]) - [number "Nat/" Codec<Text,Nat>] - text/format - [ident "Ident/" Eq<Ident>] - [text]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) - [type])) - -## [Type] -(sig: #export (Handler E M) - {#;doc "A way to interpret effects into arbitrary monads."} - (: (Monad M) - monad) - (: (All [a] (-> (E a) (M a))) - handle)) - -## [Values] -(type: #hidden (|@ L R) - (All [a] (| (L a) (R a)))) - -(def: #hidden (combine-functors left right) - (All [L R] - (-> (F;Functor L) (F;Functor R) - (F;Functor (|@ L R)))) - (struct - (def: (map f l|r) - (case l|r - (+0 l) (+0 (:: left map f l)) - (+1 r) (+1 (:: right map f r))) - ))) - -(def: #hidden (combine-handlers Monad<M> left right) - (All [L R M] - (-> (Monad M) - (Handler L M) (Handler R M) - (Handler (|@ L R) M))) - (struct - (def: monad Monad<M>) - - (def: (handle l|r) - (case l|r - (#;Left l) (:: left handle l) - (#;Right r) (:: right handle r) - )))) - -## [Syntax] -(syntax: #export (|E [effects (p;many s;any)]) - {#;doc (doc "A way to combine smaller effect into a larger effect." - (type: EffABC (|E EffA EffB EffC)))} - (wrap (list (` ($_ ;;|@ (~@ effects)))))) - -(syntax: #export (|F [functors (p;many s;any)]) - {#;doc (doc "A way to combine smaller effect functors into a larger functor." - (def: Functor<EffABC> - (Functor EffABC) - (|F Functor<EffA> Functor<EffB> Functor<EffC>)))} - (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) - -(syntax: #export (|H monad [handlers (p;many s;any)]) - {#;doc (doc "A way to combine smaller effect handlers into a larger handler." - (def: Handler<EffABC,IO> - (Handler EffABC io;IO) - (|H io;Monad<IO> - Handler<EffA,IO> Handler<EffB,IO> Handler<EffC,IO>)))} - (do @ - [g!combiner (macro;gensym "")] - (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] - ($_ (~ g!combiner) (~@ handlers)))))))) - -(type: Op - {#name Text - #inputs (List Code) - #output Code}) - -(def: op^ - (Syntax Op) - (s;form (p;either ($_ p;seq - s;local-symbol - (s;tuple (p;some s;any)) - s;any) - ($_ p;seq - s;local-symbol - (:: p;Monad<Parser> wrap (list)) - s;any)))) - -(syntax: #export (effect: [exp-lvl csr;export] - [name s;local-symbol] - [ops (p;many op^)]) - {#;doc (doc "Define effects by specifying which operations and constants a handler must provide." - (effect: #export EffA - (opA [Nat Text] Bool) - (fieldA Nat)) - - "In this case, 'opA' will be a function (-> Nat Text Bool)." - "'fieldA' will be a value provided by a handler.")} - (do @ - [g!output (macro;gensym "g!output") - #let [op-types (List/map (function [op] - (let [g!tag (code;tag ["" (get@ #name op)]) - g!inputs (` [(~@ (get@ #inputs op))]) - g!output (` (-> (~ (get@ #output op)) (~ g!output)))] - (` ((~ g!tag) (~ g!inputs) (~ g!output))))) - ops) - type-name (code;symbol ["" name]) - type-def (` (type: (~@ (csw;export exp-lvl)) - ((~ type-name) (~ g!output)) - (~@ op-types))) - op-tags (List/map (|>. (get@ #name) [""] code;tag (list) code;tuple) - ops) - functor-def (` (struct: (~@ (csw;export exp-lvl)) (~' _) (F;Functor (~ type-name)) - (def: ((~' map) (~' f) (~' fa)) - (case (~' fa) - (^template [(~' <tag>)] - ((~' <tag>) (~' params) (~' cont)) - ((~' <tag>) (~' params) (. (~' f) (~' cont)))) - ((~@ op-tags)))) - )) - function-defs (List/map (function [op] - (let [g!name (code;symbol ["" (get@ #name op)]) - g!tag (code;tag ["" (get@ #name op)]) - g!params (: (List Code) - (case (list;size (get@ #inputs op)) - +0 (list) - s (|> (list;n.range +0 (n.dec s)) - (List/map (|>. Nat/encode - (format "_") - [""] - code;symbol)))))] - (` (def: (~@ (csw;export exp-lvl)) ((~ g!name) (~@ g!params)) - (-> (~@ (get@ #inputs op)) - ((~ type-name) (~ (get@ #output op)))) - ((~ g!tag) [(~@ g!params)] ;id))))) - ops)]] - (wrap (list& type-def - functor-def - function-defs)))) - -(type: Translation - {#effect Ident - #target-type Code - #target-monad Code}) - -(def: translation^ - (Syntax Translation) - (s;form (do p;Monad<Parser> - [_ (s;this (' =>))] - (p;seq s;symbol - (s;tuple (p;seq s;any - s;any)))))) - -(syntax: #export (handler: [exp-lvl csr;export] - [name s;local-symbol] - [[effect target-type target-monad] translation^] - [defs (p;many (csr;definition *compiler*))]) - {#;doc (doc "Define effect handlers by implementing the operations and values of an effect." - (handler: _ - (=> EffA [IO Monad<IO>]) - (def: (opA length sample) - (:: Monad<IO> wrap (n.< length - (size sample)))) - - (def: fieldA (:: Monad<IO> wrap +10))) - - "Since a name for the handler was not specified, 'handler:' will generate the name as Handler<EffA,IO>.")} - (do @ - [(^@ effect [e-module _]) (macro;un-alias effect) - g!input (macro;gensym "g!input") - g!cont (macro;gensym "g!cont") - g!value (macro;gensym "value") - g!wrap (macro;gensym "wrap") - #let [g!cases (|> defs - (List/map (function [def] - (let [g!tag (code;tag [e-module (get@ #cs;definition-name def)]) - g!args (List/map (|>. [""] code;symbol) - (get@ #cs;definition-args def)) - eff-calc (case (get@ #cs;definition-type def) - #;None - (get@ #cs;definition-value def) - - (#;Some type) - (` (: (~ type) (~ (get@ #cs;definition-value def))))) - invocation (case g!args - #;Nil - eff-calc - - _ - (` ((~ eff-calc) (~@ g!args))))] - (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) - (` (do (~ target-monad) - [(~' #let) [(~ g!wrap) (~' wrap)] - (~ g!value) (~ invocation)] - ((~ g!wrap) ((~ g!cont) (~ g!value))))) - )))) - List/join)]] - (wrap (list (` (struct: (~@ (csw;export exp-lvl)) (~ (code;symbol ["" name])) - (;;Handler (~ (code;symbol effect)) (~ target-type)) - (def: (~' monad) (~ target-monad)) - - (def: ((~' handle) (~ g!input)) - (case (~ g!input) - (~@ g!cases)) - ))))))) - -(def: #export (with-handler handler body) - {#;doc "Handles an effectful computation with the given handler to produce a monadic value."} - (All [E M a] (-> (Handler E M) (Free E a) (M a))) - (case body - (#M;Pure value) - (:: handler wrap value) - - (#M;Effect effect) - (do (get@ #monad handler) - [result (:: handler handle effect)] - (with-handler handler result)) - )) - -(def: (un-apply type-app) - (-> Type Type) - (case type-app - (#;Apply value effect) - effect - - _ - (error! (format "Wrong type format: " (%type type-app))))) - -(def: (clean-effect effect) - (-> Type Type) - (case effect - (#;UnivQ env body) - (#;UnivQ (list) body) - - _ - (error! (format "Wrong effect format: " (%type effect))))) - -(def: g!functor Code (code;symbol ["" "\t@E\t"])) - -(syntax: #export (doE functor [bindings (s;tuple (p;some s;any))] body) - {#;doc (doc "An alternative to the 'do' macro for monads." - (with-handler Handler<EffABC,IO> - (doE Functor<EffABC> - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))} - (do @ - [g!output (macro;gensym "")] - (wrap (list (` (let [(~ g!functor) (~ functor)] - (do (Monad<Free> (~ g!functor)) - [(~@ bindings) - (~ g!output) (~ body)] - (#M;Pure (~ g!output))))))))) - -(def: (flatten-effect-stack stack) - (-> Type (List Type)) - (case stack - (#;Sum left right) - (List/append (flatten-effect-stack left) - (flatten-effect-stack right)) - - (^ (#;Apply (#;Var _) branches)) - (flatten-effect-stack branches) - - (^ (#;Apply right - (#;Apply left - (#;Named (ident-for ;;|@) _)))) - (#;Cons left (flatten-effect-stack right)) - - (^ (#;Apply param - (#;Apply effect - (#;Named (ident-for M;Free) _)))) - (list effect) - - _ - (list stack) - )) - -(def: (same-effect? expected actual) - (case [expected actual] - [(#;Named e-name _) (#;Named a-name _)] - (Ident/= e-name a-name) - - _ - false)) - -(def: (nest-effect idx total base) - (-> Nat Nat Code Code) - (cond (n.= +0 idx) - (` (+0 (~ base))) - - (n.> +2 total) - (` (+1 (~ (nest-effect (n.dec idx) (n.dec total) base)))) - - ## else - (` (+1 (~ base))) - )) - -(syntax: #export (lift [value (p;alt s;symbol - s;any)]) - {#;doc (doc "A way to (automatically) lift effectful fields and operations from simple effects into the larger space of composite effects." - (with-handler Handler<EffABC,IO> - (doE Functor<EffABC> - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))} - (case value - (#;Left var) - (do @ - [input (macro;find-type var) - output macro;expected-type] - (case [input output] - (^multi [(#;Apply _ eff0) (#;Apply recT0 stackT0)] - [(type;apply (list recT0) stackT0) (#;Some unfoldT0)] - [stackT0 (^ (#;Apply stackT1 - (#;Named (ident-for M;Free) _)))] - [(type;apply (list recT0) stackT1) (#;Some unfoldT1)] - [(flatten-effect-stack unfoldT1) stack] - [(|> stack list;enumerate - (list;find (function [[idx effect]] - (same-effect? effect eff0)))) - (#;Some [idx _])]) - (wrap (list (` (#M;Effect (:: (~ g!functor) (~' map) (~' wrap) - (~ (nest-effect idx (list;size stack) (code;symbol var)))))))) - - _ - (macro;fail (format "Invalid type to lift: " (%type output))))) - - (#;Right node) - (do @ - [g!value (macro;gensym "")] - (wrap (list (` (let [(~ g!value) (~ node)] - (;;lift (~ g!value))))))))) diff --git a/stdlib/test/test/lux/control/effect.lux b/stdlib/test/test/lux/control/effect.lux deleted file mode 100644 index 65a7646ca..000000000 --- a/stdlib/test/test/lux/control/effect.lux +++ /dev/null @@ -1,72 +0,0 @@ -(;module: - lux - (lux [io "IO/" Monad<IO>] - (control monad - functor - effect) - (data [text] - text/format) - [macro] - ["R" math/random]) - lux/test) - -(do-template [<effect> <op> <field>] - [(effect: <effect> - (<op> [Nat Text] Bool) - (<field> Nat))] - - [EffA opA fieldA] - [EffB opB fieldB] - [EffC opC fieldC] - ) - -(do-template [<effect> <op> <op-test> <field> <field-value>] - [(handler: _ - (=> <effect> [io;IO io;Monad<IO>]) - (def: (<op> size sample) - (IO/wrap (<op-test> size (text;size sample)))) - - (def: <field> (IO/wrap <field-value>)))] - - [EffA opA n.< fieldA +10] - [EffB opB n.= fieldB +20] - [EffC opC n.> fieldC +30] - ) - -(type: EffABC (|E EffA EffB EffC)) - -(def: Functor<EffABC> - (Functor EffABC) - (|F Functor<EffA> Functor<EffB> Functor<EffC>)) - -(def: Handler<EffABC,IO> - (Handler EffABC io;IO) - (|H io;Monad<IO> - Handler<EffA,IO> Handler<EffB,IO> Handler<EffC,IO>)) - -## [Tests] -(context: "Algebraic effects" - (with-expansions - [<single-effect-tests> (do-template [<op> <op-size> <field> <field-value>] - [(io;run (with-handler Handler<EffABC,IO> - (doE Functor<EffABC> - [] - (lift (<op> <op-size> "YOLO"))))) - (n.= <field-value> (io;run (with-handler Handler<EffABC,IO> - (doE Functor<EffABC> - [] - (lift <field>)))))] - - [opA +10 fieldA +10] - [opB +4 fieldB +20] - [opC +2 fieldC +30])] - (test "Can handle effects using handlers." - (and <single-effect-tests> - - (n.= +60 (io;run (with-handler Handler<EffABC,IO> - (doE Functor<EffABC> - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))) - )))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 7eff48e75..be26d43fb 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -14,8 +14,7 @@ ["_;" frp] ["_;" promise] ["_;" stm]) - (control ["_;" effect] - ["_;" exception] + (control ["_;" exception] ["_;" interval] ["_;" pipe] ["_;" cont] |