diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/effect.lux | 121 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 3 |
2 files changed, 80 insertions, 44 deletions
diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux index 379a28d76..297fc3bdb 100644 --- a/stdlib/source/lux/control/effect.lux +++ b/stdlib/source/lux/control/effect.lux @@ -8,17 +8,16 @@ applicative monad) (codata [io #- run]) - (data (struct [list "List/" Monad<List>]) + (data (struct [list "List/" Monad<List> Monoid<List>]) [number "Nat/" Codec<Text,Nat>] text/format - error) + error + [ident "Ident/" Eq<Ident>]) [compiler] - [macro] (macro [ast] ["s" syntax #+ syntax: Syntax] (syntax [common])) - [type] - (type ["tc" check]))) + [type])) ## [Type] (type: #export (Eff F a) @@ -83,13 +82,13 @@ fefa)) ))) -(type: (@| L R) +(type: #export (|@ L R) (All [a] (| (L a) (R a)))) (def: #export (combine-functors left right) (All [L R] (-> (F;Functor L) (F;Functor R) - (F;Functor (@| L R)))) + (F;Functor (|@ L R)))) (struct (def: (map f l|r) (case l|r @@ -101,7 +100,7 @@ (All [L R M] (-> (Monad M) (Handler L M) (Handler R M) - (Handler (@| L R) M))) + (Handler (|@ L R) M))) (struct (def: (handle el|r) (case el|r @@ -116,19 +115,13 @@ ))) ## [Syntax] -(syntax: #export (||E {effects (s;some s;any)}) - (do @ - [g!a (compiler;gensym "g!a") - #let [effects@a (List/map (lambda [eff] (` ((~ eff) (~ g!a)))) - effects)]] - (wrap (list (` (All [(~ g!a)] - (| (~@ effects@a)))) - )))) - -(syntax: #export (||F {functors (s;many s;any)}) +(syntax: #export (|E [effects (s;many s;any)]) + (wrap (list (` ($_ ;;|@ (~@ effects)))))) + +(syntax: #export (|F [functors (s;many s;any)]) (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) -(syntax: #export (||H monad {handlers (s;many s;any)}) +(syntax: #export (|H monad [handlers (s;many s;any)]) (do @ [g!combiner (compiler;gensym "")] (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] @@ -150,9 +143,9 @@ (:: s;Monad<Syntax> wrap (list)) s;any)))) -(syntax: #export (effect: {exp-lvl common;export-level} - {name s;local-symbol} - {ops (s;many op^)}) +(syntax: #export (effect: [exp-lvl common;export-level] + [name s;local-symbol] + [ops (s;many op^)]) (do @ [g!output (compiler;gensym "g!output") #let [op-types (List/map (lambda [op] @@ -208,10 +201,10 @@ (s;tuple (s;seq s;any s;any)))))) -(syntax: #export (handler: {exp-lvl common;export-level} - {name s;local-symbol} - {[effect base monad] translation^} - {defs (s;many (common;def *compiler*))}) +(syntax: #export (handler: [exp-lvl common;export-level] + [name s;local-symbol] + [[effect target-type target-monad] translation^] + [defs (s;many (common;def *compiler*))]) (do @ [(^@ effect [e-module _]) (compiler;un-alias effect) g!input (compiler;gensym "g!input") @@ -235,21 +228,22 @@ _ (` ((~ eff-calc) (~@ g!args))))] (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) - (` (do (~ monad) + (` (do (~ target-monad) [(~ g!value) (~ invocation)] ((~' handle) ((~ g!cont) (~ g!value))))) )))) List/join)]] (wrap (list (` (struct: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) - (;;Handler (~ (ast;symbol effect)) (~ base)) + (;;Handler (~ (ast;symbol effect)) (~ target-type)) (def: ((~' handle) (~ g!input)) (case (~ g!input) (#Pure (~ g!input)) - (:: (~ monad) (~' wrap) (~ g!input)) + (:: (~ target-monad) (~' wrap) (~ g!input)) (#Effect (~ g!input)) (case (~ g!input) - (~@ g!cases)))))))))) + (~@ g!cases))) + ))))))) (syntax: #export (with-handler handler body) (wrap (list (` (:: (~ handler) (~' handle) (~ body)))))) @@ -272,9 +266,9 @@ _ (error! (format "Wrong effect format: " (%type effect))))) -(def: g!functor AST (ast;symbol ["" "%E"])) +(def: g!functor AST (ast;symbol ["" "\t@E\t"])) -(syntax: #export (doE functor {bindings (s;tuple (s;some s;any))} body) +(syntax: #export (doE functor [bindings (s;tuple (s;some s;any))] body) (do @ [g!output (compiler;gensym "")] (wrap (list (` (let [(~ g!functor) (~ functor)] @@ -283,8 +277,52 @@ (~ g!output) (~ body)] ((~' wrap) (~ g!output))))))))) -(syntax: #export (lift {value (s;alt s;symbol - s;any)}) +(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)]) (case value (#;Left var) (do @ @@ -296,14 +334,13 @@ [stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _) stackT1))] [(type;apply-type stackT1 recT0) (#;Some unfoldT1)] - [(list;find (lambda [[idx effect]] - (if (tc;checks? (clean-effect effect) eff0) - (#;Some idx) - #;None)) - (|> unfoldT1 type;flatten-variant (List/map un-apply) list;enumerate)) - (#;Some idx)]) - (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) ((~ (ast;int (nat-to-int idx))) - (~ (ast;symbol var)))))))) + [(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))))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index ea2d722ae..7ab81f75c 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -282,8 +282,7 @@ (lambda [:type:] (case :type: (^=> (#;BoundT idx) - (exec (log! (format "poly;var " (%n idx) " => " (%n (adjusted-idx env idx)))) - (n.= var-id (adjusted-idx env idx)))) + (n.= var-id (adjusted-idx env idx))) (:: compiler;Monad<Lux> wrap []) _ |