aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/effect.lux57
-rw-r--r--stdlib/test/test/lux/control/effect.lux77
-rw-r--r--stdlib/test/tests.lux2
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])
)
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 16:32:55 +0000