- Fixed a bug in the way effect-handling worked.

- Added tests for lux/control/effect.

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])
              )
         ))