aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/reader.lux37
-rw-r--r--stdlib/source/lux/control/state.lux98
-rw-r--r--stdlib/source/lux/control/writer.lux43
-rw-r--r--stdlib/source/test/lux.lux4
-rw-r--r--stdlib/source/test/lux/control.lux18
-rw-r--r--stdlib/source/test/lux/control/apply.lux28
-rw-r--r--stdlib/source/test/lux/control/continuation.lux137
-rw-r--r--stdlib/source/test/lux/control/exception.lux43
-rw-r--r--stdlib/source/test/lux/control/functor.lux23
-rw-r--r--stdlib/source/test/lux/control/interval.lux35
-rw-r--r--stdlib/source/test/lux/control/monad.lux23
-rw-r--r--stdlib/source/test/lux/control/reader.lux81
-rw-r--r--stdlib/source/test/lux/control/state.lux218
-rw-r--r--stdlib/source/test/lux/control/writer.lux84
-rw-r--r--stdlib/source/test/lux/io.lux6
15 files changed, 470 insertions, 408 deletions
diff --git a/stdlib/source/lux/control/reader.lux b/stdlib/source/lux/control/reader.lux
index d8ce527cc..dc18cb43e 100644
--- a/stdlib/source/lux/control/reader.lux
+++ b/stdlib/source/lux/control/reader.lux
@@ -1,16 +1,28 @@
(.module:
[lux #*
[control
- [functor (#+ Functor)]
+ ["." functor (#+ Functor)]
[apply (#+ Apply)]
["." monad (#+ do Monad)]]])
-## [Types]
(type: #export (Reader r a)
{#.doc "Computations that have access to some environmental value."}
(-> r a))
-## [Structures]
+(def: #export ask
+ {#.doc "Get the environment."}
+ (All [r] (Reader r r))
+ (function (_ env) env))
+
+(def: #export (local change proc)
+ {#.doc "Run computation with a locally-modified environment."}
+ (All [r a] (-> (-> r r) (Reader r a) (Reader r a)))
+ (|>> change proc))
+
+(def: #export (run env proc)
+ (All [r a] (-> r (Reader r a) a))
+ (proc env))
+
(structure: #export functor
(All [r] (Functor (Reader r)))
@@ -39,26 +51,11 @@
(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 proc)
- {#.doc "Run computation with a locally-modified environment."}
- (All [r a] (-> (-> r r) (Reader r a) (Reader r a)))
- (|>> change proc))
-
-(def: #export (run env proc)
- (All [r a] (-> r (Reader r a) a))
- (proc env))
-
-(structure: #export (ReaderT monad)
+(structure: #export (with-reader monad)
{#.doc "Monad transformer for Reader."}
(All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a)))))))
- (def: &functor (F.compose ..functor (get@ #monad.&functor monad)))
+ (def: &functor (functor.compose ..functor (get@ #monad.&functor monad)))
(def: wrap (|>> (:: monad wrap) (:: ..monad wrap)))
diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux
index c0db18a43..afbf28ad1 100644
--- a/stdlib/source/lux/control/state.lux
+++ b/stdlib/source/lux/control/state.lux
@@ -9,39 +9,6 @@
{#.doc "Stateful computations."}
(-> s [s a]))
-(structure: #export functor
- (All [s] (Functor (State s)))
-
- (def: (map f ma)
- (function (_ state)
- (let [[state' a] (ma state)]
- [state' (f a)]))))
-
-(structure: #export apply
- (All [s] (Apply (State s)))
-
- (def: &functor ..functor)
-
- (def: (apply ff fa)
- (function (_ state)
- (let [[state' f] (ff state)
- [state'' a] (fa state')]
- [state'' (f a)]))))
-
-(structure: #export monad
- (All [s] (Monad (State s)))
-
- (def: &functor ..functor)
-
- (def: (wrap a)
- (function (_ state)
- [state a]))
-
- (def: (join mma)
- (function (_ state)
- (let [[state' ma] (mma state)]
- (ma state')))))
-
(def: #export get
{#.doc "Read the current state."}
(All [s] (State s s))
@@ -78,6 +45,55 @@
(All [s a] (-> s (State s a) [s a]))
(action state))
+(structure: #export functor
+ (All [s] (Functor (State s)))
+
+ (def: (map f ma)
+ (function (_ state)
+ (let [[state' a] (ma state)]
+ [state' (f a)]))))
+
+(structure: #export apply
+ (All [s] (Apply (State s)))
+
+ (def: &functor ..functor)
+
+ (def: (apply ff fa)
+ (function (_ state)
+ (let [[state' f] (ff state)
+ [state'' a] (fa state')]
+ [state'' (f a)]))))
+
+(structure: #export monad
+ (All [s] (Monad (State s)))
+
+ (def: &functor ..functor)
+
+ (def: (wrap a)
+ (function (_ state)
+ [state a]))
+
+ (def: (join mma)
+ (function (_ state)
+ (let [[state' ma] (mma state)]
+ (ma state')))))
+
+(def: #export (while condition body)
+ (All [s] (-> (State s Bit) (State s Any) (State s Any)))
+ (do ..monad
+ [execute? condition]
+ (if execute?
+ (do @
+ [_ body]
+ (while condition body))
+ (wrap []))))
+
+(def: #export (do-while condition body)
+ (All [s] (-> (State s Bit) (State s Any) (State s Any)))
+ (do ..monad
+ [_ body]
+ (while condition body)))
+
(structure: (with-state//functor functor)
(All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a]))))))
@@ -130,19 +146,3 @@
(do monad
[a ma]
(wrap [state a]))))
-
-(def: #export (while condition body)
- (All [s] (-> (State s Bit) (State s Any) (State s Any)))
- (do ..monad
- [execute? condition]
- (if execute?
- (do @
- [_ body]
- (while condition body))
- (wrap []))))
-
-(def: #export (do-while condition body)
- (All [s] (-> (State s Bit) (State s Any) (State s Any)))
- (do ..monad
- [_ body]
- (while condition body)))
diff --git a/stdlib/source/lux/control/writer.lux b/stdlib/source/lux/control/writer.lux
index 152bc9e71..8b8d7e38f 100644
--- a/stdlib/source/lux/control/writer.lux
+++ b/stdlib/source/lux/control/writer.lux
@@ -2,7 +2,7 @@
[lux #*
[control
monoid
- [functor (#+ Functor)]
+ ["." functor (#+ Functor)]
[apply (#+ Apply)]
["." monad (#+ Monad do)]]])
@@ -11,6 +11,11 @@
{#log l
#value a})
+(def: #export (write l)
+ {#.doc "Set the log to a particular value."}
+ (All [l] (-> l (Writer l Any)))
+ [l []])
+
(structure: #export functor
(All [l]
(Functor (Writer l)))
@@ -19,7 +24,7 @@
(let [[log datum] fa]
[log (f datum)])))
-(structure: #export (apply mon)
+(structure: #export (apply monoid)
(All [l]
(-> (Monoid l) (Apply (Writer l))))
@@ -28,34 +33,29 @@
(def: (apply ff fa)
(let [[log1 f] ff
[log2 a] fa]
- [(:: mon compose log1 log2) (f a)])))
+ [(:: monoid compose log1 log2) (f a)])))
-(structure: #export (monad mon)
+(structure: #export (monad monoid)
(All [l]
(-> (Monoid l) (Monad (Writer l))))
(def: &functor ..functor)
(def: (wrap x)
- [(:: mon identity) x])
+ [(:: monoid identity) x])
(def: (join mma)
(let [[log1 [log2 a]] mma]
- [(:: mon compose log1 log2) a])))
+ [(:: monoid compose log1 log2) a])))
-(def: #export (log l)
- {#.doc "Set the log to a particular value."}
- (All [l] (-> l (Writer l Any)))
- [l []])
-
-(structure: #export (with-writer Monoid<l> monad)
+(structure: #export (with-writer monoid monad)
(All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Writer l a))))))
- (def: &functor (F.compose (get@ #monad.&functor monad) ..functor))
+ (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor))
(def: wrap
- (let [monad (..monad Monoid<l>)]
- (|>> (:: monad wrap) (:: monad wrap))))
+ (let [writer (..monad monoid)]
+ (|>> (:: writer wrap) (:: monad wrap))))
(def: (join MlMla)
(do monad
@@ -64,11 +64,10 @@
MlMla)
## [l1 Mla] MlMla
[l2 a] Mla]
- (wrap [(:: Monoid<l> compose l1 l2) a]))))
+ (wrap [(:: monoid compose l1 l2) a]))))
-(def: #export (lift Monoid<l> monad)
- (All [l M a] (-> (Monoid l) (Monad M) (-> (M a) (M (Writer l a)))))
- (function (_ ma)
- (do monad
- [a ma]
- (wrap [(:: Monoid<l> identity) a]))))
+(def: #export (lift monoid monad)
+ (All [l M a]
+ (-> (Monoid l) (Monad M)
+ (-> (M a) (M (Writer l a)))))
+ (:: monad map (|>> [(:: monoid identity)])))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 08c77a303..adc14e47a 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -96,10 +96,6 @@
["/." jvm]]
["/." control]]
## [control
- ## ## [continuation (#+)]
- ## ## [reader (#+)]
- ## ## [writer (#+)]
- ## ## [state (#+)]
## ## [parser (#+)]
## ## [thread (#+)]
## ## [region (#+)]
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 79dab5322..de2e00a31 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -2,16 +2,22 @@
[lux #*
["_" test (#+ Test)]]
[/
+ ["/." continuation]
["/." exception]
["/." interval]
- ["/." pipe]])
+ ["/." pipe]
+ ["/." reader]
+ ["/." state]
+ ["/." writer]])
(def: #export test
Test
($_ _.and
- (<| (_.context "/exception Exception-handling.")
- /exception.test)
- (<| (_.context "/interval")
- /interval.test)
+ /continuation.test
+ /exception.test
+ /interval.test
(<| (_.context "/pipe")
- /pipe.test)))
+ /pipe.test)
+ /reader.test
+ /state.test
+ /writer.test))
diff --git a/stdlib/source/test/lux/control/apply.lux b/stdlib/source/test/lux/control/apply.lux
index e703ac416..42d2fa8b9 100644
--- a/stdlib/source/test/lux/control/apply.lux
+++ b/stdlib/source/test/lux/control/apply.lux
@@ -12,8 +12,8 @@
[//
[functor (#+ Injection Comparison)]])
-(def: (identity (^open "_/.") injection comparison)
- (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+(def: (identity injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Apply f) Test))
(do r.monad
[sample (:: @ map injection r.nat)]
(_.test "Identity."
@@ -21,8 +21,8 @@
(_/apply (injection function.identity) sample)
sample))))
-(def: (homomorphism (^open "_/.") injection comparison)
- (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+(def: (homomorphism injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Apply f) Test))
(do r.monad
[sample r.nat
increase (:: @ map n/+ r.nat)]
@@ -31,8 +31,8 @@
(_/apply (injection increase) (injection sample))
(injection (increase sample))))))
-(def: (interchange (^open "_/.") injection comparison)
- (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+(def: (interchange injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Apply f) Test))
(do r.monad
[sample r.nat
increase (:: @ map n/+ r.nat)]
@@ -41,8 +41,8 @@
(_/apply (injection increase) (injection sample))
(_/apply (injection (function (_ f) (f sample))) (injection increase))))))
-(def: (composition (^open "_/.") injection comparison)
- (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+(def: (composition injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Apply f) Test))
(do r.monad
[sample r.nat
increase (:: @ map n/+ r.nat)
@@ -59,12 +59,12 @@
(injection decrease)
(injection sample))))))
-(def: #export (laws apply injection comparison)
- (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+(def: #export (laws injection comparison apply)
+ (All [f] (-> (Injection f) (Comparison f) (Apply f) Test))
(_.context (%name (name-of /.Apply))
($_ _.and
- (..identity apply injection comparison)
- (..homomorphism apply injection comparison)
- (..interchange apply injection comparison)
- (..composition apply injection comparison)
+ (..identity injection comparison apply)
+ (..homomorphism injection comparison apply)
+ (..interchange injection comparison apply)
+ (..composition injection comparison apply)
)))
diff --git a/stdlib/source/test/lux/control/continuation.lux b/stdlib/source/test/lux/control/continuation.lux
index 0dbbe7dc5..ec4495a20 100644
--- a/stdlib/source/test/lux/control/continuation.lux
+++ b/stdlib/source/test/lux/control/continuation.lux
@@ -1,77 +1,88 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
[control
- ["M" monad (#+ do Monad)]
- ["&" continuation]]
+ [monad (#+ do)]
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
[data
- ["." number]
+ [number
+ ["." nat]]
+ [text
+ format]
[collection
["." list]]]
- ["r" math/random]]
- lux/test)
+ [math
+ ["r" random]]]
+ {1
+ ["." / (#+ Cont)]})
-(context: "Continuations"
- (<| (times 100)
- (do @
- [sample r.nat
- #let [(^open "&/.") &.apply
- (^open "&/.") &.monad]
- elems (r.list 3 r.nat)]
- ($_ seq
- (test "Can run continuations to compute their values."
- (n/= sample (&.run (&/wrap sample))))
-
- (test "Can use functor."
- (n/= (inc sample) (&.run (&/map inc (&/wrap sample)))))
+(def: injection
+ (All [o] (Injection (All [i] (Cont i o))))
+ (|>> /.pending))
- (test "Can use apply."
- (n/= (inc sample) (&.run (&/apply (&/wrap inc) (&/wrap sample)))))
+(def: comparison
+ (Comparison Cont)
+ (function (_ == left right)
+ (== (/.run left) (/.run right))))
- (test "Can use monad."
- (n/= (inc sample) (&.run (do &.monad
- [func (wrap inc)
- arg (wrap sample)]
- (wrap (func arg))))))
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Cont)))
+ (do r.monad
+ [sample r.nat
+ #let [(^open "_/.") /.apply
+ (^open "_/.") /.monad]
+ elems (r.list 3 r.nat)]
+ ($_ _.and
+ (_.test "Can run continuations to compute their values."
+ (n/= sample (/.run (_/wrap sample))))
- (test "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))))))
+ (functorT.laws ..injection ..comparison /.functor)
+ (applyT.laws ..injection ..comparison /.apply)
+ (monadT.laws ..injection ..comparison /.monad)
+
+ (_.test "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))))))
- (test "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) (inc idx)])
- (wrap output))))))
+ (_.test "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) (inc idx)])
+ (wrap output))))))
- (test "Can use delimited continuations with shifting."
- (let [(^open "&/.") &.monad
- (^open "L/.") (list.equivalence number.equivalence)
- visit (: (-> (List Nat)
- (&.Cont (List Nat) (List Nat)))
- (function (visit xs)
- (case xs
- #.Nil
- (&/wrap #.Nil)
+ (_.test "Can use delimited continuations with shifting."
+ (let [(^open "_/.") /.monad
+ (^open "list/.") (list.equivalence nat.equivalence)
+ 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))))
- ))
+ (#.Cons x xs')
+ (do /.monad
+ [output (/.shift (function (_ k)
+ (do @
+ [tail (k xs')]
+ (wrap (#.Cons x tail)))))]
+ (visit output)))))]
+ (list/= elems
+ (/.run (/.reset (visit elems))))))
))))
diff --git a/stdlib/source/test/lux/control/exception.lux b/stdlib/source/test/lux/control/exception.lux
index 434ffc5d0..c56688af3 100644
--- a/stdlib/source/test/lux/control/exception.lux
+++ b/stdlib/source/test/lux/control/exception.lux
@@ -2,34 +2,37 @@
[lux #*
[control
[monad (#+ do)]]
+ [data
+ [text
+ format]]
[math
["r" random]]
["_" test (#+ Test)]]
{1
["." / (#+ exception:)]})
-(exception: (an-exception))
-
-(exception: (another-exception))
+(exception: an-exception)
+(exception: another-exception)
(def: #export test
(do r.monad
[right r.nat
wrong (r.filter (|>> (n/= right) not) r.nat)]
- ($_ _.and
- (_.test "Can catch exceptions."
- (n/= right
- (|> (/.throw an-exception [])
- (/.catch an-exception (function (_ ex) right))
- (/.otherwise (function (_ ex) wrong)))))
- (_.test "Can catch multiple exceptions."
- (n/= right
- (|> (/.throw another-exception [])
- (/.catch an-exception (function (_ ex) wrong))
- (/.catch another-exception (function (_ ex) right))
- (/.otherwise (function (_ ex) wrong)))))
- (_.test "Can handle uncaught exceptions."
- (n/= right
- (|> (/.throw another-exception [])
- (/.catch an-exception (function (_ ex) wrong))
- (/.otherwise (function (_ ex) right))))))))
+ (<| (_.context (%name (name-of /.Exception)))
+ ($_ _.and
+ (_.test "Can catch exceptions."
+ (n/= right
+ (|> (/.throw an-exception [])
+ (/.catch an-exception (function (_ ex) right))
+ (/.otherwise (function (_ ex) wrong)))))
+ (_.test "Can catch multiple exceptions."
+ (n/= right
+ (|> (/.throw another-exception [])
+ (/.catch an-exception (function (_ ex) wrong))
+ (/.catch another-exception (function (_ ex) right))
+ (/.otherwise (function (_ ex) wrong)))))
+ (_.test "Can handle uncaught exceptions."
+ (n/= right
+ (|> (/.throw another-exception [])
+ (/.catch an-exception (function (_ ex) wrong))
+ (/.otherwise (function (_ ex) right)))))))))
diff --git a/stdlib/source/test/lux/control/functor.lux b/stdlib/source/test/lux/control/functor.lux
index 66de9d57e..ea0525e04 100644
--- a/stdlib/source/test/lux/control/functor.lux
+++ b/stdlib/source/test/lux/control/functor.lux
@@ -18,8 +18,8 @@
(-> (-> a a Bit)
(-> (f a) (f a) Bit))))
-(def: (identity (^open "_/.") injection comparison)
- (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+(def: (identity injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Functor f) Test))
(do r.monad
[sample (:: @ map injection r.nat)]
(_.test "Identity."
@@ -27,8 +27,8 @@
(_/map function.identity sample)
sample))))
-(def: (homomorphism (^open "_/.") injection comparison)
- (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+(def: (homomorphism injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Functor f) Test))
(do r.monad
[sample r.nat
increase (:: @ map n/+ r.nat)]
@@ -37,8 +37,8 @@
(_/map increase (injection sample))
(injection (increase sample))))))
-(def: (composition (^open "_/.") injection comparison)
- (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+(def: (composition injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Functor f) Test))
(do r.monad
[sample (:: @ map injection r.nat)
increase (:: @ map n/+ r.nat)
@@ -48,10 +48,11 @@
(|> sample (_/map increase) (_/map decrease))
(|> sample (_/map (|>> increase decrease)))))))
-(def: #export (laws functor injection comparison)
- (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+(def: #export (laws injection comparison functor)
+ (All [f] (-> (Injection f) (Comparison f) (Functor f) Test))
(_.context (%name (name-of /.Functor))
($_ _.and
- (..identity functor injection comparison)
- (..homomorphism functor injection comparison)
- (..composition functor injection comparison))))
+ (..identity injection comparison functor)
+ (..homomorphism injection comparison functor)
+ (..composition injection comparison functor)
+ )))
diff --git a/stdlib/source/test/lux/control/interval.lux b/stdlib/source/test/lux/control/interval.lux
index 30d0dfa50..4874d3742 100644
--- a/stdlib/source/test/lux/control/interval.lux
+++ b/stdlib/source/test/lux/control/interval.lux
@@ -7,6 +7,8 @@
[data
[number
["." nat]]
+ [text
+ format]
[collection
["." set]
["." list]]]
@@ -215,19 +217,20 @@
(def: #export test
Test
- ($_ _.and
- (equivalenceT.test /.equivalence ..interval)
- (<| (_.context "Boundaries.")
- ..boundaries)
- (<| (_.context "Union.")
- ..union)
- (<| (_.context "Intersection.")
- ..intersection)
- (<| (_.context "Complement.")
- ..complement)
- (<| (_.context "Positioning/location.")
- ..location)
- (<| (_.context "Touching intervals.")
- ..touch)
- (<| (_.context "Nesting & overlap.")
- ..overlap)))
+ (<| (_.context (%name (name-of /.Interval)))
+ ($_ _.and
+ (equivalenceT.test /.equivalence ..interval)
+ (<| (_.context "Boundaries.")
+ ..boundaries)
+ (<| (_.context "Union.")
+ ..union)
+ (<| (_.context "Intersection.")
+ ..intersection)
+ (<| (_.context "Complement.")
+ ..complement)
+ (<| (_.context "Positioning/location.")
+ ..location)
+ (<| (_.context "Touching intervals.")
+ ..touch)
+ (<| (_.context "Nesting & overlap.")
+ ..overlap))))
diff --git a/stdlib/source/test/lux/control/monad.lux b/stdlib/source/test/lux/control/monad.lux
index 00a31d2d5..5cb498222 100644
--- a/stdlib/source/test/lux/control/monad.lux
+++ b/stdlib/source/test/lux/control/monad.lux
@@ -10,8 +10,8 @@
[//
[functor (#+ Injection Comparison)]])
-(def: (left-identity (^open "_/.") injection comparison)
- (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+(def: (left-identity injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
(do r.monad
[sample r.nat
morphism (:: @ map (function (_ diff)
@@ -22,8 +22,8 @@
(|> (injection sample) (_/map morphism) _/join)
(morphism sample)))))
-(def: (right-identity (^open "_/.") injection comparison)
- (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+(def: (right-identity injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
(do r.monad
[sample r.nat]
(_.test "Right identity."
@@ -31,8 +31,8 @@
(|> (injection sample) (_/map _/wrap) _/join)
(injection sample)))))
-(def: (associativity (^open "_/.") injection comparison)
- (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+(def: (associativity injection comparison (^open "_/."))
+ (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
(do r.monad
[sample r.nat
increase (:: @ map (function (_ diff)
@@ -46,10 +46,11 @@
(|> (injection sample) (_/map increase) _/join (_/map decrease) _/join)
(|> (injection sample) (_/map (|>> increase (_/map decrease) _/join)) _/join)))))
-(def: #export (laws monad injection comparison)
- (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+(def: #export (laws injection comparison monad)
+ (All [f] (-> (Injection f) (Comparison f) (Monad f) Test))
(_.context (%name (name-of /.Monad))
($_ _.and
- (..left-identity monad injection comparison)
- (..right-identity monad injection comparison)
- (..associativity monad injection comparison))))
+ (..left-identity injection comparison monad)
+ (..right-identity injection comparison monad)
+ (..associativity injection comparison monad)
+ )))
diff --git a/stdlib/source/test/lux/control/reader.lux b/stdlib/source/test/lux/control/reader.lux
index 638e11519..f1d80f703 100644
--- a/stdlib/source/test/lux/control/reader.lux
+++ b/stdlib/source/test/lux/control/reader.lux
@@ -1,37 +1,56 @@
(.module:
[lux #*
- ["." io]
+ ["." io (#+ IO)]
+ ["_" test (#+ Test)]
[control
[monad (#+ do)]
- pipe
- ["&" reader]]]
- lux/test)
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
+ [data
+ [text
+ format]]
+ [math
+ ["r" random]]]
+ {1
+ ["." / (#+ Reader)]})
-(context: "Readers"
- (let [(^open "&/.") &.apply
- (^open "&/.") &.monad]
- ($_ seq
- (test "" (i/= +123 (&.run +123 &.ask)))
- (test "" (i/= +246 (&.run +123 (&.local (i/* +2) &.ask))))
- (test "" (i/= +134 (&.run +123 (&/map inc (i/+ +10)))))
- (test "" (i/= +10 (&.run +123 (&/wrap +10))))
- (test "" (i/= +30 (&.run +123 (&/apply (&/wrap (i/+ +10)) (&/wrap +20)))))
- (test "" (i/= +30 (&.run +123 (do &.monad
- [f (wrap i/+)
- x (wrap +10)
- y (wrap +20)]
- (wrap (f x y)))))))))
+(def: (injection value)
+ (Injection (All [a r] (Reader r a)))
+ (function (_ env)
+ value))
-(context: "Monad transformer"
- (let [(^open "io/.") io.monad]
- (test "Can add reader functionality to any monad."
- (|> (: (&.Reader Text (io.IO Int))
- (do (&.ReaderT io.monad)
- [a (&.lift (io/wrap +123))
- b (wrap +456)]
- (wrap (i/+ a b))))
- (&.run "")
- io.run
- (case> +579 #1
- _ #0)))
- ))
+(def: comparison
+ (Comparison (All [a r] (Reader r a)))
+ (function (_ == left right)
+ (== (/.run [] left) (/.run [] right))))
+
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.Reader)))
+ (do r.monad
+ [sample r.nat
+ factor r.nat]
+ ($_ _.and
+ (_.test "Can query the environment."
+ (n/= sample
+ (/.run sample /.ask)))
+ (_.test "Can modify an environment locally."
+ (n/= (n/* factor sample)
+ (/.run sample (/.local (n/* factor) /.ask))))
+ (functorT.laws ..injection ..comparison /.functor)
+ (applyT.laws ..injection ..comparison /.apply)
+ (monadT.laws ..injection ..comparison /.monad)
+
+ (let [(^open "io/.") io.monad]
+ (_.test "Can add reader functionality to any monad."
+ (|> (: (/.Reader Any (IO Nat))
+ (do (/.with-reader io.monad)
+ [a (/.lift (io/wrap sample))
+ b (wrap factor)]
+ (wrap (n/* b a))))
+ (/.run [])
+ io.run
+ (n/= (n/* factor sample)))))))))
diff --git a/stdlib/source/test/lux/control/state.lux b/stdlib/source/test/lux/control/state.lux
index 948cbd5bf..044ff11ff 100644
--- a/stdlib/source/test/lux/control/state.lux
+++ b/stdlib/source/test/lux/control/state.lux
@@ -1,117 +1,133 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
["." io]
[control
- ["M" monad (#+ do Monad)]
- pipe
- ["&" state]]
+ [pipe (#+ let>)]
+ [monad (#+ do)]
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
[data
- ["." product]]
+ ["." product]
+ [text
+ format]]
[math
["r" random]]]
- lux/test)
+ {1
+ ["." / (#+ State)]})
(def: (with-conditions [state output] computation)
- (-> [Nat Nat] (&.State Nat Nat) Bit)
+ (-> [Nat Nat] (State Nat Nat) Bit)
(|> computation
- (&.run state)
+ (/.run state)
product.right
(n/= output)))
-(context: "Basics"
- (<| (times 100)
- (do @
- [state r.nat
- value r.nat]
- ($_ seq
- (test "Can get the state as a value."
- (with-conditions [state state]
- &.get))
- (test "Can replace the state."
- (with-conditions [state value]
- (do &.monad
- [_ (&.put value)]
- &.get)))
- (test "Can update the state."
- (with-conditions [state (n/* value state)]
- (do &.monad
- [_ (&.update (n/* value))]
- &.get)))
- (test "Can use the state."
- (with-conditions [state (inc state)]
- (&.use inc)))
- (test "Can use a temporary (local) state."
- (with-conditions [state (n/* value state)]
- (&.local (n/* value)
- &.get)))
- ))))
+(def: basics
+ (do r.monad
+ [state r.nat
+ value r.nat]
+ ($_ _.and
+ (_.test "Can get the state as a value."
+ (with-conditions [state state]
+ /.get))
+ (_.test "Can replace the state."
+ (with-conditions [state value]
+ (do /.monad
+ [_ (/.put value)]
+ /.get)))
+ (_.test "Can update the state."
+ (with-conditions [state (n/* value state)]
+ (do /.monad
+ [_ (/.update (n/* value))]
+ /.get)))
+ (_.test "Can use the state."
+ (with-conditions [state (inc state)]
+ (/.use inc)))
+ (_.test "Can use a temporary (local) state."
+ (with-conditions [state (n/* value state)]
+ (/.local (n/* value)
+ /.get)))
+ )))
-(context: "Structures"
- (<| (times 100)
- (do @
- [state r.nat
- value r.nat
- #let [(^open "&/.") &.functor
- (^open "&/.") &.apply
- (^open "&/.") &.monad]]
- ($_ seq
- (test "Can use functor."
- (with-conditions [state (inc state)]
- (&/map inc &.get)))
- (test "Can use apply."
- (and (with-conditions [state value]
- (&/wrap value))
- (with-conditions [state (n/+ value value)]
- (&/apply (&/wrap (n/+ value))
- (&/wrap value)))))
- (test "Can use monad."
- (with-conditions [state (n/+ value value)]
- (: (&.State Nat Nat)
- (do &.monad
- [f (wrap n/+)
- x (wrap value)
- y (wrap value)]
- (wrap (f x y))))))
- ))))
+(def: (injection value)
+ (All [s] (Injection (State s)))
+ (function (_ state) [state value]))
-(context: "Monad transformer"
- (<| (times 100)
- (do @
- [state r.nat
- left r.nat
- right r.nat]
- (let [(^open "io/.") io.monad]
- (test "Can add state functionality to any monad."
- (|> (: (&.State' io.IO Nat Nat)
- (do (&.monad io.monad)
- [a (&.lift io.monad (io/wrap left))
- b (wrap right)]
- (wrap (n/+ a b))))
- (&.run' state)
- io.run
- (case> [state' output']
- (and (n/= state state')
- (n/= (n/+ left right) output')))))
- ))))
+(def: (comparison init)
+ (All [s] (-> s (Comparison (State s))))
+ (function (_ == left right)
+ (== (product.right (/.run init left))
+ (product.right (/.run init right)))))
-(context: "Loops"
- (<| (times 100)
- (do @
- [limit (|> r.nat (:: @ map (n/% 10)))
- #let [condition (do &.monad
- [state &.get]
- (wrap (n/< limit state)))]]
- ($_ seq
- (test "'while' will only execute if the condition is #1."
- (|> (&.while condition (&.update inc))
- (&.run 0)
- (case> [state' output']
- (n/= limit state'))))
- (test "'do-while' will execute at least once."
- (|> (&.do-while condition (&.update inc))
- (&.run 0)
- (case> [state' output']
- (or (n/= limit state')
- (and (n/= 0 limit)
- (n/= 1 state'))))))
- ))))
+(def: structures
+ Test
+ (do r.monad
+ [state r.nat
+ value r.nat
+ #let [(^open "&/.") /.functor
+ (^open "&/.") /.apply
+ (^open "&/.") /.monad]]
+ ($_ _.and
+ (functorT.laws ..injection (..comparison state) /.functor)
+ (applyT.laws ..injection (..comparison state) /.apply)
+ (monadT.laws ..injection (..comparison state) /.monad)
+ )))
+
+(def: loops
+ Test
+ (do r.monad
+ [limit (|> r.nat (:: @ map (n/% 10)))
+ #let [condition (do /.monad
+ [state /.get]
+ (wrap (n/< limit state)))]]
+ ($_ _.and
+ (_.test "'while' will only execute if the condition is #1."
+ (|> (/.while condition (/.update inc))
+ (/.run 0)
+ (let> [state' output']
+ (n/= limit state'))))
+ (_.test "'do-while' will execute at least once."
+ (|> (/.do-while condition (/.update inc))
+ (/.run 0)
+ (let> [state' output']
+ (or (n/= limit state')
+ (and (n/= 0 limit)
+ (n/= 1 state'))))))
+ )))
+
+(def: monad-transformer
+ Test
+ (do r.monad
+ [state r.nat
+ left r.nat
+ right r.nat]
+ (let [(^open "io/.") io.monad]
+ (_.test "Can add state functionality to any monad."
+ (|> (: (/.State' io.IO Nat Nat)
+ (do (/.with-state io.monad)
+ [a (/.lift io.monad (io/wrap left))
+ b (wrap right)]
+ (wrap (n/+ a b))))
+ (/.run' state)
+ io.run
+ (let> [state' output']
+ (and (n/= state state')
+ (n/= (n/+ left right) output')))))
+ )))
+
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.State)))
+ ($_ _.and
+ (<| (_.context "Basics.")
+ ..basics)
+ (<| (_.context "Structures.")
+ ..structures)
+ (<| (_.context "Loops.")
+ ..loops)
+ (<| (_.context "Monad transformer.")
+ ..monad-transformer))))
diff --git a/stdlib/source/test/lux/control/writer.lux b/stdlib/source/test/lux/control/writer.lux
index b5fb372d8..5c2c47a3e 100644
--- a/stdlib/source/test/lux/control/writer.lux
+++ b/stdlib/source/test/lux/control/writer.lux
@@ -1,45 +1,55 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
["." io]
[control
- ["M" monad (#+ Monad do)]
- pipe
- ["&" writer]]
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]
+ [monad (#+ do)]
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
[data
["." product]
- ["." text ("text/." equivalence)]]]
- lux/test)
+ ["." text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]]
+ {1
+ ["." / (#+ Writer)]})
-(context: "Writer."
- (let [(^open "&/.") (&.monad text.monoid)
- (^open "&/.") (&.apply text.monoid)]
- ($_ seq
- (test "Functor respects Writer."
- (i/= +11 (product.right (&/map inc ["" +10]))))
-
- (test "Apply respects Writer."
- (and (i/= +20 (product.right (&/wrap +20)))
- (i/= +30 (product.right (&/apply (&/wrap (i/+ +10)) (&/wrap +20))))))
-
- (test "Monad respects Writer."
- (i/= +30 (product.right (do (&.monad text.monoid)
- [f (wrap i/+)
- a (wrap +10)
- b (wrap +20)]
- (wrap (f a b))))))
-
- (test "Can log any value."
- (text/= "YOLO" (product.left (&.log "YOLO"))))
- )))
+(def: (injection monoid value)
+ (All [w] (-> (Monoid w) (Injection (Writer w))))
+ [(:: monoid identity) value])
-(context: "Monad transformer"
- (let [lift (&.lift text.monoid io.monad)
- (^open "io/.") io.monad]
- (test "Can add writer functionality to any monad."
- (|> (io.run (do (&.WriterT text.monoid io.monad)
- [a (lift (io/wrap +123))
- b (wrap +456)]
- (wrap (i/+ a b))))
- (case> ["" +579] #1
- _ #0)))
- ))
+(def: comparison
+ (All [w] (Comparison (Writer w)))
+ (function (_ == [_ left] [_ right])
+ (== left right)))
+
+(def: #export test
+ Test
+ (do r.monad
+ [log (r.ascii 1)]
+ (<| (_.context (%name (name-of /.Writer)))
+ ($_ _.and
+ (_.test "Can write any value."
+ (text/= log
+ (product.left (/.write log))))
+
+ (functorT.laws (..injection text.monoid) ..comparison /.functor)
+ (applyT.laws (..injection text.monoid) ..comparison (/.apply text.monoid))
+ (monadT.laws (..injection text.monoid) ..comparison (/.monad text.monoid))
+
+ (let [lift (/.lift text.monoid io.monad)
+ (^open "io/.") io.monad]
+ (_.test "Can add writer functionality to any monad."
+ (|> (io.run (do (/.with-writer text.monoid io.monad)
+ [a (lift (io/wrap 123))
+ b (wrap 456)]
+ (wrap (n/+ a b))))
+ product.right
+ (n/= 579))))
+ ))))
diff --git a/stdlib/source/test/lux/io.lux b/stdlib/source/test/lux/io.lux
index a14a240cb..bd9b67306 100644
--- a/stdlib/source/test/lux/io.lux
+++ b/stdlib/source/test/lux/io.lux
@@ -34,6 +34,6 @@
(_.test "I/O operations won't execute unless they are explicitly run."
(exec (/.exit exit-code)
true))
- (functorT.laws /.functor ..injection ..comparison)
- (applyT.laws /.apply ..injection ..comparison)
- (monadT.laws /.monad ..injection ..comparison))))
+ (functorT.laws ..injection ..comparison /.functor)
+ (applyT.laws ..injection ..comparison /.apply)
+ (monadT.laws ..injection ..comparison /.monad))))