From cb792cb800790e89b371832e46cfe958b7c683d0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Apr 2017 23:38:07 -0400 Subject: - Move the modules under lux/function/* to be under lux/control/*. --- stdlib/source/lux/control/cont.lux | 89 +++++++++++++++++++++ stdlib/source/lux/control/reader.lux | 63 +++++++++++++++ stdlib/source/lux/control/state.lux | 124 ++++++++++++++++++++++++++++++ stdlib/source/lux/control/thunk.lux | 33 ++++++++ stdlib/source/lux/data/coll/stream.lux | 6 +- stdlib/source/lux/function/cont.lux | 89 --------------------- stdlib/source/lux/function/reader.lux | 63 --------------- stdlib/source/lux/function/state.lux | 124 ------------------------------ stdlib/source/lux/function/thunk.lux | 33 -------- stdlib/test/test/lux/control/cont.lux | 75 ++++++++++++++++++ stdlib/test/test/lux/control/reader.lux | 37 +++++++++ stdlib/test/test/lux/control/state.lux | 49 ++++++++++++ stdlib/test/test/lux/control/thunk.lux | 23 ++++++ stdlib/test/test/lux/data/coll/stream.lux | 4 +- stdlib/test/test/lux/function/cont.lux | 75 ------------------ stdlib/test/test/lux/function/reader.lux | 37 --------- stdlib/test/test/lux/function/state.lux | 49 ------------ stdlib/test/test/lux/function/thunk.lux | 23 ------ stdlib/test/tests.lux | 10 +-- 19 files changed, 503 insertions(+), 503 deletions(-) create mode 100644 stdlib/source/lux/control/cont.lux create mode 100644 stdlib/source/lux/control/reader.lux create mode 100644 stdlib/source/lux/control/state.lux create mode 100644 stdlib/source/lux/control/thunk.lux delete mode 100644 stdlib/source/lux/function/cont.lux delete mode 100644 stdlib/source/lux/function/reader.lux delete mode 100644 stdlib/source/lux/function/state.lux delete mode 100644 stdlib/source/lux/function/thunk.lux create mode 100644 stdlib/test/test/lux/control/cont.lux create mode 100644 stdlib/test/test/lux/control/reader.lux create mode 100644 stdlib/test/test/lux/control/state.lux create mode 100644 stdlib/test/test/lux/control/thunk.lux delete mode 100644 stdlib/test/test/lux/function/cont.lux delete mode 100644 stdlib/test/test/lux/function/reader.lux delete mode 100644 stdlib/test/test/lux/function/state.lux delete mode 100644 stdlib/test/test/lux/function/thunk.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/control/cont.lux b/stdlib/source/lux/control/cont.lux new file mode 100644 index 000000000..08f784035 --- /dev/null +++ b/stdlib/source/lux/control/cont.lux @@ -0,0 +1,89 @@ +(;module: + lux + (lux (control functor + applicative + monad) + function + [compiler #+ with-gensyms] + (macro [ast] + [syntax #+ syntax:]))) + +(type: #export (Cont i o) + {#;doc "Continuations."} + (-> (-> i o) o)) + +(def: #export (continue k cont) + {#;doc "Forces a continuation thunk to be evaluated."} + (All [i o] (-> (-> i o) (Cont i o) o)) + (cont k)) + +(def: #export (run cont) + {#;doc "Forces a continuation thunk to be evaluated."} + (All [a] (-> (Cont a a) a)) + (cont id)) + +(struct: #export Functor (All [o] (Functor (All [i] (Cont i o)))) + (def: (map f fv) + (function [k] (fv (. k f))))) + +(struct: #export Applicative (All [o] (Applicative (All [i] (Cont i o)))) + (def: functor Functor) + + (def: (wrap value) + (function [k] (k value))) + + (def: (apply ff fv) + (function [k] + (|> (k (f v)) + (function [v]) fv + (function [f]) ff)))) + +(struct: #export Monad (All [o] (Monad (All [i] (Cont i o)))) + (def: applicative Applicative) + + (def: (join ffa) + (function [k] + (ffa (continue k))))) + +(def: #export (call/cc f) + {#;doc "Call with current continuation."} + (All [a b z] + (-> (-> (-> a (Cont b z)) + (Cont a z)) + (Cont a z))) + (function [k] + (f (function [a] (function [_] (k a))) + k))) + +(syntax: #export (pending expr) + {#;doc (doc "Turns any expression into a function that is pending a continuation." + (pending (some-computation some-input)))} + (with-gensyms [g!k] + (wrap (list (` (;function [(~ g!k)] ((~ g!k) (~ expr)))))))) + +(def: #export (portal init) + (All [i o z] + (-> i + (Cont [(-> i (Cont o z)) + i] + z))) + (call/cc (function [k] + (do Monad + [#let [nexus (function nexus [val] + (k [nexus val]))] + _ (k [nexus init])] + (wrap (undefined)))))) + +(def: #export (reset scope) + (All [i o] (-> (Cont i i) (Cont i o))) + (function [k] + (k (run scope)))) + +(def: #export (shift f) + (All [a] + (-> (-> (-> a (Cont a a)) + (Cont a a)) + (Cont a a))) + (function [oc] + (f (function [a] (function [ic] (ic (oc a)))) + id))) diff --git a/stdlib/source/lux/control/reader.lux b/stdlib/source/lux/control/reader.lux new file mode 100644 index 000000000..598bfc670 --- /dev/null +++ b/stdlib/source/lux/control/reader.lux @@ -0,0 +1,63 @@ +(;module: + lux + (lux (control functor + applicative + ["M" monad #*]))) + +## [Types] +(type: #export (Reader r a) + {#;doc "Computations that have access to some environmental value."} + (-> r a)) + +## [Structures] +(struct: #export Functor (All [r] (Functor (Reader r))) + (def: (map f fa) + (function [env] + (f (fa env))))) + +(struct: #export Applicative (All [r] (Applicative (Reader r))) + (def: functor Functor) + + (def: (wrap x) + (function [env] x)) + + (def: (apply ff fa) + (function [env] + ((ff env) (fa env))))) + +(struct: #export Monad (All [r] (Monad (Reader r))) + (def: applicative Applicative) + + (def: (join mma) + (function [env] + (mma env env)))) + +## [Values] +(def: #export ask + {#;doc "Get the environment."} + (All [r] (Reader r r)) + (function [env] env)) + +(def: #export (local change reader-proc) + {#;doc "Run computation with a locally-modified environment."} + (All [r a] (-> (-> r r) (Reader r a) (Reader r a))) + (|>. change reader-proc)) + +(def: #export (run env reader-proc) + (All [r a] (-> r (Reader r a) a)) + (reader-proc env)) + +(struct: #export (ReaderT Monad) + {#;doc "Monad transformer for Reader."} + (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a))))))) + (def: applicative (compA Applicative (get@ #M;applicative Monad))) + (def: (join eMeMa) + (function [env] + (do Monad + [eMa (run env eMeMa)] + (run env eMa))))) + +(def: #export lift-reader + {#;doc "Lift monadic values to the Reader wrapper."} + (All [M e a] (-> (M a) (Reader e (M a)))) + (:: Monad wrap)) diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux new file mode 100644 index 000000000..9ee12e93d --- /dev/null +++ b/stdlib/source/lux/control/state.lux @@ -0,0 +1,124 @@ +(;module: + lux + (lux (control functor + ["A" applicative #*] + ["M" monad #*]))) + +## [Types] +(type: #export (State s a) + {#;doc "Stateful computations."} + (-> s [s a])) + +## [Structures] +(struct: #export Functor (All [s] (Functor (State s))) + (def: (map f ma) + (function [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(struct: #export Applicative (All [s] (Applicative (State s))) + (def: functor Functor) + + (def: (wrap a) + (function [state] + [state a])) + + (def: (apply ff fa) + (function [state] + (let [[state' f] (ff state) + [state'' a] (fa state')] + [state'' (f a)])))) + +(struct: #export Monad (All [s] (Monad (State s))) + (def: applicative Applicative) + + (def: (join mma) + (function [state] + (let [[state' ma] (mma state)] + (ma state'))))) + +## [Values] +(def: #export get + {#;doc "Read the current state."} + (All [s] (State s s)) + (function [state] + [state state])) + +(def: #export (put new-state) + {#;doc "Set the new state."} + (All [s] (-> s (State s Unit))) + (function [state] + [new-state []])) + +(def: #export (update change) + {#;doc "Compute the new state."} + (All [s] (-> (-> s s) (State s Unit))) + (function [state] + [(change state) []])) + +(def: #export (use user) + {#;doc "Run function on current state."} + (All [s a] (-> (-> s a) (State s a))) + (function [state] + [state (user state)])) + +(def: #export (local change action) + {#;doc "Run computation with a locally-modified state."} + (All [s a] (-> (-> s s) (State s a) (State s a))) + (function [state] + (let [[state' output] (action (change state))] + [state output]))) + +(def: #export (run state action) + {#;doc "Run a stateful computation."} + (All [s a] (-> s (State s a) [s a])) + (action state)) + +(struct: (Functor Functor) + (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) + (def: (map f sfa) + (function [state] + (:: Functor map (function [[s a]] [s (f a)]) + (sfa state))))) + +(struct: (Applicative Monad) + (All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a])))))) + (def: functor (Functor (:: Monad functor))) + + (def: (wrap a) + (function [state] + (:: Monad wrap [state a]))) + + (def: (apply sFf sFa) + (function [state] + (do Monad + [[state f] (sFf state) + [state a] (sFa state)] + (wrap [state (f a)]))))) + +(type: #export (State' M s a) + {#;doc "Stateful computations decorated by a monad."} + (-> s (M [s a]))) + +(def: #export (run' state action) + {#;doc "Run a stateful computation decorated by a monad."} + (All [M s a] (-> s (State' M s a) (M [s a]))) + (action state)) + +(struct: #export (StateT Monad) + {#;doc "A monad transformer to create composite stateful computations."} + (All [M s] (-> (Monad M) (Monad (State' M s)))) + (def: applicative (Applicative Monad)) + (def: (join sMsMa) + (function [state] + (do Monad + [[state' sMa] (sMsMa state)] + (sMa state'))))) + +(def: #export (lift-state Monad ma) + {#;doc "Lift monadic values to the State' wrapper."} + (All [M s a] (-> (Monad M) (M a) (State' M s a))) + (function [state] + (do Monad + [a ma] + (wrap [state a])))) diff --git a/stdlib/source/lux/control/thunk.lux b/stdlib/source/lux/control/thunk.lux new file mode 100644 index 000000000..03545b8b6 --- /dev/null +++ b/stdlib/source/lux/control/thunk.lux @@ -0,0 +1,33 @@ +(;module: + lux + (lux [io] + (control monad) + (concurrency ["A" atom]) + [compiler] + (macro ["s" syntax #+ syntax:]))) + +(type: #export (Thunk a) + (-> [] a)) + +(def: #hidden (freeze' generator) + (All [a] (-> (-> [] a) (-> [] a))) + (let [cache (: (A;Atom (Maybe ($ +0))) + (A;atom #;None))] + (function [_] + (case (io;run (A;get cache)) + (#;Some value) + value + + _ + (let [value (generator [])] + (exec (io;run (A;compare-and-swap _ (#;Some value) cache)) + value)))))) + +(syntax: #export (freeze expr) + (do @ + [g!arg (compiler;gensym "")] + (wrap (list (` (freeze' (function [(~ g!arg)] (~ expr)))))))) + +(def: #export (thaw thunk) + (All [a] (-> (Thunk a) a)) + (thunk [])) diff --git a/stdlib/source/lux/data/coll/stream.lux b/stdlib/source/lux/data/coll/stream.lux index f8ee835b3..b620c5af2 100644 --- a/stdlib/source/lux/data/coll/stream.lux +++ b/stdlib/source/lux/data/coll/stream.lux @@ -2,12 +2,12 @@ lux (lux (control functor monad - comonad) + comonad + [cont #+ pending Cont]) [compiler #+ with-gensyms] (macro ["s" syntax #+ syntax: Syntax]) (data (coll [list "List/" Monad]) - bool) - (function [cont #+ pending Cont]))) + bool))) ## [Types] (type: #export (Stream a) diff --git a/stdlib/source/lux/function/cont.lux b/stdlib/source/lux/function/cont.lux deleted file mode 100644 index 08f784035..000000000 --- a/stdlib/source/lux/function/cont.lux +++ /dev/null @@ -1,89 +0,0 @@ -(;module: - lux - (lux (control functor - applicative - monad) - function - [compiler #+ with-gensyms] - (macro [ast] - [syntax #+ syntax:]))) - -(type: #export (Cont i o) - {#;doc "Continuations."} - (-> (-> i o) o)) - -(def: #export (continue k cont) - {#;doc "Forces a continuation thunk to be evaluated."} - (All [i o] (-> (-> i o) (Cont i o) o)) - (cont k)) - -(def: #export (run cont) - {#;doc "Forces a continuation thunk to be evaluated."} - (All [a] (-> (Cont a a) a)) - (cont id)) - -(struct: #export Functor (All [o] (Functor (All [i] (Cont i o)))) - (def: (map f fv) - (function [k] (fv (. k f))))) - -(struct: #export Applicative (All [o] (Applicative (All [i] (Cont i o)))) - (def: functor Functor) - - (def: (wrap value) - (function [k] (k value))) - - (def: (apply ff fv) - (function [k] - (|> (k (f v)) - (function [v]) fv - (function [f]) ff)))) - -(struct: #export Monad (All [o] (Monad (All [i] (Cont i o)))) - (def: applicative Applicative) - - (def: (join ffa) - (function [k] - (ffa (continue k))))) - -(def: #export (call/cc f) - {#;doc "Call with current continuation."} - (All [a b z] - (-> (-> (-> a (Cont b z)) - (Cont a z)) - (Cont a z))) - (function [k] - (f (function [a] (function [_] (k a))) - k))) - -(syntax: #export (pending expr) - {#;doc (doc "Turns any expression into a function that is pending a continuation." - (pending (some-computation some-input)))} - (with-gensyms [g!k] - (wrap (list (` (;function [(~ g!k)] ((~ g!k) (~ expr)))))))) - -(def: #export (portal init) - (All [i o z] - (-> i - (Cont [(-> i (Cont o z)) - i] - z))) - (call/cc (function [k] - (do Monad - [#let [nexus (function nexus [val] - (k [nexus val]))] - _ (k [nexus init])] - (wrap (undefined)))))) - -(def: #export (reset scope) - (All [i o] (-> (Cont i i) (Cont i o))) - (function [k] - (k (run scope)))) - -(def: #export (shift f) - (All [a] - (-> (-> (-> a (Cont a a)) - (Cont a a)) - (Cont a a))) - (function [oc] - (f (function [a] (function [ic] (ic (oc a)))) - id))) diff --git a/stdlib/source/lux/function/reader.lux b/stdlib/source/lux/function/reader.lux deleted file mode 100644 index 598bfc670..000000000 --- a/stdlib/source/lux/function/reader.lux +++ /dev/null @@ -1,63 +0,0 @@ -(;module: - lux - (lux (control functor - applicative - ["M" monad #*]))) - -## [Types] -(type: #export (Reader r a) - {#;doc "Computations that have access to some environmental value."} - (-> r a)) - -## [Structures] -(struct: #export Functor (All [r] (Functor (Reader r))) - (def: (map f fa) - (function [env] - (f (fa env))))) - -(struct: #export Applicative (All [r] (Applicative (Reader r))) - (def: functor Functor) - - (def: (wrap x) - (function [env] x)) - - (def: (apply ff fa) - (function [env] - ((ff env) (fa env))))) - -(struct: #export Monad (All [r] (Monad (Reader r))) - (def: applicative Applicative) - - (def: (join mma) - (function [env] - (mma env env)))) - -## [Values] -(def: #export ask - {#;doc "Get the environment."} - (All [r] (Reader r r)) - (function [env] env)) - -(def: #export (local change reader-proc) - {#;doc "Run computation with a locally-modified environment."} - (All [r a] (-> (-> r r) (Reader r a) (Reader r a))) - (|>. change reader-proc)) - -(def: #export (run env reader-proc) - (All [r a] (-> r (Reader r a) a)) - (reader-proc env)) - -(struct: #export (ReaderT Monad) - {#;doc "Monad transformer for Reader."} - (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a))))))) - (def: applicative (compA Applicative (get@ #M;applicative Monad))) - (def: (join eMeMa) - (function [env] - (do Monad - [eMa (run env eMeMa)] - (run env eMa))))) - -(def: #export lift-reader - {#;doc "Lift monadic values to the Reader wrapper."} - (All [M e a] (-> (M a) (Reader e (M a)))) - (:: Monad wrap)) diff --git a/stdlib/source/lux/function/state.lux b/stdlib/source/lux/function/state.lux deleted file mode 100644 index 9ee12e93d..000000000 --- a/stdlib/source/lux/function/state.lux +++ /dev/null @@ -1,124 +0,0 @@ -(;module: - lux - (lux (control functor - ["A" applicative #*] - ["M" monad #*]))) - -## [Types] -(type: #export (State s a) - {#;doc "Stateful computations."} - (-> s [s a])) - -## [Structures] -(struct: #export Functor (All [s] (Functor (State s))) - (def: (map f ma) - (function [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(struct: #export Applicative (All [s] (Applicative (State s))) - (def: functor Functor) - - (def: (wrap a) - (function [state] - [state a])) - - (def: (apply ff fa) - (function [state] - (let [[state' f] (ff state) - [state'' a] (fa state')] - [state'' (f a)])))) - -(struct: #export Monad (All [s] (Monad (State s))) - (def: applicative Applicative) - - (def: (join mma) - (function [state] - (let [[state' ma] (mma state)] - (ma state'))))) - -## [Values] -(def: #export get - {#;doc "Read the current state."} - (All [s] (State s s)) - (function [state] - [state state])) - -(def: #export (put new-state) - {#;doc "Set the new state."} - (All [s] (-> s (State s Unit))) - (function [state] - [new-state []])) - -(def: #export (update change) - {#;doc "Compute the new state."} - (All [s] (-> (-> s s) (State s Unit))) - (function [state] - [(change state) []])) - -(def: #export (use user) - {#;doc "Run function on current state."} - (All [s a] (-> (-> s a) (State s a))) - (function [state] - [state (user state)])) - -(def: #export (local change action) - {#;doc "Run computation with a locally-modified state."} - (All [s a] (-> (-> s s) (State s a) (State s a))) - (function [state] - (let [[state' output] (action (change state))] - [state output]))) - -(def: #export (run state action) - {#;doc "Run a stateful computation."} - (All [s a] (-> s (State s a) [s a])) - (action state)) - -(struct: (Functor Functor) - (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) - (def: (map f sfa) - (function [state] - (:: Functor map (function [[s a]] [s (f a)]) - (sfa state))))) - -(struct: (Applicative Monad) - (All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a])))))) - (def: functor (Functor (:: Monad functor))) - - (def: (wrap a) - (function [state] - (:: Monad wrap [state a]))) - - (def: (apply sFf sFa) - (function [state] - (do Monad - [[state f] (sFf state) - [state a] (sFa state)] - (wrap [state (f a)]))))) - -(type: #export (State' M s a) - {#;doc "Stateful computations decorated by a monad."} - (-> s (M [s a]))) - -(def: #export (run' state action) - {#;doc "Run a stateful computation decorated by a monad."} - (All [M s a] (-> s (State' M s a) (M [s a]))) - (action state)) - -(struct: #export (StateT Monad) - {#;doc "A monad transformer to create composite stateful computations."} - (All [M s] (-> (Monad M) (Monad (State' M s)))) - (def: applicative (Applicative Monad)) - (def: (join sMsMa) - (function [state] - (do Monad - [[state' sMa] (sMsMa state)] - (sMa state'))))) - -(def: #export (lift-state Monad ma) - {#;doc "Lift monadic values to the State' wrapper."} - (All [M s a] (-> (Monad M) (M a) (State' M s a))) - (function [state] - (do Monad - [a ma] - (wrap [state a])))) diff --git a/stdlib/source/lux/function/thunk.lux b/stdlib/source/lux/function/thunk.lux deleted file mode 100644 index 03545b8b6..000000000 --- a/stdlib/source/lux/function/thunk.lux +++ /dev/null @@ -1,33 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (concurrency ["A" atom]) - [compiler] - (macro ["s" syntax #+ syntax:]))) - -(type: #export (Thunk a) - (-> [] a)) - -(def: #hidden (freeze' generator) - (All [a] (-> (-> [] a) (-> [] a))) - (let [cache (: (A;Atom (Maybe ($ +0))) - (A;atom #;None))] - (function [_] - (case (io;run (A;get cache)) - (#;Some value) - value - - _ - (let [value (generator [])] - (exec (io;run (A;compare-and-swap _ (#;Some value) cache)) - value)))))) - -(syntax: #export (freeze expr) - (do @ - [g!arg (compiler;gensym "")] - (wrap (list (` (freeze' (function [(~ g!arg)] (~ expr)))))))) - -(def: #export (thaw thunk) - (All [a] (-> (Thunk a) a)) - (thunk [])) diff --git a/stdlib/test/test/lux/control/cont.lux b/stdlib/test/test/lux/control/cont.lux new file mode 100644 index 000000000..133629e45 --- /dev/null +++ b/stdlib/test/test/lux/control/cont.lux @@ -0,0 +1,75 @@ +(;module: + lux + (lux [io] + (control monad + ["&" cont]) + (data [text "Text/" Monoid] + text/format + [number] + [product] + (coll [list])) + ["R" math/random]) + lux/test) + +(test: "Continuations" + [sample R;nat + #let [(^open "&/") &;Monad] + elems (R;list +3 R;nat)] + ($_ seq + (assert "Can run continuations to compute their values." + (n.= sample (&;run (&/wrap sample)))) + + (assert "Can use functor." + (n.= (n.inc sample) (&;run (&/map n.inc (&/wrap sample))))) + + (assert "Can use applicative." + (n.= (n.inc sample) (&;run (&/apply (&/wrap n.inc) (&/wrap sample))))) + + (assert "Can use monad." + (n.= (n.inc sample) (&;run (do &;Monad + [func (wrap n.inc) + arg (wrap sample)] + (wrap (func arg)))))) + + (assert "Can use the current-continuation as a escape hatch." + (n.= (n.* +2 sample) + (&;run (do &;Monad + [value (&;call/cc + (function [k] + (do @ + [temp (k sample)] + ## If this code where to run, + ## the output would be + ## (n.* +4 sample) + (k temp))))] + (wrap (n.* +2 value)))))) + + (assert "Can use the current-continuation to build a time machine." + (n.= (n.+ +100 sample) + (&;run (do &;Monad + [[restart [output idx]] (&;portal [sample +0])] + (if (n.< +10 idx) + (restart [(n.+ +10 output) (n.inc idx)]) + (wrap output)))))) + + (assert "Can use delimited continuations with shifting." + (let [(^open "&/") &;Monad + (^open "L/") (list;Eq number;Eq) + visit (: (-> (List Nat) + (&;Cont (List Nat) (List Nat))) + (function visit [xs] + (case xs + #;Nil + (&/wrap #;Nil) + + (#;Cons x xs') + (do &;Monad + [output (&;shift (function [k] + (do @ + [tail (k xs')] + (wrap (#;Cons x tail)))))] + (visit output)))))] + (L/= elems + (&;run (&;reset (visit elems)))) + )) + )) diff --git a/stdlib/test/test/lux/control/reader.lux b/stdlib/test/test/lux/control/reader.lux new file mode 100644 index 000000000..85b5edf8b --- /dev/null +++ b/stdlib/test/test/lux/control/reader.lux @@ -0,0 +1,37 @@ +(;module: + lux + (lux [io] + (control monad + pipe + ["&" reader]) + (data [text "Text/" Monoid] + text/format + [number])) + lux/test) + +(test: "Readers" + ($_ seq + (assert "" (i.= 123 (&;run 123 &;ask))) + (assert "" (i.= 246 (&;run 123 (&;local (i.* 2) &;ask)))) + (assert "" (i.= 134 (&;run 123 (:: &;Functor map i.inc (i.+ 10))))) + (assert "" (i.= 10 (&;run 123 (:: &;Applicative wrap 10)))) + (assert "" (i.= 30 (&;run 123 (let [(^open "&/") &;Applicative] + (&/apply (&/wrap (i.+ 10)) (&/wrap 20)))))) + (assert "" (i.= 30 (&;run 123 (do &;Monad + [f (wrap i.+) + x (wrap 10) + y (wrap 20)] + (wrap (f x y)))))))) + +(test: "Monad transformer" + (let [(^open "io/") io;Monad] + (assert "Can add reader functionality to any monad." + (|> (do (&;ReaderT io;Monad) + [a (&;lift-reader (io/wrap 123)) + b (wrap 456)] + (wrap (i.+ a b))) + (&;run "") + io;run + (case> 579 true + _ false))) + )) diff --git a/stdlib/test/test/lux/control/state.lux b/stdlib/test/test/lux/control/state.lux new file mode 100644 index 000000000..e02dfdf55 --- /dev/null +++ b/stdlib/test/test/lux/control/state.lux @@ -0,0 +1,49 @@ +(;module: + lux + (lux [io] + (control monad + pipe + ["&" state]) + (data [text "Text/" Monoid] + text/format + [number] + [product])) + lux/test) + +(test: "State" + ($_ seq + (assert "" (i.= 123 (product;right (&;run 123 &;get)))) + (assert "" (i.= 321 (product;right (&;run 123 (do &;Monad + [_ (&;put 321)] + &;get))))) + (assert "" (i.= 369 (product;right (&;run 123 (do &;Monad + [_ (&;update (i.* 3))] + &;get))))) + (assert "" (i.= 124 (product;right (&;run 123 (&;use i.inc))))) + (assert "" (i.= 246 (product;right (&;run 123 (&;local (i.* 2) &;get))))) + (assert "" (i.= 124 (product;right (&;run 123 (:: &;Functor map i.inc &;get))))) + (assert "" (i.= 10 (product;right (&;run 123 (:: &;Applicative wrap 10))))) + (assert "" (i.= 30 (product;right (&;run 123 (let [(^open "&/") &;Applicative] + (&/apply (&/wrap (i.+ 10)) (&/wrap 20))))))) + (assert "" (i.= 30 (product;right (&;run 123 (: (&;State Int Int) + (do &;Monad + [f (wrap i.+) + x (wrap 10) + y (wrap 20)] + (wrap (f x y)))))))) + )) + +(test: "Monad transformer" + (let [lift (&;lift-state io;Monad) + (^open "io/") io;Monad] + (assert "Can add state functionality to any monad." + (|> (: (&;State' io;IO Text Int) + (do (&;StateT io;Monad) + [a (lift (io/wrap 123)) + b (wrap 456)] + (wrap (i.+ a b)))) + (&;run' "") + io;run + (case> ["" 579] true + _ false))) + )) diff --git a/stdlib/test/test/lux/control/thunk.lux b/stdlib/test/test/lux/control/thunk.lux new file mode 100644 index 000000000..cc8ca653d --- /dev/null +++ b/stdlib/test/test/lux/control/thunk.lux @@ -0,0 +1,23 @@ +(;module: + lux + (lux [io] + (control monad + ["&" thunk]) + ["R" math/random]) + lux/test) + +(test: "Thunks" + [left R;nat + right R;nat + #let [thunk (&;freeze (n.* left right)) + expected (n.* left right)]] + ($_ seq + (assert "Thunking does not alter the expected value." + (n.= expected + (&;thaw thunk))) + (assert "Thunks only evaluate once." + (and (not (is expected + (&;thaw thunk))) + (is (&;thaw thunk) + (&;thaw thunk)))) + )) diff --git a/stdlib/test/test/lux/data/coll/stream.lux b/stdlib/test/test/lux/data/coll/stream.lux index edc7d52dc..f68ae60f3 100644 --- a/stdlib/test/test/lux/data/coll/stream.lux +++ b/stdlib/test/test/lux/data/coll/stream.lux @@ -2,13 +2,13 @@ lux (lux [io] (control monad - comonad) + comonad + [cont]) (data [text "Text/" Monoid] text/format (coll [list] ["&" stream]) [number "Nat/" Codec]) - (function [cont]) ["R" math/random]) lux/test) diff --git a/stdlib/test/test/lux/function/cont.lux b/stdlib/test/test/lux/function/cont.lux deleted file mode 100644 index 4362f5a75..000000000 --- a/stdlib/test/test/lux/function/cont.lux +++ /dev/null @@ -1,75 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data [text "Text/" Monoid] - text/format - [number] - [product] - (coll [list])) - (function ["&" cont]) - ["R" math/random]) - lux/test) - -(test: "Continuations" - [sample R;nat - #let [(^open "&/") &;Monad] - elems (R;list +3 R;nat)] - ($_ seq - (assert "Can run continuations to compute their values." - (n.= sample (&;run (&/wrap sample)))) - - (assert "Can use functor." - (n.= (n.inc sample) (&;run (&/map n.inc (&/wrap sample))))) - - (assert "Can use applicative." - (n.= (n.inc sample) (&;run (&/apply (&/wrap n.inc) (&/wrap sample))))) - - (assert "Can use monad." - (n.= (n.inc sample) (&;run (do &;Monad - [func (wrap n.inc) - arg (wrap sample)] - (wrap (func arg)))))) - - (assert "Can use the current-continuation as a escape hatch." - (n.= (n.* +2 sample) - (&;run (do &;Monad - [value (&;call/cc - (function [k] - (do @ - [temp (k sample)] - ## If this code where to run, - ## the output would be - ## (n.* +4 sample) - (k temp))))] - (wrap (n.* +2 value)))))) - - (assert "Can use the current-continuation to build a time machine." - (n.= (n.+ +100 sample) - (&;run (do &;Monad - [[restart [output idx]] (&;portal [sample +0])] - (if (n.< +10 idx) - (restart [(n.+ +10 output) (n.inc idx)]) - (wrap output)))))) - - (assert "Can use delimited continuations with shifting." - (let [(^open "&/") &;Monad - (^open "L/") (list;Eq number;Eq) - visit (: (-> (List Nat) - (&;Cont (List Nat) (List Nat))) - (function visit [xs] - (case xs - #;Nil - (&/wrap #;Nil) - - (#;Cons x xs') - (do &;Monad - [output (&;shift (function [k] - (do @ - [tail (k xs')] - (wrap (#;Cons x tail)))))] - (visit output)))))] - (L/= elems - (&;run (&;reset (visit elems)))) - )) - )) diff --git a/stdlib/test/test/lux/function/reader.lux b/stdlib/test/test/lux/function/reader.lux deleted file mode 100644 index 602efc603..000000000 --- a/stdlib/test/test/lux/function/reader.lux +++ /dev/null @@ -1,37 +0,0 @@ -(;module: - lux - (lux [io] - (control monad - pipe) - (data [text "Text/" Monoid] - text/format - [number]) - (function ["&" reader])) - lux/test) - -(test: "Readers" - ($_ seq - (assert "" (i.= 123 (&;run 123 &;ask))) - (assert "" (i.= 246 (&;run 123 (&;local (i.* 2) &;ask)))) - (assert "" (i.= 134 (&;run 123 (:: &;Functor map i.inc (i.+ 10))))) - (assert "" (i.= 10 (&;run 123 (:: &;Applicative wrap 10)))) - (assert "" (i.= 30 (&;run 123 (let [(^open "&/") &;Applicative] - (&/apply (&/wrap (i.+ 10)) (&/wrap 20)))))) - (assert "" (i.= 30 (&;run 123 (do &;Monad - [f (wrap i.+) - x (wrap 10) - y (wrap 20)] - (wrap (f x y)))))))) - -(test: "Monad transformer" - (let [(^open "io/") io;Monad] - (assert "Can add reader functionality to any monad." - (|> (do (&;ReaderT io;Monad) - [a (&;lift-reader (io/wrap 123)) - b (wrap 456)] - (wrap (i.+ a b))) - (&;run "") - io;run - (case> 579 true - _ false))) - )) diff --git a/stdlib/test/test/lux/function/state.lux b/stdlib/test/test/lux/function/state.lux deleted file mode 100644 index 9ef61e4d3..000000000 --- a/stdlib/test/test/lux/function/state.lux +++ /dev/null @@ -1,49 +0,0 @@ -(;module: - lux - (lux [io] - (control monad - pipe) - (data [text "Text/" Monoid] - text/format - [number] - [product]) - (function ["&" state])) - lux/test) - -(test: "State" - ($_ seq - (assert "" (i.= 123 (product;right (&;run 123 &;get)))) - (assert "" (i.= 321 (product;right (&;run 123 (do &;Monad - [_ (&;put 321)] - &;get))))) - (assert "" (i.= 369 (product;right (&;run 123 (do &;Monad - [_ (&;update (i.* 3))] - &;get))))) - (assert "" (i.= 124 (product;right (&;run 123 (&;use i.inc))))) - (assert "" (i.= 246 (product;right (&;run 123 (&;local (i.* 2) &;get))))) - (assert "" (i.= 124 (product;right (&;run 123 (:: &;Functor map i.inc &;get))))) - (assert "" (i.= 10 (product;right (&;run 123 (:: &;Applicative wrap 10))))) - (assert "" (i.= 30 (product;right (&;run 123 (let [(^open "&/") &;Applicative] - (&/apply (&/wrap (i.+ 10)) (&/wrap 20))))))) - (assert "" (i.= 30 (product;right (&;run 123 (: (&;State Int Int) - (do &;Monad - [f (wrap i.+) - x (wrap 10) - y (wrap 20)] - (wrap (f x y)))))))) - )) - -(test: "Monad transformer" - (let [lift (&;lift-state io;Monad) - (^open "io/") io;Monad] - (assert "Can add state functionality to any monad." - (|> (: (&;State' io;IO Text Int) - (do (&;StateT io;Monad) - [a (lift (io/wrap 123)) - b (wrap 456)] - (wrap (i.+ a b)))) - (&;run' "") - io;run - (case> ["" 579] true - _ false))) - )) diff --git a/stdlib/test/test/lux/function/thunk.lux b/stdlib/test/test/lux/function/thunk.lux deleted file mode 100644 index 753398f77..000000000 --- a/stdlib/test/test/lux/function/thunk.lux +++ /dev/null @@ -1,23 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (function ["&" thunk]) - ["R" math/random]) - lux/test) - -(test: "Thunks" - [left R;nat - right R;nat - #let [thunk (&;freeze (n.* left right)) - expected (n.* left right)]] - ($_ seq - (assert "Thunking does not alter the expected value." - (n.= expected - (&;thaw thunk))) - (assert "Thunks only evaluate once." - (and (not (is expected - (&;thaw thunk))) - (is (&;thaw thunk) - (&;thaw thunk)))) - )) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 931a89e28..4cb00c4a7 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -9,10 +9,6 @@ (lux ["_;" cli] ["_;" host] ["_;" io] - (function ["_;" cont] - ["_;" reader] - ["_;" state] - ["_;" thunk]) (concurrency ["_;" actor] ["_;" atom] ["_;" frp] @@ -20,7 +16,11 @@ ["_;" stm]) (control ["_;" effect] ["_;" interval] - ["_;" pipe]) + ["_;" pipe] + ["_;" cont] + ["_;" reader] + ["_;" state] + ["_;" thunk]) (data ["_;" bit] ["_;" bool] ["_;" char] -- cgit v1.2.3