- Removed algebraic effects module. If you want effects, just go with finally-tagless approach.

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]