diff options
| -rw-r--r-- | stdlib/source/lux/control/effect.lux | 57 | ||||
| -rw-r--r-- | stdlib/test/test/lux/control/effect.lux | 77 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 2 |
3 files changed, 110 insertions, 26 deletions
diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux index 297fc3bdb..6643acd26 100644 --- a/stdlib/source/lux/control/effect.lux +++ b/stdlib/source/lux/control/effect.lux @@ -14,6 +14,7 @@ error [ident "Ident/" Eq<Ident>]) [compiler] + [macro] (macro [ast] ["s" syntax #+ syntax: Syntax] (syntax [common])) @@ -25,7 +26,9 @@ (#Effect (F (Eff F a)))) (sig: #export (Handler E M) - (: (All [a] (-> (Eff E a) (M a))) + (: (Monad M) + monad) + (: (All [a] (-> (E a) (M a))) handle)) ## [Values] @@ -102,17 +105,13 @@ (Handler L M) (Handler R M) (Handler (|@ L R) M))) (struct - (def: (handle el|r) - (case el|r - (#Pure x) - (:: Monad<M> wrap x) - - (#Effect l|r) - (case l|r - (#;Left l) (:: left handle (#Effect l)) - (#;Right r) (:: right handle (#Effect r)) - )) - ))) + (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 (s;many s;any)]) @@ -190,8 +189,8 @@ (type: Translation {#effect Ident - #base AST - #monad AST}) + #target-type AST + #target-monad AST}) (def: translation^ (Syntax Translation) @@ -210,6 +209,7 @@ 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)]) @@ -229,24 +229,31 @@ (` ((~ eff-calc) (~@ g!args))))] (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) (` (do (~ target-monad) - [(~ g!value) (~ invocation)] - ((~' handle) ((~ g!cont) (~ g!value))))) + [(~' #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) - (#Pure (~ 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)))))) +(def: #export (with-handler handler body) + (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) @@ -275,7 +282,7 @@ (do (Monad<Eff> (~ g!functor)) [(~@ bindings) (~ g!output) (~ body)] - ((~' wrap) (~ g!output))))))))) + (#;;Pure (~ g!output))))))))) (def: (flatten-effect-stack stack) (-> Type (List Type)) diff --git a/stdlib/test/test/lux/control/effect.lux b/stdlib/test/test/lux/control/effect.lux new file mode 100644 index 000000000..cffdbd561 --- /dev/null +++ b/stdlib/test/test/lux/control/effect.lux @@ -0,0 +1,77 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io "IO/" Monad<IO>]) + (control monad + functor) + (data [text] + text/format) + [macro] + (math ["R" random]) + pipe + (control effect)) + 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] +(test: "Algebraic effects" + (let% [<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])] + (assert "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 ebb6c6999..fba3e139f 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -26,6 +26,7 @@ [frp] ["_;" promise] [stm]) + (control [effect]) (data [bit] [bool] [char] @@ -66,7 +67,6 @@ ["_;" type] (type ["_;" check] ["_;" auto]) - ## (control [effect]) ) )) |