aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/effect.lux344
-rw-r--r--stdlib/test/test/lux/control/effect.lux72
-rw-r--r--stdlib/test/tests.lux3
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]
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-27 18:22:08 +0000