From 65b39c7d66244d275ad75c734bc42b0588379bfb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 1 Apr 2017 21:18:02 -0400 Subject: - Some refactorings, new types & functions, and moved the lux/effect module to lux/control/effect. --- stdlib/source/lux/control/algebra.lux | 16 ++ stdlib/source/lux/control/comonad.lux | 13 +- stdlib/source/lux/control/effect.lux | 396 +++++++++++++++++++++++++++++++++ stdlib/source/lux/control/functor.lux | 3 + stdlib/source/lux/control/monad.lux | 6 + stdlib/source/lux/data/product.lux | 6 + stdlib/source/lux/data/sum.lux | 12 +- stdlib/source/lux/effect.lux | 401 ---------------------------------- 8 files changed, 443 insertions(+), 410 deletions(-) create mode 100644 stdlib/source/lux/control/algebra.lux create mode 100644 stdlib/source/lux/control/effect.lux delete mode 100644 stdlib/source/lux/effect.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/algebra.lux b/stdlib/source/lux/control/algebra.lux new file mode 100644 index 000000000..e743f4497 --- /dev/null +++ b/stdlib/source/lux/control/algebra.lux @@ -0,0 +1,16 @@ +(;module: + lux + (lux (control functor))) + +## Types +(type: #export (Algebra f a) + (-> (f a) a)) + +(type: #export (CoAlgebra f a) + (-> a (f a))) + +(type: #export (RAlgebra f a) + (-> (f (& (Fix f) a)) a)) + +(type: #export (RCoAlgebra f a) + (-> a (f (| (Fix f) a)))) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index 5ed443040..428bb484f 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -17,6 +17,11 @@ (-> (w a) (w (w a)))) split)) +## [Types] +(type: #export (CoFree F a) + {#;doc "The CoFree CoMonad."} + [a (F (CoFree F a))]) + ## [Syntax] (def: _cursor Cursor ["" +0 +0]) @@ -43,10 +48,10 @@ body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons (` (;_lux_case (~ comonad) - (~' @) - (;_lux_case (~' @) - {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} - (~ body')))) + (~' @) + (;_lux_case (~' @) + {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} + (~ body')))) #;Nil)])) _ diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux new file mode 100644 index 000000000..d0e2e0576 --- /dev/null +++ b/stdlib/source/lux/control/effect.lux @@ -0,0 +1,396 @@ +(;module: {#;doc "Algebraic effects."} + lux + (lux (control ["F" functor] + applicative + ["M" monad #*]) + [io #- run] + (data (coll [list "List/" Monad Monoid]) + [number "Nat/" Codec] + text/format + error + [ident "Ident/" Eq] + [text]) + [compiler] + [macro] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [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] +(struct: #export (Functor dsl) + (All [F] (-> (F;Functor F) (F;Functor (Free F)))) + (def: (map f ea) + (case ea + (#M;Pure a) + (#M;Pure (f a)) + + (#M;Effect value) + (#M;Effect (:: dsl map (map f) value))))) + +(struct: #export (Applicative dsl) + (All [F] (-> (F;Functor F) (Applicative (Free F)))) + (def: functor (Functor dsl)) + + (def: (wrap a) + (#M;Pure a)) + + (def: (apply ef ea) + (case [ef ea] + [(#M;Pure f) (#M;Pure a)] + (#M;Pure (f a)) + + [(#M;Pure f) (#M;Effect fa)] + (#M;Effect (:: dsl map + (:: (Functor dsl) map f) + fa)) + + [(#M;Effect ff) _] + (#M;Effect (:: dsl map + (lambda [f] (apply f ea)) + ff)) + ))) + +(struct: #export (Monad dsl) + (All [F] (-> (F;Functor F) (Monad (Free F)))) + (def: applicative (Applicative dsl)) + + (def: (join efefa) + (case efefa + (#M;Pure efa) + (case efa + (#M;Pure a) + (#M;Pure a) + + (#M;Effect fa) + (#M;Effect fa)) + + (#M;Effect fefa) + (#M;Effect (:: dsl map + (:: (Monad dsl) join) + fefa)) + ))) + +(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 left right) + (All [L R M] + (-> (Monad M) + (Handler L M) (Handler R M) + (Handler (|@ L R) M))) + (struct + (def: monad Monad) + + (def: (handle l|r) + (case l|r + (#;Left l) (:: left handle l) + (#;Right r) (:: right handle r) + )))) + +## [Syntax] +(syntax: #export (|E [effects (s;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 (s;many s;any)]) + {#;doc (doc "A way to combine smaller effect functors into a larger functor." + (def: Functor + (Functor EffABC) + (|F Functor Functor Functor)))} + (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) + +(syntax: #export (|H monad [handlers (s;many s;any)]) + {#;doc (doc "A way to combine smaller effect handlers into a larger handler." + (def: Handler + (Handler EffABC io;IO) + (|H io;Monad + Handler Handler Handler)))} + (do @ + [g!combiner (compiler;gensym "")] + (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] + ($_ (~ g!combiner) (~@ handlers)))))))) + +(type: Op + {#name Text + #inputs (List AST) + #output AST}) + +(def: op^ + (Syntax Op) + (s;form (s;either ($_ s;seq + s;local-symbol + (s;tuple (s;some s;any)) + s;any) + ($_ s;seq + s;local-symbol + (:: s;Monad wrap (list)) + s;any)))) + +(syntax: #export (effect: [exp-lvl common;export-level] + [name s;local-symbol] + [ops (s;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 (compiler;gensym "g!output") + #let [op-types (List/map (lambda [op] + (let [g!tag (ast;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 (ast;symbol ["" name]) + type-def (` (type: (~@ (common;gen-export-level exp-lvl)) + ((~ type-name) (~ g!output)) + (~@ op-types))) + op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple) + ops) + functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name)) + (def: ((~' map) (~' f) (~' fa)) + (case (~' fa) + (^template [(~' )] + ((~' ) (~' params) (~' cont)) + ((~' ) (~' params) (. (~' f) (~' cont)))) + ((~@ op-tags)))) + )) + function-defs (List/map (lambda [op] + (let [g!name (ast;symbol ["" (get@ #name op)]) + g!tag (ast;tag ["" (get@ #name op)]) + g!params (: (List AST) + (case (list;size (get@ #inputs op)) + +0 (list) + s (|> (list;n.range +0 (n.dec s)) + (List/map (|>. Nat/encode + (format "_") + [""] + ast;symbol)))))] + (` (def: (~@ (common;gen-export-level 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 AST + #target-monad AST}) + +(def: translation^ + (Syntax Translation) + (s;form (do s;Monad + [_ (s;this! (' =>))] + (s;seq s;symbol + (s;tuple (s;seq s;any + s;any)))))) + +(syntax: #export (handler: [exp-lvl common;export-level] + [name s;local-symbol] + [[effect target-type target-monad] translation^] + [defs (s;many (common;def *compiler*))]) + {#;doc (doc "Define effect handlers by implementing the operations and values of an effect." + (handler: _ + (=> EffA [IO Monad]) + (def: (opA length sample) + (:: Monad wrap (n.< length + (size sample)))) + + (def: fieldA (:: Monad wrap +10))) + + "Since a name for the handler was not specified, 'handler:' will generate the name as Handler.")} + (do @ + [(^@ effect [e-module _]) (compiler;un-alias effect) + g!input (compiler;gensym "g!input") + g!cont (compiler;gensym "g!cont") + g!value (compiler;gensym "value") + g!wrap (compiler;gensym "wrap") + #let [g!cases (|> defs + (List/map (lambda [def] + (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) + g!args (List/map (|>. [""] ast;symbol) + (get@ #common;def-args def)) + eff-calc (case (get@ #common;def-type def) + #;None + (get@ #common;def-value def) + + (#;Some type) + (` (: (~ type) (~ (get@ #common;def-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: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) + (;;Handler (~ (ast;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 + (#;AppT effect value) + 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 AST (ast;symbol ["" "\t@E\t"])) + +(syntax: #export (doE functor [bindings (s;tuple (s;some s;any))] body) + {#;doc (doc "An alternative to the 'do' macro for monads." + (with-handler Handler + (doE Functor + [a (lift fieldA) + b (lift fieldB) + c (lift fieldC)] + (wrap ($_ n.+ a b c)))))} + (do @ + [g!output (compiler;gensym "")] + (wrap (list (` (let [(~ g!functor) (~ functor)] + (do (Monad (~ g!functor)) + [(~@ bindings) + (~ g!output) (~ body)] + (#M;Pure (~ g!output))))))))) + +(def: (flatten-effect-stack stack) + (-> Type (List Type)) + (case stack + (#;SumT left right) + (List/append (flatten-effect-stack left) + (flatten-effect-stack right)) + + (^ (#;AppT branches (#;VarT _))) + (flatten-effect-stack branches) + + (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;|@) _) + left) + right)) + (#;Cons left (flatten-effect-stack right)) + + (^ (#;AppT (#;AppT (#;NamedT (ident-for M;Free) _) + effect) + param)) + (list effect) + + _ + (list stack) + )) + +(def: (same-effect? expected actual) + (case [expected actual] + [(#;NamedT e-name _) (#;NamedT a-name _)] + (Ident/= e-name a-name) + + _ + false)) + +(def: (nest-effect idx total base) + (-> Nat Nat AST AST) + (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 (s;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 + (doE Functor + [a (lift fieldA) + b (lift fieldB) + c (lift fieldC)] + (wrap ($_ n.+ a b c)))))} + (case value + (#;Left var) + (do @ + [input (compiler;find-type var) + output compiler;expected-type] + (case [input output] + (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] + [(type;apply-type stackT0 recT0) (#;Some unfoldT0)] + [stackT0 (^ (#;AppT (#;NamedT (ident-for M;Free) _) + stackT1))] + [(type;apply-type stackT1 recT0) (#;Some unfoldT1)] + [(flatten-effect-stack unfoldT1) stack] + [(|> stack list;enumerate + (list;find (lambda [[idx effect]] + (same-effect? effect eff0)))) + (#;Some [idx _])]) + (wrap (list (` (#M;Effect (:: (~ g!functor) (~' map) (~' wrap) + (~ (nest-effect idx (list;size stack) (ast;symbol var)))))))) + + _ + (compiler;fail (format "Invalid type to lift: " (%type output))))) + + (#;Right node) + (do @ + [g!value (compiler;gensym "")] + (wrap (list (` (let [(~ g!value) (~ node)] + (;;lift (~ g!value))))))))) diff --git a/stdlib/source/lux/control/functor.lux b/stdlib/source/lux/control/functor.lux index 005050efd..3532e0633 100644 --- a/stdlib/source/lux/control/functor.lux +++ b/stdlib/source/lux/control/functor.lux @@ -5,6 +5,9 @@ (-> (-> a b) (f a) (f b))) map)) +(type: #export (Fix f) + (f (Fix f))) + (struct: #export (compF Functor Functor) {#;doc "Functor composition."} (All [F G] (-> (Functor F) (Functor G) (Functor (All [a] (F (G a)))))) diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux index a6d0d5988..0563857f4 100644 --- a/stdlib/source/lux/control/monad.lux +++ b/stdlib/source/lux/control/monad.lux @@ -48,6 +48,12 @@ (-> (m (m a)) (m a))) join)) +## [Types] +(type: #export (Free F a) + {#;doc "The Free Monad."} + (#Pure a) + (#Effect (F (Free F a)))) + ## [Syntax] (def: _cursor Cursor ["" +0 +0]) diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux index 8e8be3cd3..2a25e53a0 100644 --- a/stdlib/source/lux/data/product.lux +++ b/stdlib/source/lux/data/product.lux @@ -29,3 +29,9 @@ (All [a b] (-> [a b] [b a])) (let [[x y] xy] [y x])) + +(def: #export (both f g) + (All [a b c] (-> (-> a b) (-> a c) + (-> a [b c]))) + (lambda [input] + [(f input) (g input)])) diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux index 716b3908a..ade411e6b 100644 --- a/stdlib/source/lux/data/sum.lux +++ b/stdlib/source/lux/data/sum.lux @@ -10,11 +10,13 @@ [left a +0] [right b +1]) -(def: #export (either f g s) - (All [a b c] (-> (-> a c) (-> b c) (| a b) c)) - (case s - (+0 x) (f x) - (+1 x) (g x))) +(def: #export (either f g) + (All [a b c] (-> (-> a c) (-> b c) + (-> (| a b) c))) + (lambda [input] + (case input + (+0 l) (f l) + (+1 r) (g r)))) (do-template [ ] [(def: #export ( es) diff --git a/stdlib/source/lux/effect.lux b/stdlib/source/lux/effect.lux deleted file mode 100644 index 2540effb8..000000000 --- a/stdlib/source/lux/effect.lux +++ /dev/null @@ -1,401 +0,0 @@ -(;module: {#;doc "Algebraic effects."} - lux - (lux (control ["F" functor] - applicative - monad) - [io #- run] - (data (coll [list "List/" Monad Monoid]) - [number "Nat/" Codec] - text/format - error - [ident "Ident/" Eq] - [text]) - [compiler] - [macro] - (macro [ast] - ["s" syntax #+ syntax: Syntax] - (syntax [common])) - [type])) - -## [Type] -(type: #export (Eff F a) - {#;doc "A Free Monad implementation for algebraic effects."} - (#Pure a) - (#Effect (F (Eff F a)))) - -(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] -(struct: #export (Functor dsl) - (All [F] (-> (F;Functor F) (F;Functor (Eff F)))) - (def: (map f ea) - (case ea - (#Pure a) - (#Pure (f a)) - - (#Effect value) - (#Effect (:: dsl map (map f) value))))) - -(struct: #export (Applicative dsl) - (All [F] (-> (F;Functor F) (Applicative (Eff F)))) - (def: functor (Functor dsl)) - - (def: (wrap a) - (#Pure a)) - - (def: (apply ef ea) - (case [ef ea] - [(#Pure f) (#Pure a)] - (#Pure (f a)) - - [(#Pure f) (#Effect fa)] - (#Effect (:: dsl map - (:: (Functor dsl) map f) - fa)) - - [(#Effect ff) _] - (#Effect (:: dsl map - (lambda [f] (apply f ea)) - ff)) - ))) - -(struct: #export (Monad dsl) - (All [F] (-> (F;Functor F) (Monad (Eff F)))) - (def: applicative (Applicative dsl)) - - (def: (join efefa) - (case efefa - (#Pure efa) - (case efa - (#Pure a) - (#Pure a) - - (#Effect fa) - (#Effect fa)) - - (#Effect fefa) - (#Effect (:: dsl map - (:: (Monad dsl) join) - fefa)) - ))) - -(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 left right) - (All [L R M] - (-> (Monad M) - (Handler L M) (Handler R M) - (Handler (|@ L R) M))) - (struct - (def: monad Monad) - - (def: (handle l|r) - (case l|r - (#;Left l) (:: left handle l) - (#;Right r) (:: right handle r) - )))) - -## [Syntax] -(syntax: #export (|E [effects (s;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 (s;many s;any)]) - {#;doc (doc "A way to combine smaller effect functors into a larger functor." - (def: Functor - (Functor EffABC) - (|F Functor Functor Functor)))} - (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) - -(syntax: #export (|H monad [handlers (s;many s;any)]) - {#;doc (doc "A way to combine smaller effect handlers into a larger handler." - (def: Handler - (Handler EffABC io;IO) - (|H io;Monad - Handler Handler Handler)))} - (do @ - [g!combiner (compiler;gensym "")] - (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] - ($_ (~ g!combiner) (~@ handlers)))))))) - -(type: Op - {#name Text - #inputs (List AST) - #output AST}) - -(def: op^ - (Syntax Op) - (s;form (s;either ($_ s;seq - s;local-symbol - (s;tuple (s;some s;any)) - s;any) - ($_ s;seq - s;local-symbol - (:: s;Monad wrap (list)) - s;any)))) - -(syntax: #export (effect: [exp-lvl common;export-level] - [name s;local-symbol] - [ops (s;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 (compiler;gensym "g!output") - #let [op-types (List/map (lambda [op] - (let [g!tag (ast;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 (ast;symbol ["" name]) - type-def (` (type: (~@ (common;gen-export-level exp-lvl)) - ((~ type-name) (~ g!output)) - (~@ op-types))) - op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple) - ops) - functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name)) - (def: ((~' map) (~' f) (~' fa)) - (case (~' fa) - (^template [(~' )] - ((~' ) (~' params) (~' cont)) - ((~' ) (~' params) (. (~' f) (~' cont)))) - ((~@ op-tags)))) - )) - function-defs (List/map (lambda [op] - (let [g!name (ast;symbol ["" (get@ #name op)]) - g!tag (ast;tag ["" (get@ #name op)]) - g!params (: (List AST) - (case (list;size (get@ #inputs op)) - +0 (list) - s (|> (list;n.range +0 (n.dec s)) - (List/map (|>. Nat/encode - (format "_") - [""] - ast;symbol)))))] - (` (def: (~@ (common;gen-export-level 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 AST - #target-monad AST}) - -(def: translation^ - (Syntax Translation) - (s;form (do s;Monad - [_ (s;this! (' =>))] - (s;seq s;symbol - (s;tuple (s;seq s;any - s;any)))))) - -(syntax: #export (handler: [exp-lvl common;export-level] - [name s;local-symbol] - [[effect target-type target-monad] translation^] - [defs (s;many (common;def *compiler*))]) - {#;doc (doc "Define effect handlers by implementing the operations and values of an effect." - (handler: _ - (=> EffA [IO Monad]) - (def: (opA length sample) - (:: Monad wrap (n.< length - (size sample)))) - - (def: fieldA (:: Monad wrap +10))) - - "Since a name for the handler was not specified, 'handler:' will generate the name as Handler.")} - (do @ - [(^@ effect [e-module _]) (compiler;un-alias effect) - g!input (compiler;gensym "g!input") - g!cont (compiler;gensym "g!cont") - g!value (compiler;gensym "value") - g!wrap (compiler;gensym "wrap") - #let [g!cases (|> defs - (List/map (lambda [def] - (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) - g!args (List/map (|>. [""] ast;symbol) - (get@ #common;def-args def)) - eff-calc (case (get@ #common;def-type def) - #;None - (get@ #common;def-value def) - - (#;Some type) - (` (: (~ type) (~ (get@ #common;def-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: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) - (;;Handler (~ (ast;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) (Eff E a) (M a))) - (case body - (#Pure value) - (:: handler wrap value) - - (#Effect effect) - (do (get@ #monad handler) - [result (:: handler handle effect)] - (with-handler handler result)) - )) - -(def: (un-apply type-app) - (-> Type Type) - (case type-app - (#;AppT effect value) - 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 AST (ast;symbol ["" "\t@E\t"])) - -(syntax: #export (doE functor [bindings (s;tuple (s;some s;any))] body) - {#;doc (doc "An alternative to the 'do' macro for monads." - (with-handler Handler - (doE Functor - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))} - (do @ - [g!output (compiler;gensym "")] - (wrap (list (` (let [(~ g!functor) (~ functor)] - (do (Monad (~ g!functor)) - [(~@ bindings) - (~ g!output) (~ body)] - (#;;Pure (~ g!output))))))))) - -(def: (flatten-effect-stack stack) - (-> Type (List Type)) - (case stack - (#;SumT left right) - (List/append (flatten-effect-stack left) - (flatten-effect-stack right)) - - (^ (#;AppT branches (#;VarT _))) - (flatten-effect-stack branches) - - (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;|@) _) - left) - right)) - (#;Cons left (flatten-effect-stack right)) - - (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;Eff) _) - effect) - param)) - (list effect) - - _ - (list stack) - )) - -(def: (same-effect? expected actual) - (case [expected actual] - [(#;NamedT e-name _) (#;NamedT a-name _)] - (Ident/= e-name a-name) - - _ - false)) - -(def: (nest-effect idx total base) - (-> Nat Nat AST AST) - (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 (s;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 - (doE Functor - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))} - (case value - (#;Left var) - (do @ - [input (compiler;find-type var) - output compiler;expected-type] - (case [input output] - (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] - [(type;apply-type stackT0 recT0) (#;Some unfoldT0)] - [stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _) - stackT1))] - [(type;apply-type stackT1 recT0) (#;Some unfoldT1)] - [(flatten-effect-stack unfoldT1) stack] - [(|> stack list;enumerate - (list;find (lambda [[idx effect]] - (same-effect? effect eff0)))) - (#;Some [idx _])]) - (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) - (~ (nest-effect idx (list;size stack) (ast;symbol var)))))))) - - _ - (compiler;fail (format "Invalid type to lift: " (%type output))))) - - (#;Right node) - (do @ - [g!value (compiler;gensym "")] - (wrap (list (` (let [(~ g!value) (~ node)] - (;;lift (~ g!value))))))))) -- cgit v1.2.3