diff options
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux/control/reader.lux | 37 | ||||
-rw-r--r-- | stdlib/source/lux/control/state.lux | 98 | ||||
-rw-r--r-- | stdlib/source/lux/control/writer.lux | 43 | ||||
-rw-r--r-- | stdlib/source/test/lux.lux | 4 | ||||
-rw-r--r-- | stdlib/source/test/lux/control.lux | 18 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/apply.lux | 28 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/continuation.lux | 137 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/exception.lux | 43 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/functor.lux | 23 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/interval.lux | 35 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/monad.lux | 23 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/reader.lux | 81 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/state.lux | 218 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/writer.lux | 84 | ||||
-rw-r--r-- | stdlib/source/test/lux/io.lux | 6 |
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)))) |