aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/test/lux.lux435
-rw-r--r--stdlib/source/test/lux/cli.lux75
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/case.lux198
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/function.lux118
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux100
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux187
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux107
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux297
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/synthesis/case.lux88
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/synthesis/function.lux174
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/synthesis/primitive.lux97
-rw-r--r--stdlib/source/test/lux/compiler/default/phase/synthesis/structure.lux67
-rw-r--r--stdlib/source/test/lux/compiler/default/syntax.lux147
-rw-r--r--stdlib/source/test/lux/control.lux11
-rw-r--r--stdlib/source/test/lux/control/apply.lux69
-rw-r--r--stdlib/source/test/lux/control/concurrency/actor.lux75
-rw-r--r--stdlib/source/test/lux/control/concurrency/atom.lux34
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux53
-rw-r--r--stdlib/source/test/lux/control/concurrency/promise.lux68
-rw-r--r--stdlib/source/test/lux/control/concurrency/semaphore.lux143
-rw-r--r--stdlib/source/test/lux/control/concurrency/stm.lux77
-rw-r--r--stdlib/source/test/lux/control/continuation.lux77
-rw-r--r--stdlib/source/test/lux/control/equivalence.lux21
-rw-r--r--stdlib/source/test/lux/control/exception.lux35
-rw-r--r--stdlib/source/test/lux/control/functor.lux56
-rw-r--r--stdlib/source/test/lux/control/interval.lux235
-rw-r--r--stdlib/source/test/lux/control/monad.lux54
-rw-r--r--stdlib/source/test/lux/control/parser.lux177
-rw-r--r--stdlib/source/test/lux/control/pipe.lux72
-rw-r--r--stdlib/source/test/lux/control/reader.lux37
-rw-r--r--stdlib/source/test/lux/control/region.lux106
-rw-r--r--stdlib/source/test/lux/control/security/integrity.lux54
-rw-r--r--stdlib/source/test/lux/control/security/privacy.lux85
-rw-r--r--stdlib/source/test/lux/control/state.lux117
-rw-r--r--stdlib/source/test/lux/control/thread.lux21
-rw-r--r--stdlib/source/test/lux/control/writer.lux45
-rw-r--r--stdlib/source/test/lux/data/bit.lux37
-rw-r--r--stdlib/source/test/lux/data/collection/array.lux143
-rw-r--r--stdlib/source/test/lux/data/collection/bits.lux87
-rw-r--r--stdlib/source/test/lux/data/collection/dictionary.lux129
-rw-r--r--stdlib/source/test/lux/data/collection/dictionary/ordered.lux91
-rw-r--r--stdlib/source/test/lux/data/collection/list.lux239
-rw-r--r--stdlib/source/test/lux/data/collection/queue.lux54
-rw-r--r--stdlib/source/test/lux/data/collection/queue/priority.lux57
-rw-r--r--stdlib/source/test/lux/data/collection/row.lux82
-rw-r--r--stdlib/source/test/lux/data/collection/sequence.lux103
-rw-r--r--stdlib/source/test/lux/data/collection/set.lux67
-rw-r--r--stdlib/source/test/lux/data/collection/set/ordered.lux98
-rw-r--r--stdlib/source/test/lux/data/collection/stack.lux46
-rw-r--r--stdlib/source/test/lux/data/collection/tree/rose.lux51
-rw-r--r--stdlib/source/test/lux/data/collection/tree/rose/zipper.lux128
-rw-r--r--stdlib/source/test/lux/data/color.lux99
-rw-r--r--stdlib/source/test/lux/data/error.lux61
-rw-r--r--stdlib/source/test/lux/data/format/json.lux183
-rw-r--r--stdlib/source/test/lux/data/format/xml.lux121
-rw-r--r--stdlib/source/test/lux/data/identity.lux37
-rw-r--r--stdlib/source/test/lux/data/lazy.lux54
-rw-r--r--stdlib/source/test/lux/data/maybe.lux69
-rw-r--r--stdlib/source/test/lux/data/name.lux73
-rw-r--r--stdlib/source/test/lux/data/number.lux185
-rw-r--r--stdlib/source/test/lux/data/number/complex.lux201
-rw-r--r--stdlib/source/test/lux/data/number/i64.lux75
-rw-r--r--stdlib/source/test/lux/data/number/ratio.lux116
-rw-r--r--stdlib/source/test/lux/data/product.lux17
-rw-r--r--stdlib/source/test/lux/data/sum.lux37
-rw-r--r--stdlib/source/test/lux/data/text.lux143
-rw-r--r--stdlib/source/test/lux/data/text/format.lux21
-rw-r--r--stdlib/source/test/lux/data/text/lexer.lux205
-rw-r--r--stdlib/source/test/lux/data/text/regex.lux286
-rw-r--r--stdlib/source/test/lux/host.js.lux28
-rw-r--r--stdlib/source/test/lux/host.jvm.lux134
-rw-r--r--stdlib/source/test/lux/host/jvm.jvm.lux89
-rw-r--r--stdlib/source/test/lux/io.lux39
-rw-r--r--stdlib/source/test/lux/macro/code.lux36
-rw-r--r--stdlib/source/test/lux/macro/poly/equivalence.lux71
-rw-r--r--stdlib/source/test/lux/macro/poly/functor.lux24
-rw-r--r--stdlib/source/test/lux/macro/syntax.lux155
-rw-r--r--stdlib/source/test/lux/math.lux125
-rw-r--r--stdlib/source/test/lux/math/logic/continuous.lux35
-rw-r--r--stdlib/source/test/lux/math/logic/fuzzy.lux183
-rw-r--r--stdlib/source/test/lux/math/modular.lux150
-rw-r--r--stdlib/source/test/lux/math/random.lux49
-rw-r--r--stdlib/source/test/lux/time/date.lux147
-rw-r--r--stdlib/source/test/lux/time/duration.lux60
-rw-r--r--stdlib/source/test/lux/time/instant.lux99
-rw-r--r--stdlib/source/test/lux/type.lux168
-rw-r--r--stdlib/source/test/lux/type/check.lux237
-rw-r--r--stdlib/source/test/lux/type/dynamic.lux31
-rw-r--r--stdlib/source/test/lux/type/implicit.lux40
-rw-r--r--stdlib/source/test/lux/type/resource.lux48
-rw-r--r--stdlib/source/test/lux/world/binary.lux88
-rw-r--r--stdlib/source/test/lux/world/file.lux195
-rw-r--r--stdlib/source/test/lux/world/net/tcp.lux71
-rw-r--r--stdlib/source/test/lux/world/net/udp.lux64
94 files changed, 9573 insertions, 0 deletions
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
new file mode 100644
index 000000000..51f5c8277
--- /dev/null
+++ b/stdlib/source/test/lux.lux
@@ -0,0 +1,435 @@
+(.module:
+ [lux #*
+ [cli (#+ program:)]
+ ["." io (#+ io)]
+ [control
+ [monad (#+ do)]
+ [predicate (#+ Predicate)]]
+ [data
+ [number
+ ["." i64]]]
+ ["." function]
+ ["." math
+ ["r" random (#+ Random) ("r/." functor)]]
+ ["_" test (#+ Test)]
+ ## These modules do not need to be tested.
+ [type
+ [variance (#+)]]
+ [locale (#+)
+ [language (#+)]
+ [territory (#+)]]
+ ## TODO: Test these modules
+ [data
+ [format
+ [css (#+)]
+ [markdown (#+)]]]
+ ## [control
+ ## ["._" contract]
+ ## ["._" concatenative]
+ ## ["._" predicate]
+ ## [monad
+ ## ["._" free]]]
+ ## [data
+ ## ["._" env]
+ ## ["._" trace]
+ ## ["._" store]
+ ## [format
+ ## ["._" context]
+ ## ["._" html]
+ ## ["._" css]
+ ## ["._" binary]]
+ ## [collection
+ ## [tree
+ ## [rose
+ ## ["._" parser]]]
+ ## [dictionary
+ ## ["._" plist]]
+ ## [set
+ ## ["._" multi]]]
+ ## [text
+ ## ["._" buffer]]]
+ ## ["._" macro
+ ## [poly
+ ## ["._" json]]]
+ ## [type
+ ## ["._" unit]
+ ## ["._" refinement]
+ ## ["._" quotient]]
+ ## [world
+ ## ["._" environment]
+ ## ["._" console]]
+ ## [compiler
+ ## [host
+ ## [".H" scheme]]
+ ## ["._" cli]
+ ## ["._" default
+ ## ["._" evaluation]
+ ## [phase
+ ## ["._" translation
+ ## [scheme
+ ## ["._scheme" primitive]
+ ## ["._scheme" structure]
+ ## ["._scheme" reference]
+ ## ["._scheme" function]
+ ## ["._scheme" loop]
+ ## ["._scheme" case]
+ ## ["._scheme" extension]
+ ## ["._scheme" extension/common]
+ ## ["._scheme" expression]]]
+ ## [extension
+ ## ["._" statement]]]
+ ## ["._default" cache]]
+ ## [meta
+ ## ["._meta" io
+ ## ["._meta_io" context]
+ ## ["._meta_io" archive]]
+ ## ["._meta" archive]
+ ## ["._meta" cache]]]
+ ## ["._" interpreter
+ ## ["._interpreter" type]]
+ ]
+ ## TODO: Must have 100% coverage on tests.
+ [/
+ ["/." cli]
+ ["/." io]
+ ["/." host
+ ["/." jvm]]
+ ["/." control]]
+ ## [control
+ ## ## [interval (#+)]
+ ## ## [pipe (#+)]
+ ## ## [continuation (#+)]
+ ## ## [reader (#+)]
+ ## ## [writer (#+)]
+ ## ## [state (#+)]
+ ## ## [parser (#+)]
+ ## ## [thread (#+)]
+ ## ## [region (#+)]
+ ## ## [security
+ ## ## [privacy (#+)]
+ ## ## [integrity (#+)]]
+ ## [concurrency
+ ## [actor (#+)]
+ ## [atom (#+)]
+ ## [frp (#+)]
+ ## [promise (#+)]
+ ## [stm (#+)]
+ ## ## [semaphore (#+)]
+ ## ]]
+ ## [data
+ ## [bit (#+)]
+ ## [color (#+)]
+ ## [error (#+)]
+ ## [name (#+)]
+ ## [identity (#+)]
+ ## [lazy (#+)]
+ ## [maybe (#+)]
+ ## [product (#+)]
+ ## [sum (#+)]
+ ## [number (#+) ## TODO: FIX Specially troublesome...
+ ## [i64 (#+)]
+ ## [ratio (#+)]
+ ## [complex (#+)]]
+ ## [text (#+)
+ ## ## [format (#+)]
+ ## [lexer (#+)]
+ ## [regex (#+)]]
+ ## [format
+ ## ## [json (#+)]
+ ## [xml (#+)]]
+ ## ## [collection
+ ## ## [array (#+)]
+ ## ## [bits (#+)]
+ ## ## [list (#+)]
+ ## ## [stack (#+)]
+ ## ## [row (#+)]
+ ## ## [sequence (#+)]
+ ## ## [dictionary (#+)
+ ## ## ["dictionary_." ordered]]
+ ## ## [set (#+)
+ ## ## ["set_." ordered]]
+ ## ## [queue (#+)
+ ## ## [priority (#+)]]
+ ## ## [tree
+ ## ## [rose (#+)
+ ## ## [zipper (#+)]]]]
+ ## ]
+ ## [math (#+)
+ ## [random (#+)]
+ ## [modular (#+)]
+ ## [logic
+ ## [continuous (#+)]
+ ## [fuzzy (#+)]]]
+ ## [macro
+ ## [code (#+)]
+ ## [syntax (#+)]
+ ## [poly
+ ## ["poly_." equivalence]
+ ## ["poly_." functor]]]
+ ## [type ## (#+)
+ ## ## [check (#+)]
+ ## ## [implicit (#+)] ## TODO: FIX Specially troublesome...
+ ## ## [resource (#+)]
+ ## [dynamic (#+)]]
+ ## [time
+ ## [instant (#+)]
+ ## [duration (#+)]
+ ## [date (#+)]]
+ ## [compiler
+ ## [default
+ ## ["_default/." syntax]
+ ## [phase
+ ## [analysis
+ ## ["_.A" primitive]
+ ## ["_.A" structure]
+ ## ["_.A" reference]
+ ## ["_.A" case]
+ ## ["_.A" function]
+ ## [procedure
+ ## ["_.A" common]]]
+ ## [synthesis
+ ## ["_.S" primitive]
+ ## ["_.S" structure]
+ ## ["_.S" case]
+ ## ["_.S" function]]]]]
+ ## [world
+ ## [binary (#+)]
+ ## [file (#+)]
+ ## [net
+ ## [tcp (#+)]
+ ## [udp (#+)]]]
+ )
+
+(def: identity
+ Test
+ (do r.monad
+ [self (r.unicode 1)]
+ ($_ _.and
+ (_.test "Every value is identical to itself."
+ (is? self self))
+ (_.test "The identity function doesn't change values in any way."
+ (is? self (function.identity self)))
+ (do @
+ [other (r.unicode 1)]
+ (_.test "Values created separately can't be identical."
+ (not (is? self other))))
+ )))
+
+(def: increment-and-decrement
+ Test
+ (do r.monad
+ [value r.i64]
+ ($_ _.and
+ (_.test "'inc' and 'dec' are different."
+ (not (n/= (inc value)
+ (dec value))))
+ (_.test "'inc' and 'dec' are opposites."
+ (and (|> value inc dec (n/= value))
+ (|> value dec inc (n/= value))))
+ (_.test "'inc' and 'dec' shift the number by 1."
+ (let [shift 1]
+ (and (n/= (n/+ shift value)
+ (inc value))
+ (n/= (n/- shift value)
+ (dec value))))))))
+
+(def: (check-neighbors has-property? value)
+ (All [a] (-> (Predicate (I64 a)) (I64 a) Bit))
+ (and (|> value inc has-property?)
+ (|> value dec has-property?)))
+
+(def: (even-or-odd rand-gen even? odd?)
+ (All [a] (-> (Random (I64 a)) (Predicate (I64 a)) (Predicate (I64 a)) Test))
+ (do r.monad
+ [value rand-gen]
+ ($_ _.and
+ (_.test "Every number is either even or odd."
+ (if (even? value)
+ (not (odd? value))
+ (odd? value)))
+ (_.test "Every odd/even number is surrounded by two of the other kind."
+ (if (even? value)
+ (check-neighbors odd? value)
+ (check-neighbors even? value))))))
+
+(type: (Choice a)
+ (-> a a a))
+
+(type: (Order a)
+ (-> a a Bit))
+
+(type: (Equivalence a)
+ (-> a a Bit))
+
+(def: (choice rand-gen = [< choose])
+ (All [a] (-> (Random a) (Equivalence a) [(Order a) (Choice a)] Test))
+ (do r.monad
+ [left rand-gen
+ right rand-gen
+ #let [choice (choose left right)]]
+ ($_ _.and
+ (_.test "The choice between 2 values is one of them."
+ (or (= left choice)
+ (= right choice)))
+ (_.test "The choice between 2 values implies an order relationship between them."
+ (if (= left choice)
+ (< right choice)
+ (< left choice))))))
+
+(def: (minimum-and-maximum rand-gen = min' max')
+ (All [a] (-> (Random a) (Equivalence a) [(Order a) (Choice a)] [(Order a) (Choice a)] Test))
+ ($_ _.and
+ (<| (_.context "Minimum.")
+ (choice rand-gen = min'))
+ (<| (_.context "Maximum.")
+ (choice rand-gen = max'))))
+
+(def: (conversion rand-gen forward backward =)
+ (All [a b] (-> (Random a) (-> a b) (-> b a) (Equivalence a) Test))
+ (do r.monad
+ [value rand-gen]
+ (_.test "Can convert between types in a lossless way."
+ (|> value forward backward (= value)))))
+
+(def: frac-rev
+ (r.Random Rev)
+ (|> r.rev
+ (:: r.functor map (|>> (i64.left-shift 11) (i64.logical-right-shift 11)))))
+
+(def: prelude-macros
+ Test
+ ($_ _.and
+ (do r.monad
+ [factor (r/map (|>> (n/% 10) (n/max 1)) r.nat)
+ iterations (r/map (n/% 100) r.nat)
+ #let [expected (n/* factor iterations)]]
+ (_.test "Can write loops."
+ (n/= expected
+ (loop [counter 0
+ value 0]
+ (if (n/< iterations counter)
+ (recur (inc counter) (n/+ factor value))
+ value)))))
+
+ (do r.monad
+ [first r.nat
+ second r.nat
+ third r.nat]
+ (_.test "Can create lists easily through macros."
+ (and (case (list first second third)
+ (#.Cons first' (#.Cons second' (#.Cons third' #.Nil)))
+ (and (n/= first first')
+ (n/= second second')
+ (n/= third third'))
+
+ _
+ false)
+ (case (list& first (list second third))
+ (#.Cons first' (#.Cons second' (#.Cons third' #.Nil)))
+ (and (n/= first first')
+ (n/= second second')
+ (n/= third third'))
+
+ _
+ false)
+ (case (list& first second (list third))
+ (#.Cons first' (#.Cons second' (#.Cons third' #.Nil)))
+ (and (n/= first first')
+ (n/= second second')
+ (n/= third third'))
+
+ _
+ false))))
+ ))
+
+(template: (hypotenuse cat0 cat1)
+ (n/+ (n/* cat0 cat0) (n/* cat1 cat1)))
+
+(def: template
+ Test
+ (do r.monad
+ [cat0 r.nat
+ cat1 r.nat]
+ (_.test "Template application is a stand-in for the templated code."
+ (n/= (n/+ (n/* cat0 cat0) (n/* cat1 cat1))
+ (hypotenuse cat0 cat1)))))
+
+(def: cross-platform-support
+ Test
+ (do r.monad
+ [on-default r.nat
+ on-fake-host r.nat
+ on-valid-host r.nat]
+ ($_ _.and
+ (_.test "Can provide default in case there is no particular host/platform support."
+ (n/= on-default
+ (for {"" on-fake-host}
+ on-default)))
+ (_.test "Can pick code depending on the host/platform being targeted."
+ (n/= on-valid-host
+ (for {"JVM" on-valid-host
+ "JS" on-valid-host}
+ on-default))))))
+
+(def: #export test
+ ($_ _.and
+ (<| (_.context "Identity.")
+ ..identity)
+ (<| (_.context "Increment & decrement.")
+ ..increment-and-decrement)
+ (<| (_.context "Even or odd.")
+ ($_ _.and
+ (<| (_.context "Natural numbers.")
+ (..even-or-odd r.nat n/even? n/odd?))
+ (<| (_.context "Integers.")
+ (..even-or-odd r.int i/even? i/odd?))))
+ (<| (_.context "Minimum and maximum.")
+ (`` ($_ _.and
+ (~~ (do-template [<=> <lt> <min> <gt> <max> <gen> <context>]
+ [(<| (_.context <context>)
+ (..minimum-and-maximum <gen> <=> [<lt> <min>] [<gt> <max>]))]
+
+ [i/= i/< i/min i/> i/max r.int "Integers."]
+ [n/= n/< n/min n/> n/max r.nat "Natural numbers."]
+ [r/= r/< r/min r/> r/max r.rev "Revolutions."]
+ [f/= f/< f/min f/> f/max r.frac "Fractions."]
+ )))))
+ (<| (_.context "Conversion.")
+ (`` ($_ _.and
+ (~~ (do-template [<context> <=> <forward> <backward> <gen>]
+ [(<| (_.context <context>)
+ (..conversion <gen> <forward> <backward> <=>))]
+
+ ["Int -> Nat"
+ i/= .nat .int (r/map (i/% +1_000_000) r.int)]
+ ["Nat -> Int"
+ n/= .int .nat (r/map (n/% 1_000_000) r.nat)]
+ ["Int -> Frac"
+ i/= int-to-frac frac-to-int (r/map (i/% +1_000_000) r.int)]
+ ["Frac -> Int"
+ f/= frac-to-int int-to-frac (r/map math.floor r.frac)]
+ ["Rev -> Frac"
+ r/= rev-to-frac frac-to-rev frac-rev]
+ )))))
+ (<| (_.context "Prelude macros.")
+ ..prelude-macros)
+ (<| (_.context "Templates.")
+ ..template)
+ (<| (_.context "Cross-platform support.")
+ ..cross-platform-support)
+ (<| (_.context "/cli Command-Line Interface.")
+ /cli.test)
+ (<| (_.context "/io I/O (input/output)")
+ /io.test)
+ (<| (_.context "/host Host-platform interoperation")
+ ($_ _.and
+ /host.test
+ (<| (_.context "/jvm JVM (Java Virtual Machine)")
+ /jvm.test)))
+ (<| (_.context "/control")
+ /control.test)
+ ))
+
+(program: args
+ (io (_.run! (<| (_.times 100)
+ ..test))))
diff --git a/stdlib/source/test/lux/cli.lux b/stdlib/source/test/lux/cli.lux
new file mode 100644
index 000000000..e202b3aa7
--- /dev/null
+++ b/stdlib/source/test/lux/cli.lux
@@ -0,0 +1,75 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ Monad do)]
+ pipe
+ ["p" parser]]
+ [data
+ ["." error]
+ [number
+ ["." nat ("nat/." decimal)]]
+ [text ("text/." equivalence)
+ format]
+ [collection
+ ["." list]]]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." /]})
+
+(def: #export test
+ Test
+ (do r.monad
+ [num-args (|> r.nat (:: @ map (n/% 10)))
+ #let [gen-arg (:: @ map nat/encode r.nat)]
+ yes gen-arg
+ #let [gen-ignore (r.filter (|>> (text/= yes) not)
+ (r.unicode 5))]
+ no gen-ignore
+ pre-ignore (r.list 5 gen-ignore)
+ post-ignore (r.list 5 gen-ignore)]
+ ($_ _.and
+ (_.test "Can read any argument."
+ (|> (/.run (list yes) /.any)
+ (case> (#error.Failure _)
+ #0
+
+ (#error.Success arg)
+ (text/= arg yes))))
+ (_.test "Can test tokens."
+ (and (|> (/.run (list yes) (/.this yes))
+ (case> (#error.Failure _)
+ #0
+
+ (#error.Success _)
+ #1))
+ (|> (/.run (list no) (/.this yes))
+ (case> (#error.Failure _)
+ #1
+
+ (#error.Success _)
+ #0))))
+ (_.test "Can use custom token parsers."
+ (|> (/.run (list yes) (/.parse nat/decode))
+ (case> (#error.Failure _)
+ #0
+
+ (#error.Success parsed)
+ (text/= (nat/encode parsed)
+ yes))))
+ (_.test "Can query if there are any more inputs."
+ (and (|> (/.run (list) /.end)
+ (case> (#error.Success []) #1 _ #0))
+ (|> (/.run (list yes) (p.not /.end))
+ (case> (#error.Success []) #0 _ #1))))
+ (_.test "Can parse CLI input anywhere."
+ (|> (/.run (list.concat (list pre-ignore (list yes) post-ignore))
+ (|> (/.somewhere (/.this yes))
+ (p.before (p.some /.any))))
+ (case> (#error.Failure _)
+ #0
+
+ (#error.Success _)
+ #1)))
+ )))
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux
new file mode 100644
index 000000000..2bf02bb0e
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux
@@ -0,0 +1,198 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do)]
+ pipe]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("text/." equivalence)]
+ [collection
+ ["." list ("list/." monad)]
+ ["." set]]]
+ [math
+ ["r" random ("random/." monad)]]
+ ["." type
+ ["." check]]
+ [macro
+ ["." code]]
+ [compiler
+ [default
+ ["." phase
+ ["." analysis
+ ["." module]
+ [".A" type]
+ ["/" case]]]]]
+ test]
+ [//
+ ["_." primitive]
+ ["_." structure]])
+
+(def: (exhaustive-weaving branchings)
+ (-> (List (List Code)) (List (List Code)))
+ (case branchings
+ #.Nil
+ #.Nil
+
+ (#.Cons head+ #.Nil)
+ (list/map (|>> list) head+)
+
+ (#.Cons head+ tail++)
+ (do list.monad
+ [tail+ (exhaustive-weaving tail++)
+ head head+]
+ (wrap (#.Cons head tail+)))))
+
+(def: #export (exhaustive-branches allow-literals? variantTC inputC)
+ (-> Bit (List [Code Code]) Code (r.Random (List Code)))
+ (case inputC
+ [_ (#.Bit _)]
+ (random/wrap (list (' #1) (' #0)))
+
+ (^template [<tag> <gen> <wrapper>]
+ [_ (<tag> _)]
+ (if allow-literals?
+ (do r.monad
+ [?sample (r.maybe <gen>)]
+ (case ?sample
+ (#.Some sample)
+ (do @
+ [else (exhaustive-branches allow-literals? variantTC inputC)]
+ (wrap (list& (<wrapper> sample) else)))
+
+ #.None
+ (wrap (list (' _)))))
+ (random/wrap (list (' _)))))
+ ([#.Nat r.nat code.nat]
+ [#.Int r.int code.int]
+ [#.Rev r.rev code.rev]
+ [#.Frac r.frac code.frac]
+ [#.Text (r.unicode 5) code.text])
+
+ (^ [_ (#.Tuple (list))])
+ (random/wrap (list (' [])))
+
+ (^ [_ (#.Record (list))])
+ (random/wrap (list (' {})))
+
+ [_ (#.Tuple members)]
+ (do r.monad
+ [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)]
+ (wrap (|> member-wise-patterns
+ exhaustive-weaving
+ (list/map code.tuple))))
+
+ [_ (#.Record kvs)]
+ (do r.monad
+ [#let [ks (list/map product.left kvs)
+ vs (list/map product.right kvs)]
+ member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)]
+ (wrap (|> member-wise-patterns
+ exhaustive-weaving
+ (list/map (|>> (list.zip2 ks) code.record)))))
+
+ (^ [_ (#.Form (list [_ (#.Tag _)] _))])
+ (do r.monad
+ [bundles (monad.map @
+ (function (_ [_tag _code])
+ (do @
+ [v-branches (exhaustive-branches allow-literals? variantTC _code)]
+ (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern))))
+ v-branches))))
+ variantTC)]
+ (wrap (list/join bundles)))
+
+ _
+ (random/wrap (list))
+ ))
+
+(def: #export (input variant-tags record-tags primitivesC)
+ (-> (List Code) (List Code) (List Code) (r.Random Code))
+ (r.rec
+ (function (_ input)
+ ($_ r.either
+ (random/map product.right _primitive.primitive)
+ (do r.monad
+ [choice (|> r.nat (:: @ map (n/% (list.size variant-tags))))
+ #let [choiceT (maybe.assume (list.nth choice variant-tags))
+ choiceC (maybe.assume (list.nth choice primitivesC))]]
+ (wrap (` ((~ choiceT) (~ choiceC)))))
+ (do r.monad
+ [size (|> r.nat (:: @ map (n/% 3)))
+ elems (r.list size input)]
+ (wrap (code.tuple elems)))
+ (random/wrap (code.record (list.zip2 record-tags primitivesC)))
+ ))))
+
+(def: (branch body pattern)
+ (-> Code Code [Code Code])
+ [pattern body])
+
+(context: "Pattern-matching."
+ ## #seed 9253409297339902486
+ ## #seed 3793366152923578600
+ (<| (seed 5004137551292836565)
+ ## (times 100)
+ (do @
+ [module-name (r.unicode 5)
+ variant-name (r.unicode 5)
+ record-name (|> (r.unicode 5) (r.filter (|>> (text/= variant-name) not)))
+ size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list))
+ record-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list))
+ primitivesTC (r.list size _primitive.primitive)
+ #let [primitivesT (list/map product.left primitivesTC)
+ primitivesC (list/map product.right primitivesTC)
+ code-tag (|>> [module-name] code.tag)
+ variant-tags+ (list/map code-tag variant-tags)
+ record-tags+ (list/map code-tag record-tags)
+ variantTC (list.zip2 variant-tags+ primitivesC)]
+ inputC (input variant-tags+ record-tags+ primitivesC)
+ [outputT outputC] _primitive.primitive
+ [heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not)
+ _primitive.primitive)
+ exhaustive-patterns (exhaustive-branches #1 variantTC inputC)
+ redundant-patterns (exhaustive-branches #0 variantTC inputC)
+ redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns))))
+ heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns))))
+ #let [exhaustive-branchesC (list/map (branch outputC)
+ exhaustive-patterns)
+ non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC))
+ exhaustive-branchesC)
+ redundant-branchesC (<| (list/map (branch outputC))
+ list.concat
+ (list (list.take redundancy-idx redundant-patterns)
+ (list (maybe.assume (list.nth redundancy-idx redundant-patterns)))
+ (list.drop redundancy-idx redundant-patterns)))
+ heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC)
+ (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))]
+ [_pattern heterogeneousC]))
+ (list.drop (inc heterogeneous-idx) exhaustive-branchesC)))
+ analyse-pm (|>> (/.case _primitive.phase inputC)
+ (typeA.with-type outputT)
+ analysis.with-scope
+ (do phase.monad
+ [_ (module.declare-tags variant-tags #0
+ (#.Named [module-name variant-name]
+ (type.variant primitivesT)))
+ _ (module.declare-tags record-tags #0
+ (#.Named [module-name record-name]
+ (type.tuple primitivesT)))])
+ (module.with-module 0 module-name))]]
+ ($_ seq
+ (test "Will reject empty pattern-matching (no branches)."
+ (|> (analyse-pm (list))
+ _structure.check-fails))
+ (test "Can analyse exhaustive pattern-matching."
+ (|> (analyse-pm exhaustive-branchesC)
+ _structure.check-succeeds))
+ (test "Will reject non-exhaustive pattern-matching."
+ (|> (analyse-pm non-exhaustive-branchesC)
+ _structure.check-fails))
+ (test "Will reject redundant pattern-matching."
+ (|> (analyse-pm redundant-branchesC)
+ _structure.check-fails))
+ (test "Will reject pattern-matching if the bodies of the branches do not all have the same type."
+ (|> (analyse-pm heterogeneous-branchesC)
+ _structure.check-fails)))
+ )))
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/function.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/function.lux
new file mode 100644
index 000000000..0ec5d4766
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/analysis/function.lux
@@ -0,0 +1,118 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ ["." error]
+ ["." maybe]
+ ["." product]
+ [text ("text/." equivalence)
+ format]
+ [collection
+ ["." list ("list/." functor)]]]
+ [math
+ ["r" random]]
+ ["." type]
+ ["." macro
+ ["." code]]
+ [compiler
+ [default
+ ["." reference]
+ ["." init]
+ ["." phase
+ ["." analysis (#+ Analysis Operation)
+ [".A" type]
+ ["." expression]
+ ["/" function]]
+ [extension
+ [".E" analysis]]]]]
+ test]
+ [//
+ ["_." primitive]
+ ["_." structure]])
+
+(def: (check-apply expectedT num-args analysis)
+ (-> Type Nat (Operation Analysis) Bit)
+ (|> analysis
+ (typeA.with-type expectedT)
+ (phase.run _primitive.state)
+ (case> (#error.Success applyA)
+ (let [[funcA argsA] (analysis.application applyA)]
+ (n/= num-args (list.size argsA)))
+
+ (#error.Failure error)
+ #0)))
+
+(context: "Function definition."
+ (<| (times 100)
+ (do @
+ [func-name (r.unicode 5)
+ arg-name (|> (r.unicode 5) (r.filter (|>> (text/= func-name) not)))
+ [outputT outputC] _primitive.primitive
+ [inputT _] _primitive.primitive
+ #let [g!arg (code.local-identifier arg-name)]]
+ ($_ seq
+ (test "Can analyse function."
+ (and (|> (typeA.with-type (All [a] (-> a outputT))
+ (/.function _primitive.phase func-name arg-name outputC))
+ _structure.check-succeeds)
+ (|> (typeA.with-type (All [a] (-> a a))
+ (/.function _primitive.phase func-name arg-name g!arg))
+ _structure.check-succeeds)))
+ (test "Generic functions can always be specialized."
+ (and (|> (typeA.with-type (-> inputT outputT)
+ (/.function _primitive.phase func-name arg-name outputC))
+ _structure.check-succeeds)
+ (|> (typeA.with-type (-> inputT inputT)
+ (/.function _primitive.phase func-name arg-name g!arg))
+ _structure.check-succeeds)))
+ (test "The function's name is bound to the function's type."
+ (|> (typeA.with-type (Rec self (-> inputT self))
+ (/.function _primitive.phase func-name arg-name (code.local-identifier func-name)))
+ _structure.check-succeeds))
+ ))))
+
+(context: "Function application."
+ (<| (times 100)
+ (do @
+ [full-args (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ partial-args (|> r.nat (:: @ map (n/% full-args)))
+ var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max 1))))
+ inputsTC (r.list full-args _primitive.primitive)
+ #let [inputsT (list/map product.left inputsTC)
+ inputsC (list/map product.right inputsTC)]
+ [outputT outputC] _primitive.primitive
+ #let [funcT (type.function inputsT outputT)
+ partialT (type.function (list.drop partial-args inputsT) outputT)
+ varT (#.Parameter 1)
+ polyT (<| (type.univ-q 1)
+ (type.function (list.concat (list (list.take var-idx inputsT)
+ (list varT)
+ (list.drop (inc var-idx) inputsT))))
+ varT)
+ poly-inputT (maybe.assume (list.nth var-idx inputsT))
+ partial-poly-inputsT (list.drop (inc var-idx) inputsT)
+ partial-polyT1 (<| (type.function partial-poly-inputsT)
+ poly-inputT)
+ partial-polyT2 (<| (type.univ-q 1)
+ (type.function (#.Cons varT partial-poly-inputsT))
+ varT)
+ dummy-function (#analysis.Function (list) (#analysis.Reference (reference.local 1)))]]
+ ($_ seq
+ (test "Can analyse monomorphic type application."
+ (|> (/.apply _primitive.phase funcT dummy-function inputsC)
+ (check-apply outputT full-args)))
+ (test "Can partially apply functions."
+ (|> (/.apply _primitive.phase funcT dummy-function (list.take partial-args inputsC))
+ (check-apply partialT partial-args)))
+ (test "Can apply polymorphic functions."
+ (|> (/.apply _primitive.phase polyT dummy-function inputsC)
+ (check-apply poly-inputT full-args)))
+ (test "Polymorphic partial application propagates found type-vars."
+ (|> (/.apply _primitive.phase polyT dummy-function (list.take (inc var-idx) inputsC))
+ (check-apply partial-polyT1 (inc var-idx))))
+ (test "Polymorphic partial application preserves quantification for type-vars."
+ (|> (/.apply _primitive.phase polyT dummy-function (list.take var-idx inputsC))
+ (check-apply partial-polyT2 var-idx)))
+ ))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux
new file mode 100644
index 000000000..de079094b
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/analysis/primitive.lux
@@ -0,0 +1,100 @@
+(.module:
+ [lux (#- primitive)
+ [control
+ [monad (#+ do)]
+ pipe
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." error (#+ Error)]
+ [text
+ format]]
+ [math
+ ["r" random ("random/." monad)]]
+ [".L" type ("type/." equivalence)]
+ [macro
+ ["." code]]
+ [compiler
+ [default
+ ["." init]
+ [evaluation (#+ Eval)]
+ ["." phase
+ ["." analysis (#+ Analysis Operation)
+ [".A" type]
+ ["." expression]]
+ [extension
+ [".E" analysis]]]]]
+ test])
+
+(def: #export phase
+ analysis.Phase
+ expression.compile)
+
+(def: #export state
+ analysis.State+
+ [(analysisE.bundle (:coerce Eval [])) (init.compiler [])])
+
+(def: unit
+ (r.Random Code)
+ (random/wrap (' [])))
+
+(def: #export primitive
+ (r.Random [Type Code])
+ (`` ($_ r.either
+ (~~ (do-template [<type> <code-wrapper> <value-gen>]
+ [(r.and (random/wrap <type>) (random/map <code-wrapper> <value-gen>))]
+
+ [Any code.tuple (r.list 0 ..unit)]
+ [Bit code.bit r.bit]
+ [Nat code.nat r.nat]
+ [Int code.int r.int]
+ [Rev code.rev r.rev]
+ [Frac code.frac r.frac]
+ [Text code.text (r.unicode 5)]
+ )))))
+
+(exception: (wrong-inference {expected Type} {inferred Type})
+ (ex.report ["Expected" (%type expected)]
+ ["Inferred" (%type inferred)]))
+
+(def: (infer-primitive expected-type analysis)
+ (-> Type (Operation Analysis) (Error Analysis))
+ (|> analysis
+ typeA.with-inference
+ (phase.run ..state)
+ (case> (#error.Success [inferred-type output])
+ (if (is? expected-type inferred-type)
+ (#error.Success output)
+ (ex.throw wrong-inference [expected-type inferred-type]))
+
+ (#error.Failure error)
+ (#error.Failure error))))
+
+(context: "Primitives"
+ ($_ seq
+ (test "Can analyse unit."
+ (|> (infer-primitive Any (..phase (' [])))
+ (case> (^ (#error.Success (#analysis.Primitive (#analysis.Unit output))))
+ (is? [] output)
+
+ _
+ #0)))
+ (<| (times 100)
+ (`` ($_ seq
+ (~~ (do-template [<desc> <type> <tag> <random> <constructor>]
+ [(do @
+ [sample <random>]
+ (test (format "Can analyse " <desc> ".")
+ (|> (infer-primitive <type> (..phase (<constructor> sample)))
+ (case> (#error.Success (#analysis.Primitive (<tag> output)))
+ (is? sample output)
+
+ _
+ #0))))]
+
+ ["bit" Bit #analysis.Bit r.bit code.bit]
+ ["nat" Nat #analysis.Nat r.nat code.nat]
+ ["int" Int #analysis.Int r.int code.int]
+ ["rev" Rev #analysis.Rev r.rev code.rev]
+ ["frac" Frac #analysis.Frac r.frac code.frac]
+ ["text" Text #analysis.Text (r.unicode 5) code.text]
+ )))))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux
new file mode 100644
index 000000000..6576ae90d
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/analysis/procedure/common.lux
@@ -0,0 +1,187 @@
+(.module:
+ [lux #*
+ [io]
+ [control
+ [monad (#+ do)]
+ pipe]
+ [concurrency
+ ["." atom]]
+ [data
+ ["." error]
+ ["." product]
+ [text
+ format]]
+ [math
+ ["r" random]]
+ [type ("type/." equivalence)]
+ [macro
+ ["." code]]
+ [compiler
+ [default
+ ["." init]
+ ["." phase
+ [analysis
+ ["." scope]
+ [".A" type]]
+ [extension
+ [".E" analysis]]]]]
+ test]
+ [///
+ ["_." primitive]])
+
+(do-template [<name> <success> <failure>]
+ [(def: (<name> procedure params output-type)
+ (-> Text (List Code) Type Bit)
+ (|> (scope.with-scope ""
+ (typeA.with-type output-type
+ (_primitive.phase (` ((~ (code.text procedure)) (~+ params))))))
+ (phase.run _primitive.state)
+ (case> (#error.Success _)
+ <success>
+
+ (#error.Failure error)
+ <failure>)))]
+
+ [check-success+ #1 #0]
+ [check-failure+ #0 #1]
+ )
+
+(context: "Lux procedures"
+ (<| (times 100)
+ (do @
+ [[primT primC] _primitive.primitive
+ [antiT antiC] (|> _primitive.primitive
+ (r.filter (|>> product.left (type/= primT) not)))]
+ ($_ seq
+ (test "Can test for reference equality."
+ (check-success+ "lux is" (list primC primC) Bit))
+ (test "Reference equality must be done with elements of the same type."
+ (check-failure+ "lux is" (list primC antiC) Bit))
+ (test "Can 'try' risky IO computations."
+ (check-success+ "lux try"
+ (list (` ([(~' _) (~' _)] (~ primC))))
+ (type (Either Text primT))))
+ ))))
+
+(context: "Bit procedures"
+ (<| (times 100)
+ (do @
+ [subjectC (|> r.nat (:: @ map code.nat))
+ signedC (|> r.int (:: @ map code.int))
+ paramC (|> r.nat (:: @ map code.nat))]
+ ($_ seq
+ (test "Can perform bit 'and'."
+ (check-success+ "lux bit and" (list subjectC paramC) Nat))
+ (test "Can perform bit 'or'."
+ (check-success+ "lux bit or" (list subjectC paramC) Nat))
+ (test "Can perform bit 'xor'."
+ (check-success+ "lux bit xor" (list subjectC paramC) Nat))
+ (test "Can shift bit pattern to the left."
+ (check-success+ "lux bit left-shift" (list subjectC paramC) Nat))
+ (test "Can shift bit pattern to the right."
+ (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat))
+ (test "Can shift signed bit pattern to the right."
+ (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int))
+ ))))
+
+(context: "Int procedures"
+ (<| (times 100)
+ (do @
+ [subjectC (|> r.int (:: @ map code.int))
+ paramC (|> r.int (:: @ map code.int))]
+ ($_ seq
+ (test "Can add integers."
+ (check-success+ "lux int +" (list subjectC paramC) Int))
+ (test "Can subtract integers."
+ (check-success+ "lux int -" (list subjectC paramC) Int))
+ (test "Can multiply integers."
+ (check-success+ "lux int *" (list subjectC paramC) Int))
+ (test "Can divide integers."
+ (check-success+ "lux int /" (list subjectC paramC) Int))
+ (test "Can calculate remainder of integers."
+ (check-success+ "lux int %" (list subjectC paramC) Int))
+ (test "Can test equivalence of integers."
+ (check-success+ "lux int =" (list subjectC paramC) Bit))
+ (test "Can compare integers."
+ (check-success+ "lux int <" (list subjectC paramC) Bit))
+ (test "Can convert integer to fraction."
+ (check-success+ "lux int to-frac" (list subjectC) Frac))
+ (test "Can convert integer to text."
+ (check-success+ "lux int char" (list subjectC) Text))
+ ))))
+
+(context: "Frac procedures"
+ (<| (times 100)
+ (do @
+ [subjectC (|> r.frac (:: @ map code.frac))
+ paramC (|> r.frac (:: @ map code.frac))
+ encodedC (|> (r.unicode 5) (:: @ map code.text))]
+ ($_ seq
+ (test "Can add frac numbers."
+ (check-success+ "lux frac +" (list subjectC paramC) Frac))
+ (test "Can subtract frac numbers."
+ (check-success+ "lux frac -" (list subjectC paramC) Frac))
+ (test "Can multiply frac numbers."
+ (check-success+ "lux frac *" (list subjectC paramC) Frac))
+ (test "Can divide frac numbers."
+ (check-success+ "lux frac /" (list subjectC paramC) Frac))
+ (test "Can calculate remainder of frac numbers."
+ (check-success+ "lux frac %" (list subjectC paramC) Frac))
+ (test "Can test equivalence of frac numbers."
+ (check-success+ "lux frac =" (list subjectC paramC) Bit))
+ (test "Can compare frac numbers."
+ (check-success+ "lux frac <" (list subjectC paramC) Bit))
+ (test "Can obtain minimum frac number."
+ (check-success+ "lux frac min" (list) Frac))
+ (test "Can obtain maximum frac number."
+ (check-success+ "lux frac max" (list) Frac))
+ (test "Can obtain smallest frac number."
+ (check-success+ "lux frac smallest" (list) Frac))
+ (test "Can convert frac number to integer."
+ (check-success+ "lux frac to-int" (list subjectC) Int))
+ (test "Can convert frac number to text."
+ (check-success+ "lux frac encode" (list subjectC) Text))
+ (test "Can convert text to frac number."
+ (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac))))
+ ))))
+
+(context: "Text procedures"
+ (<| (times 100)
+ (do @
+ [subjectC (|> (r.unicode 5) (:: @ map code.text))
+ paramC (|> (r.unicode 5) (:: @ map code.text))
+ replacementC (|> (r.unicode 5) (:: @ map code.text))
+ fromC (|> r.nat (:: @ map code.nat))
+ toC (|> r.nat (:: @ map code.nat))]
+ ($_ seq
+ (test "Can test text equivalence."
+ (check-success+ "lux text =" (list subjectC paramC) Bit))
+ (test "Compare texts in lexicographical order."
+ (check-success+ "lux text <" (list subjectC paramC) Bit))
+ (test "Can concatenate one text to another."
+ (check-success+ "lux text concat" (list subjectC paramC) Text))
+ (test "Can find the index of a piece of text inside a larger one that (may) contain it."
+ (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat))))
+ (test "Can query the size/length of a text."
+ (check-success+ "lux text size" (list subjectC) Nat))
+ (test "Can obtain the character code of a text at a given index."
+ (check-success+ "lux text char" (list subjectC fromC) Nat))
+ (test "Can clip a piece of text between 2 indices."
+ (check-success+ "lux text clip" (list subjectC fromC toC) Text))
+ ))))
+
+(context: "IO procedures"
+ (<| (times 100)
+ (do @
+ [logC (|> (r.unicode 5) (:: @ map code.text))
+ exitC (|> r.int (:: @ map code.int))]
+ ($_ seq
+ (test "Can log messages to standard output."
+ (check-success+ "lux io log" (list logC) Any))
+ (test "Can throw a run-time error."
+ (check-success+ "lux io error" (list logC) Nothing))
+ (test "Can exit the program."
+ (check-success+ "lux io exit" (list exitC) Nothing))
+ (test "Can query the current time (as milliseconds since epoch)."
+ (check-success+ "lux io current-time" (list) Int))
+ ))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux
new file mode 100644
index 000000000..18ab58fa9
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/analysis/reference.lux
@@ -0,0 +1,107 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ ["." error (#+ Error)]
+ [name ("name/." equivalence)]
+ [text ("text/." equivalence)]]
+ [math
+ ["r" random]]
+ [type ("type/." equivalence)]
+ [macro
+ ["." code]]
+ [compiler
+ [default
+ ["." reference]
+ ["." init]
+ ["." phase
+ ["." analysis
+ ["." scope]
+ ["." module]
+ [".A" type]
+ ["." expression]]
+ [extension
+ [".E" analysis]]]]]
+ test]
+ [//
+ ["_." primitive]])
+
+(type: Check (-> (Error Any) Bit))
+
+(do-template [<name> <on-success> <on-failure>]
+ [(def: <name>
+ Check
+ (|>> (case> (#error.Success _)
+ <on-success>
+
+ (#error.Failure _)
+ <on-failure>)))]
+
+ [success? #1 #0]
+ [failure? #0 #1]
+ )
+
+(def: (reach-test var-name [export? def-module] [import? dependent-module] check!)
+ (-> Text [Bit Text] [Bit Text] Check Bit)
+ (|> (do phase.monad
+ [_ (module.with-module 0 def-module
+ (module.define var-name [Any
+ (if export?
+ (' {#.export? #1})
+ (' {}))
+ []]))]
+ (module.with-module 0 dependent-module
+ (do @
+ [_ (if import?
+ (module.import def-module)
+ (wrap []))]
+ (typeA.with-inference
+ (_primitive.phase (code.identifier [def-module var-name]))))))
+ (phase.run _primitive.state)
+ check!))
+
+(context: "References"
+ (<| (times 100)
+ (do @
+ [[expectedT _] _primitive.primitive
+ def-module (r.unicode 5)
+ scope-name (r.unicode 5)
+ var-name (r.unicode 5)
+ dependent-module (|> (r.unicode 5)
+ (r.filter (|>> (text/= def-module) not)))]
+ ($_ seq
+ (test "Can analyse variable."
+ (|> (scope.with-scope scope-name
+ (scope.with-local [var-name expectedT]
+ (typeA.with-inference
+ (_primitive.phase (code.local-identifier var-name)))))
+ (phase.run _primitive.state)
+ (case> (^ (#error.Success [inferredT (#analysis.Reference (reference.local var))]))
+ (and (type/= expectedT inferredT)
+ (n/= 0 var))
+
+ _
+ #0)))
+ (test "Can analyse definition (in the same module)."
+ (let [def-name [def-module var-name]]
+ (|> (do phase.monad
+ [_ (module.define var-name [expectedT (' {}) []])]
+ (typeA.with-inference
+ (_primitive.phase (code.identifier def-name))))
+ (module.with-module 0 def-module)
+ (phase.run _primitive.state)
+ (case> (^ (#error.Success [_ inferredT (#analysis.Reference (reference.constant constant-name))]))
+ (and (type/= expectedT inferredT)
+ (name/= def-name constant-name))
+
+ _
+ #0))))
+ (test "Can analyse definition (if exported from imported module)."
+ (reach-test var-name [#1 def-module] [#1 dependent-module] success?))
+ (test "Cannot analyse definition (if not exported from imported module)."
+ (reach-test var-name [#0 def-module] [#1 dependent-module] failure?))
+ (test "Cannot analyse definition (if exported from non-imported module)."
+ (reach-test var-name [#1 def-module] [#0 dependent-module] failure?))
+ ))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux
new file mode 100644
index 000000000..63c6da493
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/analysis/structure.lux
@@ -0,0 +1,297 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ [bit ("bit/." equivalence)]
+ ["e" error]
+ ["." product]
+ ["." maybe]
+ ["." text]
+ [collection
+ ["." list ("list/." functor)]
+ ["." set]]]
+ [math
+ ["r" random]]
+ ["." type ("type/." equivalence)
+ ["." check]]
+ [macro
+ ["." code]]
+ [compiler
+ [default
+ ["." init]
+ ["." phase
+ ["." analysis (#+ Analysis Variant Tag Operation)
+ ["." module]
+ [".A" type]
+ ["/" structure]
+ ["." expression]]
+ [extension
+ [".E" analysis]]]]]
+ test]
+ [//
+ ["_." primitive]])
+
+(do-template [<name> <on-success> <on-error>]
+ [(def: #export <name>
+ (All [a] (-> (Operation a) Bit))
+ (|>> (phase.run _primitive.state)
+ (case> (#e.Success _)
+ <on-success>
+
+ _
+ <on-error>)))]
+
+ [check-succeeds #1 #0]
+ [check-fails #0 #1]
+ )
+
+(def: (check-sum' size tag variant)
+ (-> Nat Tag (Variant Analysis) Bit)
+ (let [variant-tag (if (get@ #analysis.right? variant)
+ (inc (get@ #analysis.lefts variant))
+ (get@ #analysis.lefts variant))]
+ (|> size dec (n/= tag)
+ (bit/= (get@ #analysis.right? variant))
+ (and (n/= tag variant-tag)))))
+
+(def: (check-sum type size tag analysis)
+ (-> Type Nat Tag (Operation Analysis) Bit)
+ (|> analysis
+ (typeA.with-type type)
+ (phase.run _primitive.state)
+ (case> (^ (#e.Success (analysis.variant variant)))
+ (check-sum' size tag variant)
+
+ _
+ #0)))
+
+(def: (tagged module tags type)
+ (All [a] (-> Text (List module.Tag) Type (Operation a) (Operation [Module a])))
+ (|>> (do phase.monad
+ [_ (module.declare-tags tags #0 type)])
+ (module.with-module 0 module)))
+
+(def: (check-variant module tags type size tag analysis)
+ (-> Text (List module.Tag) Type Nat Tag (Operation Analysis) Bit)
+ (|> analysis
+ (tagged module tags type)
+ (typeA.with-type type)
+ (phase.run _primitive.state)
+ (case> (^ (#e.Success [_ (analysis.variant variant)]))
+ (check-sum' size tag variant)
+
+ _
+ #0)))
+
+(def: (right-size? size)
+ (-> Nat (-> Analysis Bit))
+ (|>> (case> (^ (analysis.tuple elems))
+ (|> elems
+ list.size
+ (n/= size))
+
+ _
+ false)))
+
+(def: (check-record-inference module tags type size analysis)
+ (-> Text (List module.Tag) Type Nat (Operation [Type Analysis]) Bit)
+ (|> analysis
+ (tagged module tags type)
+ (phase.run _primitive.state)
+ (case> (#e.Success [_ productT productA])
+ (and (type/= type productT)
+ (right-size? size productA))
+
+ _
+ #0)))
+
+(context: "Sums"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ choice (|> r.nat (:: @ map (n/% size)))
+ primitives (r.list size _primitive.primitive)
+ +choice (|> r.nat (:: @ map (n/% (inc size))))
+ [_ +valueC] _primitive.primitive
+ #let [variantT (type.variant (list/map product.left primitives))
+ [valueT valueC] (maybe.assume (list.nth choice primitives))
+ +size (inc size)
+ +primitives (list.concat (list (list.take choice primitives)
+ (list [(#.Parameter 1) +valueC])
+ (list.drop choice primitives)))
+ [+valueT +valueC] (maybe.assume (list.nth +choice +primitives))
+ +variantT (type.variant (list/map product.left +primitives))]]
+ ($_ seq
+ (test "Can analyse sum."
+ (check-sum variantT size choice
+ (/.sum _primitive.phase choice valueC)))
+ (test "Can analyse sum through bound type-vars."
+ (|> (do phase.monad
+ [[_ varT] (typeA.with-env check.var)
+ _ (typeA.with-env
+ (check.check varT variantT))]
+ (typeA.with-type varT
+ (/.sum _primitive.phase choice valueC)))
+ (phase.run _primitive.state)
+ (case> (^ (#e.Success (analysis.variant variant)))
+ (check-sum' size choice variant)
+
+ _
+ #0)))
+ (test "Cannot analyse sum through unbound type-vars."
+ (|> (do phase.monad
+ [[_ varT] (typeA.with-env check.var)]
+ (typeA.with-type varT
+ (/.sum _primitive.phase choice valueC)))
+ check-fails))
+ (test "Can analyse sum through existential quantification."
+ (|> (typeA.with-type (type.ex-q 1 +variantT)
+ (/.sum _primitive.phase +choice +valueC))
+ check-succeeds))
+ (test "Can analyse sum through universal quantification."
+ (let [check-outcome (if (not (n/= choice +choice))
+ check-succeeds
+ check-fails)]
+ (|> (typeA.with-type (type.univ-q 1 +variantT)
+ (/.sum _primitive.phase +choice +valueC))
+ check-outcome)))
+ ))))
+
+(context: "Products"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ primitives (r.list size _primitive.primitive)
+ choice (|> r.nat (:: @ map (n/% size)))
+ [_ +valueC] _primitive.primitive
+ #let [tupleT (type.tuple (list/map product.left primitives))
+ [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume)
+ +primitives (list.concat (list (list.take choice primitives)
+ (list [(#.Parameter 1) +valueC])
+ (list.drop choice primitives)))
+ +tupleT (type.tuple (list/map product.left +primitives))]]
+ ($_ seq
+ (test "Can analyse product."
+ (|> (typeA.with-type tupleT
+ (/.product _primitive.phase (list/map product.right primitives)))
+ (phase.run _primitive.state)
+ (case> (#e.Success tupleA)
+ (right-size? size tupleA)
+
+ _
+ #0)))
+ (test "Can infer product."
+ (|> (typeA.with-inference
+ (/.product _primitive.phase (list/map product.right primitives)))
+ (phase.run _primitive.state)
+ (case> (#e.Success [_type tupleA])
+ (and (type/= tupleT _type)
+ (right-size? size tupleA))
+
+ _
+ #0)))
+ (test "Can analyse pseudo-product (singleton tuple)"
+ (|> (typeA.with-type singletonT
+ (_primitive.phase (` [(~ singletonC)])))
+ check-succeeds))
+ (test "Can analyse product through bound type-vars."
+ (|> (do phase.monad
+ [[_ varT] (typeA.with-env check.var)
+ _ (typeA.with-env
+ (check.check varT (type.tuple (list/map product.left primitives))))]
+ (typeA.with-type varT
+ (/.product _primitive.phase (list/map product.right primitives))))
+ (phase.run _primitive.state)
+ (case> (#e.Success tupleA)
+ (right-size? size tupleA)
+
+ _
+ #0)))
+ (test "Can analyse product through existential quantification."
+ (|> (typeA.with-type (type.ex-q 1 +tupleT)
+ (/.product _primitive.phase (list/map product.right +primitives)))
+ check-succeeds))
+ (test "Cannot analyse product through universal quantification."
+ (|> (typeA.with-type (type.univ-q 1 +tupleT)
+ (/.product _primitive.phase (list/map product.right +primitives)))
+ check-fails))
+ ))))
+
+(context: "Tagged Sums"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list))
+ choice (|> r.nat (:: @ map (n/% size)))
+ other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not)))
+ primitives (r.list size _primitive.primitive)
+ module-name (r.unicode 5)
+ type-name (r.unicode 5)
+ #let [varT (#.Parameter 1)
+ primitivesT (list/map product.left primitives)
+ [choiceT choiceC] (maybe.assume (list.nth choice primitives))
+ [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives))
+ variantT (type.variant primitivesT)
+ namedT (#.Named [module-name type-name] variantT)
+ named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT)
+ (list varT)
+ (list.drop (inc choice) primitivesT))))
+ (type.univ-q 1)
+ (#.Named [module-name type-name]))
+ choice-tag (maybe.assume (list.nth choice tags))
+ other-choice-tag (maybe.assume (list.nth other-choice tags))]]
+ ($_ seq
+ (test "Can infer tagged sum."
+ (|> (/.tagged-sum _primitive.phase [module-name choice-tag] choiceC)
+ (check-variant module-name tags namedT choice size)))
+ (test "Tagged sums specialize when type-vars get bound."
+ (|> (/.tagged-sum _primitive.phase [module-name choice-tag] choiceC)
+ (check-variant module-name tags named-polyT choice size)))
+ (test "Tagged sum inference retains universal quantification when type-vars are not bound."
+ (|> (/.tagged-sum _primitive.phase [module-name other-choice-tag] other-choiceC)
+ (check-variant module-name tags named-polyT other-choice size)))
+ (test "Can specialize generic tagged sums."
+ (|> (typeA.with-type variantT
+ (/.tagged-sum _primitive.phase [module-name other-choice-tag] other-choiceC))
+ (check-variant module-name tags named-polyT other-choice size)))
+ ))))
+
+(context: "Records"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list))
+ primitives (r.list size _primitive.primitive)
+ module-name (r.unicode 5)
+ type-name (r.unicode 5)
+ choice (|> r.nat (:: @ map (n/% size)))
+ #let [varT (#.Parameter 1)
+ tagsC (list/map (|>> [module-name] code.tag) tags)
+ primitivesT (list/map product.left primitives)
+ primitivesC (list/map product.right primitives)
+ tupleT (type.tuple primitivesT)
+ namedT (#.Named [module-name type-name] tupleT)
+ recordC (list.zip2 tagsC primitivesC)
+ named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT)
+ (list varT)
+ (list.drop (inc choice) primitivesT))))
+ (type.univ-q 1)
+ (#.Named [module-name type-name]))]]
+ ($_ seq
+ (test "Can infer record."
+ (|> (typeA.with-inference
+ (/.record _primitive.phase recordC))
+ (check-record-inference module-name tags namedT size)))
+ (test "Records specialize when type-vars get bound."
+ (|> (typeA.with-inference
+ (/.record _primitive.phase recordC))
+ (check-record-inference module-name tags named-polyT size)))
+ (test "Can specialize generic records."
+ (|> (do phase.monad
+ [recordA (typeA.with-type tupleT
+ (/.record _primitive.phase recordC))]
+ (wrap [tupleT recordA]))
+ (check-record-inference module-name tags named-polyT size)))
+ ))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/synthesis/case.lux b/stdlib/source/test/lux/compiler/default/phase/synthesis/case.lux
new file mode 100644
index 000000000..319d4ab57
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/synthesis/case.lux
@@ -0,0 +1,88 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ ["." error ("error/." functor)]]
+ [compiler
+ [default
+ ["." reference]
+ ["." phase
+ ["." analysis (#+ Branch Analysis)]
+ ["//" synthesis (#+ Synthesis)
+ ["." expression]]
+ [extension
+ ["." bundle]]]]]
+ [math
+ ["r" random]]
+ test]
+ ["." //primitive])
+
+(context: "Dummy variables."
+ (<| (times 100)
+ (do @
+ [maskedA //primitive.primitive
+ temp (|> r.nat (:: @ map (n/% 100)))
+ #let [maskA (analysis.control/case
+ [maskedA
+ [[(#analysis.Bind temp)
+ (#analysis.Reference (reference.local temp))]
+ (list)]])]]
+ (test "Dummy variables created to mask expressions get eliminated during synthesis."
+ (|> maskA
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (error/map (//primitive.corresponds? maskedA))
+ (error.default #0))))))
+
+(context: "Let expressions."
+ (<| (times 100)
+ (do @
+ [registerA r.nat
+ inputA //primitive.primitive
+ outputA //primitive.primitive
+ #let [letA (analysis.control/case
+ [inputA
+ [[(#analysis.Bind registerA)
+ outputA]
+ (list)]])]]
+ (test "Can detect and reify simple 'let' expressions."
+ (|> letA
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.branch/let [inputS registerS outputS])))
+ (and (n/= registerA registerS)
+ (//primitive.corresponds? inputA inputS)
+ (//primitive.corresponds? outputA outputS))
+
+ _
+ #0))))))
+
+(context: "If expressions."
+ (<| (times 100)
+ (do @
+ [then|else r.bit
+ inputA //primitive.primitive
+ thenA //primitive.primitive
+ elseA //primitive.primitive
+ #let [thenB (: Branch
+ [(#analysis.Simple (#analysis.Bit #1))
+ thenA])
+ elseB (: Branch
+ [(#analysis.Simple (#analysis.Bit #0))
+ elseA])
+ ifA (if then|else
+ (analysis.control/case [inputA [thenB (list elseB)]])
+ (analysis.control/case [inputA [elseB (list thenB)]]))]]
+ (test "Can detect and reify simple 'if' expressions."
+ (|> ifA
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.branch/if [inputS thenS elseS])))
+ (and (//primitive.corresponds? inputA inputS)
+ (//primitive.corresponds? thenA thenS)
+ (//primitive.corresponds? elseA elseS))
+
+ _
+ #0))))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/synthesis/function.lux b/stdlib/source/test/lux/compiler/default/phase/synthesis/function.lux
new file mode 100644
index 000000000..f2565dfa0
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/synthesis/function.lux
@@ -0,0 +1,174 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." error]
+ ["." number]
+ [text
+ format]
+ [collection
+ ["." list ("list/." functor fold)]
+ ["dict" dictionary (#+ Dictionary)]
+ ["." set]]]
+ [compiler
+ [default
+ ["." reference (#+ Variable) ("variable/." equivalence)]
+ ["." phase
+ ["." analysis (#+ Arity Analysis)]
+ ["//" synthesis (#+ Synthesis)
+ ["." expression]]
+ [extension
+ ["." bundle]]]]]
+ [math
+ ["r" random]]
+ test]
+ ["." //primitive])
+
+(def: constant-function
+ (r.Random [Arity Analysis Analysis])
+ (r.rec
+ (function (_ constant-function)
+ (do r.monad
+ [function? r.bit]
+ (if function?
+ (do @
+ [[arity bodyA predictionA] constant-function]
+ (wrap [(inc arity)
+ (#analysis.Function (list) bodyA)
+ predictionA]))
+ (do @
+ [predictionA //primitive.primitive]
+ (wrap [0 predictionA predictionA])))))))
+
+(def: (pick scope-size)
+ (-> Nat (r.Random Nat))
+ (|> r.nat (:: r.monad map (n/% scope-size))))
+
+(def: function-with-environment
+ (r.Random [Arity Analysis Variable])
+ (do r.monad
+ [num-locals (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))
+ #let [indices (list.n/range 0 (dec num-locals))
+ local-env (list/map (|>> #reference.Local) indices)
+ foreign-env (list/map (|>> #reference.Foreign) indices)]
+ [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable])
+ (loop [arity 1
+ current-env foreign-env]
+ (let [current-env/size (list.size current-env)
+ resolver (list/fold (function (_ [idx var] resolver)
+ (dict.put idx var resolver))
+ (: (Dictionary Nat Variable)
+ (dict.new number.hash))
+ (list.enumerate current-env))]
+ (do @
+ [nest? r.bit]
+ (if nest?
+ (do @
+ [num-picks (:: @ map (n/max 1) (pick (inc current-env/size)))
+ picks (|> (r.set number.hash num-picks (pick current-env/size))
+ (:: @ map set.to-list))
+ [arity bodyA predictionA] (recur (inc arity)
+ (list/map (function (_ pick)
+ (maybe.assume (list.nth pick current-env)))
+ picks))
+ #let [picked-env (list/map (|>> #reference.Foreign) picks)]]
+ (wrap [arity
+ (#analysis.Function picked-env bodyA)
+ predictionA]))
+ (do @
+ [chosen (pick (list.size current-env))]
+ (wrap [arity
+ (#analysis.Reference (reference.foreign chosen))
+ (maybe.assume (dict.get chosen resolver))])))))))]
+ (wrap [arity
+ (#analysis.Function local-env bodyA)
+ predictionA])))
+
+(def: local-function
+ (r.Random [Arity Analysis Variable])
+ (loop [arity 0
+ nest? #1]
+ (if nest?
+ (do r.monad
+ [nest?' r.bit
+ [arity' bodyA predictionA] (recur (inc arity) nest?')]
+ (wrap [arity'
+ (#analysis.Function (list) bodyA)
+ predictionA]))
+ (do r.monad
+ [chosen (|> r.nat (:: @ map (|>> (n/% 100) (n/max 2))))]
+ (wrap [arity
+ (#analysis.Reference (reference.local chosen))
+ (|> chosen (n/+ (dec arity)) #reference.Local)])))))
+
+(context: "Abstraction."
+ (<| (times 100)
+ (do @
+ [[arity//constant function//constant prediction//constant] constant-function
+ [arity//environment function//environment prediction//environment] function-with-environment
+ [arity//local function//local prediction//local] local-function]
+ ($_ seq
+ (test "Nested functions will get folded together."
+ (|> function//constant
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.function/abstraction [environment arity output])))
+ (and (n/= arity//constant arity)
+ (//primitive.corresponds? prediction//constant output))
+
+ _
+ (n/= 0 arity//constant))))
+ (test "Folded functions provide direct access to environment variables."
+ (|> function//environment
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))])))
+ (and (n/= arity//environment arity)
+ (variable/= prediction//environment output))
+
+ _
+ #0)))
+ (test "Folded functions properly offset local variables."
+ (|> function//local
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))])))
+ (and (n/= arity//local arity)
+ (variable/= prediction//local output))
+
+ _
+ #0)))
+ ))))
+
+(context: "Application."
+ (<| (times 100)
+ (do @
+ [arity (|> r.nat (:: @ map (|>> (n/% 10) (n/max 1))))
+ funcA //primitive.primitive
+ argsA (r.list arity //primitive.primitive)]
+ ($_ seq
+ (test "Can synthesize function application."
+ (|> (analysis.apply [funcA argsA])
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.function/apply [funcS argsS])))
+ (and (//primitive.corresponds? funcA funcS)
+ (list.every? (product.uncurry //primitive.corresponds?)
+ (list.zip2 argsA argsS)))
+
+ _
+ #0)))
+ (test "Function application on no arguments just synthesizes to the function itself."
+ (|> (analysis.apply [funcA (list)])
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (#error.Success funcS)
+ (//primitive.corresponds? funcA funcS)
+
+ _
+ #0)))
+ ))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/synthesis/primitive.lux b/stdlib/source/test/lux/compiler/default/phase/synthesis/primitive.lux
new file mode 100644
index 000000000..87dccc9f5
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/synthesis/primitive.lux
@@ -0,0 +1,97 @@
+(.module:
+ [lux (#- primitive)
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ ["." error]
+ [text
+ format]]
+ [compiler
+ [default
+ ["." phase
+ ["." analysis (#+ Analysis)]
+ ["//" synthesis (#+ Synthesis)
+ ["." expression]]
+ [extension
+ ["." bundle]]]]]
+ [math
+ ["r" random]]
+ test])
+
+(def: #export primitive
+ (r.Random Analysis)
+ (do r.monad
+ [primitive (: (r.Random analysis.Primitive)
+ ($_ r.or
+ (wrap [])
+ r.bit
+ r.nat
+ r.int
+ r.rev
+ r.frac
+ (r.unicode 5)))]
+ (wrap (#analysis.Primitive primitive))))
+
+(def: #export (corresponds? analysis synthesis)
+ (-> Analysis Synthesis Bit)
+ (case [synthesis analysis]
+ [(#//.Primitive (#//.Text valueS))
+ (#analysis.Primitive (#analysis.Unit valueA))]
+ (is? valueS (:coerce Text valueA))
+
+ [(#//.Primitive (#//.Bit valueS))
+ (#analysis.Primitive (#analysis.Bit valueA))]
+ (is? valueS valueA)
+
+ [(#//.Primitive (#//.I64 valueS))
+ (#analysis.Primitive (#analysis.Nat valueA))]
+ (is? (.i64 valueS) (.i64 valueA))
+
+ [(#//.Primitive (#//.I64 valueS))
+ (#analysis.Primitive (#analysis.Int valueA))]
+ (is? (.i64 valueS) (.i64 valueA))
+
+ [(#//.Primitive (#//.I64 valueS))
+ (#analysis.Primitive (#analysis.Rev valueA))]
+ (is? (.i64 valueS) (.i64 valueA))
+
+ [(#//.Primitive (#//.F64 valueS))
+ (#analysis.Primitive (#analysis.Frac valueA))]
+ (is? valueS valueA)
+
+ [(#//.Primitive (#//.Text valueS))
+ (#analysis.Primitive (#analysis.Text valueA))]
+ (is? valueS valueA)
+
+ _
+ #0))
+
+(context: "Primitives."
+ (<| (times 100)
+ (do @
+ [|bit| r.bit
+ |nat| r.nat
+ |int| r.int
+ |rev| r.rev
+ |frac| r.frac
+ |text| (r.unicode 5)]
+ (`` ($_ seq
+ (~~ (do-template [<desc> <analysis> <synthesis> <sample>]
+ [(test (format "Can synthesize " <desc> ".")
+ (|> (#analysis.Primitive (<analysis> <sample>))
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (#error.Success (#//.Primitive (<synthesis> value)))
+ (is? <sample> value)
+
+ _
+ #0)))]
+
+ ["unit" #analysis.Unit #//.Text //.unit]
+ ["bit" #analysis.Bit #//.Bit |bit|]
+ ["nat" #analysis.Nat #//.I64 (.i64 |nat|)]
+ ["int" #analysis.Int #//.I64 (.i64 |int|)]
+ ["rev" #analysis.Rev #//.I64 (.i64 |rev|)]
+ ["frac" #analysis.Frac #//.F64 |frac|]
+ ["text" #analysis.Text #//.Text |text|])))))))
diff --git a/stdlib/source/test/lux/compiler/default/phase/synthesis/structure.lux b/stdlib/source/test/lux/compiler/default/phase/synthesis/structure.lux
new file mode 100644
index 000000000..7f9eae209
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/phase/synthesis/structure.lux
@@ -0,0 +1,67 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ pipe]
+ [data
+ [bit ("bit/." equivalence)]
+ ["." product]
+ ["." error]
+ [collection
+ ["." list]]]
+ [compiler
+ [default
+ ["." phase
+ ["." analysis]
+ ["//" synthesis (#+ Synthesis)
+ ["." expression]]
+ [extension
+ ["." bundle]]]]]
+ [math
+ ["r" random]]
+ test]
+ ["." //primitive])
+
+(context: "Variants"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 10) (n/+ 2))))
+ tagA (|> r.nat (:: @ map (n/% size)))
+ #let [right? (n/= (dec size) tagA)
+ lefts (if right?
+ (dec tagA)
+ tagA)]
+ memberA //primitive.primitive]
+ ($_ seq
+ (test "Can synthesize variants."
+ (|> (analysis.variant [lefts right? memberA])
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.variant [leftsS right?S valueS])))
+ (let [tagS (if right?S (inc leftsS) leftsS)]
+ (and (n/= tagA tagS)
+ (|> tagS (n/= (dec size)) (bit/= right?S))
+ (//primitive.corresponds? memberA valueS)))
+
+ _
+ #0)))
+ ))))
+
+(context: "Tuples"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2))))
+ membersA (r.list size //primitive.primitive)]
+ ($_ seq
+ (test "Can synthesize tuple."
+ (|> (analysis.tuple membersA)
+ expression.phase
+ (phase.run [bundle.empty //.init])
+ (case> (^ (#error.Success (//.tuple membersS)))
+ (and (n/= size (list.size membersS))
+ (list.every? (product.uncurry //primitive.corresponds?)
+ (list.zip2 membersA membersS)))
+
+ _
+ #0)))
+ ))))
diff --git a/stdlib/source/test/lux/compiler/default/syntax.lux b/stdlib/source/test/lux/compiler/default/syntax.lux
new file mode 100644
index 000000000..fb83bda4c
--- /dev/null
+++ b/stdlib/source/test/lux/compiler/default/syntax.lux
@@ -0,0 +1,147 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ ["." error]
+ ["." text
+ format
+ ["l" lexer]]
+ [collection
+ ["." list]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ ["r" random ("r/." monad)]]
+ [macro
+ ["." code]]
+ [compiler
+ [default
+ ["&" syntax]]]
+ test])
+
+(def: default-cursor
+ Cursor
+ {#.module ""
+ #.line 0
+ #.column 0})
+
+(def: name-part^
+ (r.Random Text)
+ (do r.monad
+ [#let [digits "0123456789"
+ delimiters (format "()[]{}#." &.text-delimiter)
+ space (format " " text.new-line)
+ invalid-range (format digits delimiters space)
+ char-gen (|> r.nat
+ (:: @ map (|>> (n/% 256) (n/max 1)))
+ (r.filter (function (_ sample)
+ (not (text.contains? (text.from-code sample)
+ invalid-range)))))]
+ size (|> r.nat (:: @ map (|>> (n/% 20) (n/max 1))))]
+ (r.text char-gen size)))
+
+(def: name^
+ (r.Random Name)
+ (r.and name-part^ name-part^))
+
+(def: code^
+ (r.Random Code)
+ (let [numeric^ (: (r.Random Code)
+ ($_ r.either
+ (|> r.bit (r/map code.bit))
+ (|> r.nat (r/map code.nat))
+ (|> r.int (r/map code.int))
+ (|> r.rev (r/map code.rev))
+ (|> r.frac (r/map code.frac))))
+ textual^ (: (r.Random Code)
+ ($_ r.either
+ (do r.monad
+ [size (|> r.nat (r/map (n/% 20)))]
+ (|> (r.unicode size) (r/map code.text)))
+ (|> name^ (r/map code.identifier))
+ (|> name^ (r/map code.tag))))
+ simple^ (: (r.Random Code)
+ ($_ r.either
+ numeric^
+ textual^))]
+ (r.rec
+ (function (_ code^)
+ (let [multi^ (do r.monad
+ [size (|> r.nat (r/map (n/% 3)))]
+ (r.list size code^))
+ composite^ (: (r.Random Code)
+ ($_ r.either
+ (|> multi^ (r/map code.form))
+ (|> multi^ (r/map code.tuple))
+ (do r.monad
+ [size (|> r.nat (r/map (n/% 3)))]
+ (|> (r.list size (r.and code^ code^))
+ (r/map code.record)))))]
+ (r.either simple^
+ composite^))))))
+
+(context: "Lux code syntax."
+ (<| (times 100)
+ (do @
+ [sample code^
+ other code^]
+ ($_ seq
+ (test "Can parse Lux code."
+ (case (let [source-code (%code sample)]
+ (&.parse "" (dictionary.new text.hash) (text.size source-code)
+ [default-cursor 0 source-code]))
+ (#error.Failure error)
+ #0
+
+ (#error.Success [_ parsed])
+ (:: code.equivalence = parsed sample)))
+ (test "Can parse Lux multiple code nodes."
+ (let [source-code (format (%code sample) " " (%code other))
+ source-code//size (text.size source-code)]
+ (case (&.parse "" (dictionary.new text.hash) source-code//size
+ [default-cursor 0 source-code])
+ (#error.Failure error)
+ #0
+
+ (#error.Success [remaining =sample])
+ (case (&.parse "" (dictionary.new text.hash) source-code//size
+ remaining)
+ (#error.Failure error)
+ #0
+
+ (#error.Success [_ =other])
+ (and (:: code.equivalence = sample =sample)
+ (:: code.equivalence = other =other))))))
+ ))))
+
+(def: comment-text^
+ (r.Random Text)
+ (let [char-gen (|> r.nat (r.filter (|>> (n/= (`` (char (~~ (static text.new-line))))) not)))]
+ (do r.monad
+ [size (|> r.nat (r/map (n/% 20)))]
+ (r.text char-gen size))))
+
+(def: comment^
+ (r.Random Text)
+ (do r.monad
+ [comment comment-text^]
+ (wrap (format "## " comment text.new-line))))
+
+(context: "Multi-line text & comments."
+ (<| (seed 12137892244981970631)
+ ## (times 100)
+ (do @
+ [sample code^
+ comment comment^]
+ ($_ seq
+ (test "Can handle comments."
+ (case (let [source-code (format comment (%code sample))
+ source-code//size (text.size source-code)]
+ (&.parse "" (dictionary.new text.hash) source-code//size
+ [default-cursor 0 source-code]))
+ (#error.Failure error)
+ #0
+
+ (#error.Success [_ parsed])
+ (:: code.equivalence = parsed sample)))
+ ))))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
new file mode 100644
index 000000000..f50bdf7a7
--- /dev/null
+++ b/stdlib/source/test/lux/control.lux
@@ -0,0 +1,11 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]]
+ [/
+ ["/." exception]])
+
+(def: #export test
+ Test
+ ($_ _.and
+ (<| (_.context "/exception Exception-handling.")
+ /exception.test)))
diff --git a/stdlib/source/test/lux/control/apply.lux b/stdlib/source/test/lux/control/apply.lux
new file mode 100644
index 000000000..01fb33797
--- /dev/null
+++ b/stdlib/source/test/lux/control/apply.lux
@@ -0,0 +1,69 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ ["." function]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ Apply)]}
+ [//
+ [functor (#+ Injection Comparison)]])
+
+(def: (identity (^open "_/.") injection comparison)
+ (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample (:: @ map injection r.nat)]
+ (_.test "Identity."
+ ((comparison n/=)
+ (_/apply (injection function.identity) sample)
+ sample))))
+
+(def: (homomorphism (^open "_/.") injection comparison)
+ (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample r.nat
+ increase (:: @ map n/+ r.nat)]
+ (_.test "Homomorphism."
+ ((comparison n/=)
+ (_/apply (injection increase) (injection sample))
+ (injection (increase sample))))))
+
+(def: (interchange (^open "_/.") injection comparison)
+ (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample r.nat
+ increase (:: @ map n/+ r.nat)]
+ (_.test "Interchange."
+ ((comparison n/=)
+ (_/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))
+ (do r.monad
+ [sample r.nat
+ increase (:: @ map n/+ r.nat)
+ decrease (:: @ map n/- r.nat)]
+ (_.test "Composition."
+ ((comparison n/=)
+ (_$ _/apply
+ (injection function.compose)
+ (injection increase)
+ (injection decrease)
+ (injection sample))
+ ($_ _/apply
+ (injection increase)
+ (injection decrease)
+ (injection sample))))))
+
+(def: #export (laws apply injection comparison)
+ (All [f] (-> (Apply f) (Injection f) (Comparison f) Test))
+ (_.context "Apply laws."
+ ($_ _.and
+ (..identity apply injection comparison)
+ (..homomorphism apply injection comparison)
+ (..interchange apply injection comparison)
+ (..composition apply injection comparison)
+ )))
diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux
new file mode 100644
index 000000000..c035cabe2
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/actor.lux
@@ -0,0 +1,75 @@
+(.module:
+ [lux #*
+ ["." io (#+ IO io)]
+ [control
+ ["M" monad (#+ do Monad)]
+ ["ex" exception]
+ [concurrency
+ ["P" promise ("promise/." monad)]
+ ["T" task]
+ ["&" actor (#+ actor: message:)]]]
+ [data
+ ["." error]
+ [text
+ format]]]
+ lux/test)
+
+(actor: Counter
+ Nat
+
+ ((handle message state self)
+ (do t.monad
+ [#let [_ (log! "BEFORE")]
+ output (message state self)
+ #let [_ (log! "AFTER")]]
+ (wrap output)))
+
+ ((stop cause state)
+ (promise/wrap (log! (if (ex.match? &.poisoned cause)
+ (format "Counter was poisoned: " (%n state))
+ cause)))))
+
+(message: #export Counter
+ (count! {increment Nat} state self Nat)
+ (let [state' (n/+ increment state)]
+ (T.return [state' state'])))
+
+(context: "Actors"
+ ($_ seq
+ (test "Can check if an actor is alive."
+ (io.run (do io.monad
+ [counter (new@Counter 0)]
+ (wrap (&.alive? counter)))))
+
+ (test "Can poison actors."
+ (io.run (do io.monad
+ [counter (new@Counter 0)
+ poisoned? (&.poison counter)]
+ (wrap (and poisoned?
+ (not (&.alive? counter)))))))
+
+ (test "Cannot poison an already dead actor."
+ (io.run (do io.monad
+ [counter (new@Counter 0)
+ first-time (&.poison counter)
+ second-time (&.poison counter)]
+ (wrap (and first-time
+ (not second-time))))))
+
+ (wrap (do p.monad
+ [result (do t.monad
+ [#let [counter (io.run (new@Counter 0))]
+ output-1 (count! 1 counter)
+ output-2 (count! 1 counter)
+ output-3 (count! 1 counter)]
+ (wrap (and (n/= 1 output-1)
+ (n/= 2 output-2)
+ (n/= 3 output-3))))]
+ (assert "Can send messages to actors."
+ (case result
+ (#error.Success outcome)
+ outcome
+
+ (#error.Failure error)
+ #0))))
+ ))
diff --git a/stdlib/source/test/lux/control/concurrency/atom.lux b/stdlib/source/test/lux/control/concurrency/atom.lux
new file mode 100644
index 000000000..720547e27
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/atom.lux
@@ -0,0 +1,34 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ ["M" monad (#+ do Monad)]
+ [concurrency
+ ["&" atom]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Atoms"
+ (<| (times 100)
+ (do @
+ [value r.nat
+ swap-value r.nat
+ set-value r.nat
+ #let [box (&.atom value)]]
+ ($_ seq
+ (test "Can obtain the value of an atom."
+ (n/= value (io.run (&.read box))))
+
+ (test "Can swap the value of an atom."
+ (and (io.run (&.compare-and-swap value swap-value box))
+ (n/= swap-value (io.run (&.read box)))))
+
+ (test "Can update the value of an atom."
+ (exec (io.run (&.update inc box))
+ (n/= (inc swap-value) (io.run (&.read box)))))
+
+ (test "Can immediately set the value of an atom."
+ (exec (io.run (&.write set-value box))
+ (n/= set-value (io.run (&.read box)))))
+ ))))
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
new file mode 100644
index 000000000..cfe70ff0e
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -0,0 +1,53 @@
+(.module:
+ [lux #*
+ ["." io (#+ IO io)]
+ [control
+ ["." monad (#+ do Monad)]
+ [concurrency
+ ["." promise ("promise/." monad)]
+ ["." frp (#+ Channel)]
+ ["." atom (#+ Atom atom)]]]
+ [data
+ ["." number]
+ [collection
+ ["." list]]]]
+ lux/test)
+
+(context: "FRP"
+ (let [(^open "list/.") (list.equivalence number.equivalence)]
+ ($_ seq
+ (wrap (do promise.monad
+ [output (|> (list +0 +1 +2 +3 +4 +5)
+ (frp.sequential 0)
+ (frp.filter i/even?)
+ frp.consume)]
+ (assert "Can filter a channel's elements."
+ (list/= (list +0 +2 +4) output))))
+
+ (wrap (do promise.monad
+ [output (|> (list +0 +1 +2 +3 +4 +5)
+ (frp.sequential 0)
+ (:: frp.functor map inc)
+ frp.consume)]
+ (assert "Functor goes over every element in a channel."
+ (list/= (list +1 +2 +3 +4 +5 +6)
+ output))))
+
+ (wrap (do promise.monad
+ [output (frp.consume (:: frp.apply apply
+ (frp.sequential 0 (list inc))
+ (frp.sequential 0 (list +12345))))]
+ (assert "Apply works over all channel values."
+ (list/= (list +12346)
+ output))))
+
+ (wrap (do promise.monad
+ [output (frp.consume
+ (do frp.monad
+ [f (frp.from-promise (promise/wrap inc))
+ a (frp.from-promise (promise/wrap +12345))]
+ (wrap (f a))))]
+ (assert "Valid monad."
+ (list/= (list +12346)
+ output))))
+ )))
diff --git a/stdlib/source/test/lux/control/concurrency/promise.lux b/stdlib/source/test/lux/control/concurrency/promise.lux
new file mode 100644
index 000000000..e50320901
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/promise.lux
@@ -0,0 +1,68 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ ["M" monad (#+ Monad do)]
+ pipe
+ [concurrency
+ ["&" promise ("&/." monad)]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Promises"
+ ($_ seq
+ (wrap (do &.monad
+ [running? (&.future (io.io #1))]
+ (assert "Can run IO actions in separate threads."
+ running?)))
+
+ (wrap (do &.monad
+ [_ (&.wait 500)]
+ (assert "Can wait for a specified amount of time."
+ #1)))
+
+ (wrap (do &.monad
+ [[left right] (&.and (&.future (io.io #1))
+ (&.future (io.io #0)))]
+ (assert "Can combine promises sequentially."
+ (and left (not right)))))
+
+ (wrap (do &.monad
+ [?left (&.or (&.delay 100 #1)
+ (&.delay 200 #0))
+ ?right (&.or (&.delay 200 #1)
+ (&.delay 100 #0))]
+ (assert "Can combine promises alternatively."
+ (case [?left ?right]
+ [(#.Left #1) (#.Right #0)]
+ #1
+
+ _
+ #0))))
+
+ (wrap (do &.monad
+ [?left (&.either (&.delay 100 #1)
+ (&.delay 200 #0))
+ ?right (&.either (&.delay 200 #1)
+ (&.delay 100 #0))]
+ (assert "Can combine promises alternatively [Part 2]."
+ (and ?left (not ?right)))))
+
+ (test "Can poll a promise for its value."
+ (and (|> (&.poll (&/wrap #1))
+ (case> (#.Some #1) #1 _ #0))
+ (|> (&.poll (&.delay 200 #1))
+ (case> #.None #1 _ #0))))
+
+ (wrap (do &.monad
+ [?none (&.time-out 100 (&.delay 200 #1))
+ ?some (&.time-out 200 (&.delay 100 #1))]
+ (assert "Can establish maximum waiting times for promises to be fulfilled."
+ (case [?none ?some]
+ [#.None (#.Some #1)]
+ #1
+
+ _
+ #0))))
+ ))
diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux
new file mode 100644
index 000000000..0c4167ee7
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux
@@ -0,0 +1,143 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do)]
+ [concurrency
+ ["/" semaphore]
+ ["." promise (#+ Promise)]
+ ["." atom (#+ Atom)]]]
+ [data
+ ["." maybe]
+ ["." text ("text/." equivalence monoid)
+ format]
+ [collection
+ ["." list ("list/." functor)]]]
+ ["." io]
+ [math
+ ["r" random]]]
+ lux/test)
+
+## (def: (wait-many-times times semaphore)
+## (-> Nat /.Semaphore (Promise Any))
+## (loop [steps times]
+## (if (n/> 0 steps)
+## (do promise.monad
+## [_ (/.wait semaphore)]
+## (recur (dec steps)))
+## (:: promise.monad wrap []))))
+
+## (context: "Semaphore."
+## (<| (times 100)
+## (do @
+## [open-positions (|> r.nat (:: @ map (|>> (n/% 10) (n/max 1))))]
+## ($_ seq
+## (let [semaphore (/.semaphore open-positions)]
+## (wrap (do promise.monad
+## [_ (wait-many-times open-positions semaphore)]
+## (assert "Can wait on a semaphore up to the number of open positions without blocking."
+## true))))
+## (let [semaphore (/.semaphore open-positions)]
+## (wrap (do promise.monad
+## [result (<| (promise.time-out 100)
+## (wait-many-times (inc open-positions) semaphore))]
+## (assert "Waiting on a semaphore more than the number of open positions blocks the process."
+## (case result
+## (#.Some _)
+## false
+
+## #.None
+## true)))))
+## (let [semaphore (/.semaphore open-positions)]
+## (wrap (do promise.monad
+## [_ (: (Promise Any)
+## (loop [steps (n/* 2 open-positions)]
+## (if (n/> 0 steps)
+## (do @
+## [_ (/.wait semaphore)
+## _ (/.signal semaphore)]
+## (recur (dec steps)))
+## (wrap []))))]
+## (assert "Signaling a semaphore replenishes its open positions."
+## true))))
+## (let [semaphore (/.semaphore open-positions)]
+## (wrap (do promise.monad
+## [#let [resource (atom.atom "")
+## blocked (do @
+## [_ (wait-many-times open-positions semaphore)
+## _ (/.wait semaphore)
+## #let [_ (io.run (atom.update (|>> (format "B"))
+## resource))]]
+## (wrap []))]
+## _ (promise.wait 100)
+## _ (exec (io.run (atom.update (|>> (format "A"))
+## resource))
+## (/.signal semaphore))
+## _ blocked]
+## (assert "A blocked process can be un-blocked by a signal somewhere else."
+## (text/= "BA"
+## (io.run (atom.read resource)))))))
+## ))))
+
+## (context: "Mutex."
+## (<| (times 100)
+## (do @
+## [repetitions (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))]
+## ($_ seq
+## (let [mutex (/.mutex [])]
+## (wrap (do promise.monad
+## [#let [resource (atom.atom "")
+## expected-As (text.join-with "" (list.repeat repetitions "A"))
+## expected-Bs (text.join-with "" (list.repeat repetitions "B"))
+## processA (<| (/.synchronize mutex)
+## io.io
+## promise.future
+## (do io.monad
+## [_ (<| (monad.seq @)
+## (list.repeat repetitions)
+## (atom.update (|>> (format "A")) resource))]
+## (wrap [])))
+## processB (<| (/.synchronize mutex)
+## io.io
+## promise.future
+## (do io.monad
+## [_ (<| (monad.seq @)
+## (list.repeat repetitions)
+## (atom.update (|>> (format "B")) resource))]
+## (wrap [])))]
+## _ processA
+## _ processB
+## #let [outcome (io.run (atom.read resource))]]
+## (assert "Mutexes only allow one process to execute at a time."
+## (or (text/= (format expected-As expected-Bs)
+## outcome)
+## (text/= (format expected-Bs expected-As)
+## outcome))))))
+## ))))
+
+## (def: (waiter resource barrier id)
+## (-> (Atom Text) /.Barrier Nat (Promise Any))
+## (do promise.monad
+## [_ (/.block barrier)
+## #let [_ (io.run (atom.update (|>> (format (%n id))) resource))]]
+## (wrap [])))
+
+## (context: "Barrier."
+## (let [limit 10
+## barrier (/.barrier (maybe.assume (/.limit limit)))
+## resource (atom.atom "")]
+## ($_ seq
+## (wrap (do promise.monad
+## [#let [ids (list.n/range 0 (dec limit))
+## waiters (list/map (function (_ id)
+## (let [process (waiter resource barrier id)]
+## (exec (io.run (atom.update (|>> (format "_")) resource))
+## process)))
+## ids)]
+## _ (monad.seq @ waiters)
+## #let [outcome (io.run (atom.read resource))]]
+## (assert "A barrier can stop all processes from acting, until an amount of waiting processes is reached, and then the barrier is un-blocked for all."
+## (and (text.ends-with? "__________" outcome)
+## (list.every? (function (_ id)
+## (text.contains? (%n id) outcome))
+## ids)
+## )))))))
diff --git a/stdlib/source/test/lux/control/concurrency/stm.lux b/stdlib/source/test/lux/control/concurrency/stm.lux
new file mode 100644
index 000000000..966ab6007
--- /dev/null
+++ b/stdlib/source/test/lux/control/concurrency/stm.lux
@@ -0,0 +1,77 @@
+(.module:
+ [lux #*
+ ["." io (#+ IO)]
+ [control
+ ["M" monad (#+ do Monad)]
+ [concurrency
+ ["." atom (#+ Atom atom)]
+ ["&" stm]
+ ["." process]
+ ["." promise]
+ ["." frp (#+ Channel)]]]
+ [data
+ ["." number]
+ [collection
+ ["." list ("list/." functor)]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: (read! channel)
+ (All [a] (-> (Channel a) (IO (Atom (List a)))))
+ (do io.monad
+ [#let [output (atom (list))]
+ _ (frp.listen (function (_ value)
+ ## TODO: Simplify when possible.
+ (do @
+ [_ (atom.update (|>> (#.Cons value)) output)]
+ (wrap [])))
+ channel)]
+ (wrap output)))
+
+(def: iterations-per-process Nat 100)
+
+(context: "STM"
+ ($_ seq
+ (wrap (do promise.monad
+ [output (&.commit (&.read (&.var 0)))]
+ (assert "Can read STM vars."
+ (n/= 0 output))))
+ (wrap (do promise.monad
+ [#let [_var (&.var 0)]
+ output (&.commit (do &.monad
+ [_ (&.write 5 _var)]
+ (&.read _var)))]
+ (assert "Can write STM vars."
+ (n/= 5 output))))
+ (wrap (do promise.monad
+ [#let [_var (&.var 5)]
+ output (&.commit (do &.monad
+ [_ (&.update (n/* 3) _var)]
+ (&.read _var)))]
+ (assert "Can update STM vars."
+ (n/= 15 output))))
+ (wrap (do promise.monad
+ [#let [_var (&.var 0)
+ changes (io.run (read! (io.run (&.follow _var))))]
+ _ (&.commit (&.write 5 _var))
+ _ (&.commit (&.update (n/* 3) _var))
+ changes (promise.future (atom.read changes))]
+ (assert "Can follow all the changes to STM vars."
+ (:: (list.equivalence number.equivalence) =
+ (list 5 15)
+ (list.reverse changes)))))
+ (wrap (let [_concurrency-var (&.var 0)]
+ (do promise.monad
+ [_ (|> process.parallelism
+ (list.n/range 1)
+ (list/map (function (_ _)
+ (|> iterations-per-process
+ (list.n/range 1)
+ (M.map @ (function (_ _) (&.commit (&.update inc _concurrency-var)))))))
+ (M.seq @))
+ last-val (&.commit (&.read _concurrency-var))]
+ (assert "Can modify STM vars concurrently from multiple threads."
+ (|> process.parallelism
+ (n/* iterations-per-process)
+ (n/= last-val))))))))
diff --git a/stdlib/source/test/lux/control/continuation.lux b/stdlib/source/test/lux/control/continuation.lux
new file mode 100644
index 000000000..0dbbe7dc5
--- /dev/null
+++ b/stdlib/source/test/lux/control/continuation.lux
@@ -0,0 +1,77 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ do Monad)]
+ ["&" continuation]]
+ [data
+ ["." number]
+ [collection
+ ["." list]]]
+ ["r" math/random]]
+ lux/test)
+
+(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)))))
+
+ (test "Can use apply."
+ (n/= (inc sample) (&.run (&/apply (&/wrap inc) (&/wrap sample)))))
+
+ (test "Can use monad."
+ (n/= (inc sample) (&.run (do &.monad
+ [func (wrap inc)
+ arg (wrap sample)]
+ (wrap (func arg))))))
+
+ (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 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)
+
+ (#.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/source/test/lux/control/equivalence.lux b/stdlib/source/test/lux/control/equivalence.lux
new file mode 100644
index 000000000..daa2c81b3
--- /dev/null
+++ b/stdlib/source/test/lux/control/equivalence.lux
@@ -0,0 +1,21 @@
+(.module:
+ [lux #*
+ [control
+ ["/" equivalence]
+ [monad (#+ do)]]
+ [math
+ ["r" random]]
+ test])
+
+(def: #export (spec Equivalence<a> generator)
+ (All [a] (-> (/.Equivalence a) (r.Random a) Test))
+ (do r.monad
+ [sample generator
+ another generator]
+ ($_ seq
+ (test "Equivalence is reflexive."
+ (:: Equivalence<a> = sample sample))
+ (test "Equivalence is symmetric."
+ (if (:: Equivalence<a> = sample another)
+ (:: Equivalence<a> = another sample)
+ #1)))))
diff --git a/stdlib/source/test/lux/control/exception.lux b/stdlib/source/test/lux/control/exception.lux
new file mode 100644
index 000000000..434ffc5d0
--- /dev/null
+++ b/stdlib/source/test/lux/control/exception.lux
@@ -0,0 +1,35 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ 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))))))))
diff --git a/stdlib/source/test/lux/control/functor.lux b/stdlib/source/test/lux/control/functor.lux
new file mode 100644
index 000000000..a93edc291
--- /dev/null
+++ b/stdlib/source/test/lux/control/functor.lux
@@ -0,0 +1,56 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ ["." function]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ Functor)]})
+
+(type: #export (Injection f)
+ (All [a] (-> a (f a))))
+
+(type: #export (Comparison f)
+ (All [a]
+ (-> (-> a a Bit)
+ (-> (f a) (f a) Bit))))
+
+(def: (identity (^open "_/.") injection comparison)
+ (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample (:: @ map injection r.nat)]
+ (_.test "Identity."
+ ((comparison n/=)
+ (_/map function.identity sample)
+ sample))))
+
+(def: (homomorphism (^open "_/.") injection comparison)
+ (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample r.nat
+ increase (:: @ map n/+ r.nat)]
+ (_.test "Homomorphism."
+ ((comparison n/=)
+ (_/map increase (injection sample))
+ (injection (increase sample))))))
+
+(def: (composition (^open "_/.") injection comparison)
+ (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample (:: @ map injection r.nat)
+ increase (:: @ map n/+ r.nat)
+ decrease (:: @ map n/- r.nat)]
+ (_.test "Composition."
+ ((comparison n/=)
+ (|> sample (_/map increase) (_/map decrease))
+ (|> sample (_/map (|>> increase decrease)))))))
+
+(def: #export (laws functor injection comparison)
+ (All [f] (-> (Functor f) (Injection f) (Comparison f) Test))
+ (_.context "Functor laws."
+ ($_ _.and
+ (..identity functor injection comparison)
+ (..homomorphism functor injection comparison)
+ (..composition functor injection comparison))))
diff --git a/stdlib/source/test/lux/control/interval.lux b/stdlib/source/test/lux/control/interval.lux
new file mode 100644
index 000000000..6d00a36e9
--- /dev/null
+++ b/stdlib/source/test/lux/control/interval.lux
@@ -0,0 +1,235 @@
+(.module:
+ lux/test
+ [lux #*
+ [control
+ ["M" monad (#+ do Monad)]
+ pipe
+ ["&" interval]]
+ [math
+ ["r" random]]
+ [data
+ ["." number]
+ [collection
+ ["S" set]
+ ["L" list]]]])
+
+(context: "Equivalence."
+ (<| (times 100)
+ (do @
+ [bottom r.int
+ top r.int
+ #let [(^open "&/.") &.equivalence]]
+ ($_ seq
+ (test "Every interval is equal to itself."
+ (and (let [self (&.between number.enum bottom top)]
+ (&/= self self))
+ (let [self (&.between number.enum top bottom)]
+ (&/= self self))
+ (let [self (&.singleton number.enum bottom)]
+ (&/= self self))))))))
+
+(context: "Boundaries"
+ (<| (times 100)
+ (do @
+ [bottom r.int
+ top r.int
+ #let [interval (&.between number.enum bottom top)]]
+ ($_ seq
+ (test "Every boundary value belongs to it's interval."
+ (and (&.within? interval bottom)
+ (&.within? interval top)))
+ (test "Every interval starts with its bottom."
+ (&.starts-with? bottom interval))
+ (test "Every interval ends with its top."
+ (&.ends-with? top interval))
+ (test "The boundary values border the interval."
+ (and (&.borders? interval bottom)
+ (&.borders? interval top)))
+ ))))
+
+(def: (list-to-4tuple list)
+ (-> (List Int) [Int Int Int Int])
+ (case list
+ (^ (list x0 x1 x2 x3))
+ [x0 x1 x2 x3]
+
+ _
+ (undefined)))
+
+
+(do-template [<name> <cmp>]
+ [(def: <name>
+ (r.Random (&.Interval Int))
+ (do r.monad
+ [bottom r.int
+ top (|> r.int (r.filter (|>> (i/= bottom) not)))]
+ (if (<cmp> top bottom)
+ (wrap (&.between number.enum bottom top))
+ (wrap (&.between number.enum top bottom)))))]
+
+ [gen-inner i/<]
+ [gen-outer i/>]
+ )
+
+(def: gen-singleton
+ (r.Random (&.Interval Int))
+ (do r.monad
+ [point r.int]
+ (wrap (&.singleton number.enum point))))
+
+(def: gen-interval
+ (r.Random (&.Interval Int))
+ ($_ r.either
+ gen-inner
+ gen-outer
+ gen-singleton))
+
+(context: "Unions"
+ (<| (times 100)
+ (do @
+ [some-interval gen-interval
+ left-inner gen-inner
+ right-inner gen-inner
+ left-singleton gen-singleton
+ right-singleton gen-singleton
+ left-outer gen-outer
+ right-outer gen-outer
+ #let [(^open "&/.") &.equivalence]]
+ ($_ seq
+ (test "The union of an interval to itself yields the same interval."
+ (&/= some-interval (&.union some-interval some-interval)))
+ (test "The union of 2 inner intervals is another inner interval."
+ (&.inner? (&.union left-inner right-inner)))
+ (test "The union of 2 outer intervals yields an inner interval when their complements don't overlap, and an outer when they do."
+ (if (&.overlaps? (&.complement left-outer) (&.complement right-outer))
+ (&.outer? (&.union left-outer right-outer))
+ (&.inner? (&.union left-outer right-outer))))
+ ))))
+
+(context: "Intersections"
+ (<| (times 100)
+ (do @
+ [some-interval gen-interval
+ left-inner gen-inner
+ right-inner gen-inner
+ left-singleton gen-singleton
+ right-singleton gen-singleton
+ left-outer gen-outer
+ right-outer gen-outer
+ #let [(^open "&/.") &.equivalence]]
+ ($_ seq
+ (test "The intersection of an interval to itself yields the same interval."
+ (&/= some-interval (&.intersection some-interval some-interval)))
+ (test "The intersection of 2 inner intervals yields an inner interval when they overlap, and an outer when they don't."
+ (if (&.overlaps? left-inner right-inner)
+ (&.inner? (&.intersection left-inner right-inner))
+ (&.outer? (&.intersection left-inner right-inner))))
+ (test "The intersection of 2 outer intervals is another outer interval."
+ (&.outer? (&.intersection left-outer right-outer)))
+ ))))
+
+(context: "Complement"
+ (<| (times 100)
+ (do @
+ [some-interval gen-interval
+ #let [(^open "&/.") &.equivalence]]
+ ($_ seq
+ (test "The complement of a complement is the same as the original."
+ (&/= some-interval (|> some-interval &.complement &.complement)))
+ (test "The complement of an interval does not overlap it."
+ (not (&.overlaps? some-interval (&.complement some-interval))))
+ ))))
+
+(context: "Positioning/location"
+ (<| (times 100)
+ (do @
+ [[l m r] (|> (r.set number.hash 3 r.int)
+ (:: @ map (|>> S.to-list
+ (L.sort i/<)
+ (case> (^ (list b t1 t2))
+ [b t1 t2]
+
+ _
+ (undefined)))))
+ #let [left (&.singleton number.enum l)
+ right (&.singleton number.enum r)]]
+ ($_ seq
+ (test "'precedes?' and 'succeeds?' are symetric."
+ (and (&.precedes? right left)
+ (&.succeeds? left right)))
+ (test "Can check if an interval is before or after some element."
+ (and (&.before? m left)
+ (&.after? m right)))
+ ))))
+
+(context: "Touching intervals"
+ (<| (times 100)
+ (do @
+ [[b t1 t2] (|> (r.set number.hash 3 r.int)
+ (:: @ map (|>> S.to-list
+ (L.sort i/<)
+ (case> (^ (list b t1 t2))
+ [b t1 t2]
+
+ _
+ (undefined)))))
+ #let [int-left (&.between number.enum t1 t2)
+ int-right (&.between number.enum b t1)]]
+ ($_ seq
+ (test "An interval meets another if it's top is the other's bottom."
+ (&.meets? int-left int-right))
+ (test "Two intervals touch one another if any one meets the other."
+ (&.touches? int-left int-right))
+ (test "Can check if 2 intervals start together."
+ (&.starts? (&.between number.enum b t2)
+ (&.between number.enum b t1)))
+ (test "Can check if 2 intervals finish together."
+ (&.finishes? (&.between number.enum b t2)
+ (&.between number.enum t1 t2)))
+ ))))
+
+(context: "Nesting & overlap"
+ (<| (times 100)
+ (do @
+ [some-interval gen-interval
+ [x0 x1 x2 x3] (|> (r.set number.hash 4 r.int)
+ (:: @ map (|>> S.to-list
+ (L.sort i/<)
+ (case> (^ (list x0 x1 x2 x3))
+ [x0 x1 x2 x3]
+
+ _
+ (undefined)))))]
+ ($_ seq
+ (test "Every interval is nested into itself."
+ (&.nested? some-interval some-interval))
+ (test "No interval overlaps with itself."
+ (not (&.overlaps? some-interval some-interval)))
+ (let [small-inner (&.between number.enum x1 x2)
+ large-inner (&.between number.enum x0 x3)]
+ (test "Inner intervals can be nested inside one another."
+ (and (&.nested? large-inner small-inner)
+ (not (&.nested? small-inner large-inner)))))
+ (let [left-inner (&.between number.enum x0 x2)
+ right-inner (&.between number.enum x1 x3)]
+ (test "Inner intervals can overlap one another."
+ (and (&.overlaps? left-inner right-inner)
+ (&.overlaps? right-inner left-inner))))
+ (let [small-outer (&.between number.enum x2 x1)
+ large-outer (&.between number.enum x3 x0)]
+ (test "Outer intervals can be nested inside one another."
+ (and (&.nested? small-outer large-outer)
+ (not (&.nested? large-outer small-outer)))))
+ (let [left-inner (&.between number.enum x0 x1)
+ right-inner (&.between number.enum x2 x3)
+ outer (&.between number.enum x0 x3)]
+ (test "Inners can be nested inside outers."
+ (and (&.nested? outer left-inner)
+ (&.nested? outer right-inner))))
+ (let [left-inner (&.between number.enum x0 x2)
+ right-inner (&.between number.enum x1 x3)
+ outer (&.between number.enum x1 x2)]
+ (test "Inners can overlap outers."
+ (and (&.overlaps? outer left-inner)
+ (&.overlaps? outer right-inner))))
+ ))))
diff --git a/stdlib/source/test/lux/control/monad.lux b/stdlib/source/test/lux/control/monad.lux
new file mode 100644
index 000000000..412f3ab94
--- /dev/null
+++ b/stdlib/source/test/lux/control/monad.lux
@@ -0,0 +1,54 @@
+(.module:
+ [lux #*
+ ["." function]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ Monad do)]}
+ [//
+ [functor (#+ Injection Comparison)]])
+
+(def: (left-identity (^open "_/.") injection comparison)
+ (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample r.nat
+ morphism (:: @ map (function (_ diff)
+ (|>> (n/+ diff) _/wrap))
+ r.nat)]
+ (_.test "Left identity."
+ ((comparison n/=)
+ (|> (injection sample) (_/map morphism) _/join)
+ (morphism sample)))))
+
+(def: (right-identity (^open "_/.") injection comparison)
+ (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample r.nat]
+ (_.test "Right identity."
+ ((comparison n/=)
+ (|> (injection sample) (_/map _/wrap) _/join)
+ (injection sample)))))
+
+(def: (associativity (^open "_/.") injection comparison)
+ (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
+ (do r.monad
+ [sample r.nat
+ increase (:: @ map (function (_ diff)
+ (|>> (n/+ diff) _/wrap))
+ r.nat)
+ decrease (:: @ map (function (_ diff)
+ (|>> (n/- diff) _/wrap))
+ r.nat)]
+ (_.test "Associativity."
+ ((comparison n/=)
+ (|> (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))
+ (_.context "Monad laws."
+ ($_ _.and
+ (..left-identity monad injection comparison)
+ (..right-identity monad injection comparison)
+ (..associativity monad injection comparison))))
diff --git a/stdlib/source/test/lux/control/parser.lux b/stdlib/source/test/lux/control/parser.lux
new file mode 100644
index 000000000..c9d568495
--- /dev/null
+++ b/stdlib/source/test/lux/control/parser.lux
@@ -0,0 +1,177 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ ["&" parser]]
+ [data
+ ["." error (#+ Error)]]
+ [math
+ ["r" random]]
+ ["." macro
+ ["." code]
+ ["s" syntax (#+ syntax:)]]]
+ lux/test)
+
+## [Utils]
+(def: (should-fail input)
+ (All [a] (-> (Error a) Bit))
+ (case input
+ (#error.Failure _)
+ #1
+
+ _
+ #0))
+
+(def: (enforced? parser input)
+ (All [s] (-> (&.Parser s Any) s Bit))
+ (case (&.run input parser)
+ (#error.Success [_ []])
+ #1
+
+ _
+ #0))
+
+(def: (found? parser input)
+ (All [s] (-> (&.Parser s Bit) s Bit))
+ (case (&.run input parser)
+ (#error.Success [_ #1])
+ #1
+
+ _
+ #0))
+
+(def: (fails? input)
+ (All [a] (-> (Error a) Bit))
+ (case input
+ (#error.Failure _)
+ #1
+
+ _
+ #0))
+
+(syntax: (match pattern input)
+ (wrap (list (` (case (~ input)
+ (^ (#error.Success [(~' _) (~ pattern)]))
+ #1
+
+ (~' _)
+ #0)))))
+
+## [Tests]
+(context: "Assertions"
+ (test "Can make assertions while parsing."
+ (and (match []
+ (&.run (list (code.bit #1) (code.int +123))
+ (&.assert "yolo" #1)))
+ (fails? (&.run (list (code.bit #1) (code.int +123))
+ (&.assert "yolo" #0))))))
+
+(context: "Combinators [Part 1]"
+ ($_ seq
+ (test "Can optionally succeed with some parser."
+ (and (match (#.Some 123)
+ (&.run (list (code.nat 123))
+ (&.maybe s.nat)))
+ (match #.None
+ (&.run (list (code.int -123))
+ (&.maybe s.nat)))))
+
+ (test "Can apply a parser 0 or more times."
+ (and (match (list 123 456 789)
+ (&.run (list (code.nat 123) (code.nat 456) (code.nat 789))
+ (&.some s.nat)))
+ (match (list)
+ (&.run (list (code.int -123))
+ (&.some s.nat)))))
+
+ (test "Can apply a parser 1 or more times."
+ (and (match (list 123 456 789)
+ (&.run (list (code.nat 123) (code.nat 456) (code.nat 789))
+ (&.many s.nat)))
+ (match (list 123)
+ (&.run (list (code.nat 123))
+ (&.many s.nat)))
+ (fails? (&.run (list (code.int -123))
+ (&.many s.nat)))))
+
+ (test "Can use either parser."
+ (let [positive (: (s.Syntax Int)
+ (do &.monad
+ [value s.int
+ _ (&.assert "" (i/> +0 value))]
+ (wrap value)))]
+ (and (match +123
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.either positive s.int)))
+ (match -123
+ (&.run (list (code.int -123) (code.int +456) (code.int +789))
+ (&.either positive s.int)))
+ (fails? (&.run (list (code.bit #1) (code.int +456) (code.int +789))
+ (&.either positive s.int))))))
+
+ (test "Can create the opposite/negation of any parser."
+ (and (fails? (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.not s.int)))
+ (match []
+ (&.run (list (code.bit #1) (code.int +456) (code.int +789))
+ (&.not s.int)))))
+ ))
+
+(context: "Combinators Part [2]"
+ ($_ seq
+ (test "Can fail at will."
+ (should-fail (&.run (list)
+ (&.fail "Well, it really SHOULD fail..."))))
+
+ (test "Can apply a parser N times."
+ (and (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.exactly 3 s.int)))
+ (match (list +123 +456)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.exactly 2 s.int)))
+ (fails? (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.exactly 4 s.int)))))
+
+ (test "Can apply a parser at-least N times."
+ (and (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.at-least 3 s.int)))
+ (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.at-least 2 s.int)))
+ (fails? (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.at-least 4 s.int)))))
+
+ (test "Can apply a parser at-most N times."
+ (and (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.at-most 3 s.int)))
+ (match (list +123 +456)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.at-most 2 s.int)))
+ (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.at-most 4 s.int)))))
+
+ (test "Can apply a parser between N and M times."
+ (and (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.between 3 10 s.int)))
+ (fails? (&.run (list (code.int +123) (code.int +456) (code.int +789))
+ (&.between 4 10 s.int)))))
+
+ (test "Can parse while taking separators into account."
+ (and (match (list +123 +456 +789)
+ (&.run (list (code.int +123) (code.text "YOLO") (code.int +456) (code.text "YOLO") (code.int +789))
+ (&.sep-by (s.this (' "YOLO")) s.int)))
+ (match (list +123 +456)
+ (&.run (list (code.int +123) (code.text "YOLO") (code.int +456) (code.int +789))
+ (&.sep-by (s.this (' "YOLO")) s.int)))))
+
+ (test "Can obtain the whole of the remaining input."
+ (|> &.remaining
+ (&.run (list (code.int +123) (code.int +456) (code.int +789)))
+ (match (list [_ (#.Int +123)] [_ (#.Int +456)] [_ (#.Int +789)]))))
+ ))
diff --git a/stdlib/source/test/lux/control/pipe.lux b/stdlib/source/test/lux/control/pipe.lux
new file mode 100644
index 000000000..aaaa18616
--- /dev/null
+++ b/stdlib/source/test/lux/control/pipe.lux
@@ -0,0 +1,72 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]
+ pipe]
+ [data
+ ["." identity]
+ [text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Pipes"
+ ($_ seq
+ (test "Can dismiss previous pipeline results and begin a new line."
+ (|> +20
+ (i/* +3)
+ (i/+ +4)
+ (new> +0 inc)
+ (i/= +1)))
+
+ (test "Can give names to piped values within a pipeline's scope."
+ (|> +5
+ (let> X [(i/+ X X)])
+ (i/= +10)))
+
+ (test "Can do branching in pipelines."
+ (and (|> +5
+ (cond> [i/even?] [(i/* +2)]
+ [i/odd?] [(i/* +3)]
+ [(new> -1)])
+ (i/= +15))
+ (|> +4
+ (cond> [i/even?] [(i/* +2)]
+ [i/odd?] [(i/* +3)]
+ [])
+ (i/= +8))
+ (|> +5
+ (cond> [i/even?] [(i/* +2)]
+ [(new> -1)])
+ (i/= -1))))
+
+ (test "Can loop within pipelines."
+ (|> +1
+ (loop> [(i/< +10)]
+ [inc])
+ (i/= +10)))
+
+ (test "Can use monads within pipelines."
+ (|> +5
+ (do> identity.monad
+ [(i/* +3)]
+ [(i/+ +4)]
+ [inc])
+ (i/= +20)))
+
+ (test "Can pattern-match against piped values."
+ (|> +5
+ (case> +0 "zero"
+ +1 "one"
+ +2 "two"
+ +3 "three"
+ +4 "four"
+ +5 "five"
+ +6 "six"
+ +7 "seven"
+ +8 "eight"
+ +9 "nine"
+ _ "???")
+ (text/= "five")))
+ ))
diff --git a/stdlib/source/test/lux/control/reader.lux b/stdlib/source/test/lux/control/reader.lux
new file mode 100644
index 000000000..638e11519
--- /dev/null
+++ b/stdlib/source/test/lux/control/reader.lux
@@ -0,0 +1,37 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ [monad (#+ do)]
+ pipe
+ ["&" reader]]]
+ lux/test)
+
+(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)))))))))
+
+(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)))
+ ))
diff --git a/stdlib/source/test/lux/control/region.lux b/stdlib/source/test/lux/control/region.lux
new file mode 100644
index 000000000..ff6bdaeaf
--- /dev/null
+++ b/stdlib/source/test/lux/control/region.lux
@@ -0,0 +1,106 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do)]
+ ["/" region]
+ ["." thread (#+ Thread)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." error (#+ Error)]
+ [collection
+ ["." list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(exception: oops)
+
+(do-template [<name> <success> <error>]
+ [(def: (<name> result)
+ (All [a] (-> (Error a) Bit))
+ (case result
+ (#error.Success _)
+ <success>
+
+ (#error.Failure _)
+ <error>))]
+
+ [success? #1 #0]
+ [error? #0 #1]
+ )
+
+(context: "Regions."
+ (<| (times 100)
+ (do @
+ [expected-clean-ups (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))]
+ ($_ seq
+ (test "Clean-up functions are always run when region execution is done."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (#error.Success []))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (success? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (test "Can clean-up despite errors."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (#error.Success []))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))
+ _ (/.throw @@ oops [])]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (error? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (test "Errors can propagate from the cleaners."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @
+ count-clean-up (function (_ value)
+ (do @
+ [_ (thread.update inc clean-up-counter)]
+ (wrap (: (Error Any) (ex.throw oops [])))))]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (monad.map @ (/.acquire @@ count-clean-up)
+ (list.n/range 1 expected-clean-ups))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (or (n/= 0 expected-clean-ups)
+ (error? outcome))
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ (test "Can lift operations."
+ (thread.run
+ (do thread.monad
+ [clean-up-counter (thread.box 0)
+ #let [@@ @]
+ outcome (/.run @
+ (do (/.monad @)
+ [_ (/.lift @@ (thread.write expected-clean-ups clean-up-counter))]
+ (wrap [])))
+ actual-clean-ups (thread.read clean-up-counter)]
+ (wrap (and (success? outcome)
+ (n/= expected-clean-ups
+ actual-clean-ups))))))
+ ))))
diff --git a/stdlib/source/test/lux/control/security/integrity.lux b/stdlib/source/test/lux/control/security/integrity.lux
new file mode 100644
index 000000000..f306cf7e5
--- /dev/null
+++ b/stdlib/source/test/lux/control/security/integrity.lux
@@ -0,0 +1,54 @@
+(.module:
+ [lux #*
+ [control
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ [security
+ ["@" integrity]]]
+ [data
+ ["." error]
+ ["." text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Taint."
+ (do @
+ [raw (r.ascii 10)
+ #let [dirty (@.taint raw)]]
+ ($_ seq
+ (test "Can clean a tainted value by trusting it."
+ (text/= raw (@.trust dirty)))
+ (test "Can validate a tainted value."
+ (case (@.validate (function (_ value)
+ (if (|> value text.size (n/> 0))
+ (#error.Success value)
+ (#error.Failure "Empty text is invalid.")))
+ dirty)
+ (#error.Success clean)
+ (text/= raw clean)
+
+ (#error.Failure error)
+ false))
+ )))
+
+(context: "Structures."
+ (do @
+ [#let [duplicate (: (-> Text Text)
+ (function (_ raw) (format raw raw)))]
+ raw (r.ascii 10)
+ #let [check (|>> @.trust (text/= (duplicate raw)))
+ (^open "@/.") @.functor
+ (^open "@/.") @.apply
+ (^open "@/.") @.monad]]
+ ($_ seq
+ (test "Can use Functor."
+ (check (@/map duplicate (@.taint raw))))
+ (test "Can use Apply."
+ (check (@/apply (@/wrap duplicate) (@.taint raw))))
+ (test "Can use Monad."
+ (check (do @.monad
+ [dirty (@.taint raw)]
+ (wrap (duplicate dirty)))))
+ )))
diff --git a/stdlib/source/test/lux/control/security/privacy.lux b/stdlib/source/test/lux/control/security/privacy.lux
new file mode 100644
index 000000000..72c23e4c1
--- /dev/null
+++ b/stdlib/source/test/lux/control/security/privacy.lux
@@ -0,0 +1,85 @@
+(.module:
+ [lux #*
+ [control
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ [security
+ ["@" privacy (#+ Context Privilege Private with-privacy)]]]
+ [data
+ ["." text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(type: Password (Private Text))
+
+(signature: (Policy %)
+ (: (Hash (Password %))
+ &hash)
+
+ (: (-> Text (Password %))
+ password)
+
+ (: (Privilege %)
+ privilege))
+
+(def: (policy _)
+ (Ex [%] (-> Any (Policy %)))
+ (with-privacy
+ (: (Context Policy)
+ (function (_ (^@ privilege (^open "%/.")))
+ (structure
+ (def: &hash
+ (structure
+ (def: eq
+ (structure (def: (= reference sample)
+ (text/= (%/reveal reference)
+ (%/reveal sample)))))
+ (def: hash
+ (|>> %/reveal
+ (:: text.hash hash)))))
+
+ (def: password
+ %/conceal)
+
+ (def: privilege privilege))))))
+
+(context: "Policy labels."
+ (do @
+ [#let [policy-0 (policy 0)]
+ raw-password (r.ascii 10)
+ #let [password (:: policy-0 password raw-password)]]
+ ($_ seq
+ (test "Can work with private values under the same label."
+ (and (:: policy-0 = password password)
+ (n/= (:: text.hash hash raw-password)
+ (:: policy-0 hash password))))
+ (let [policy-1 (policy 1)
+ delegate (@.delegation (:: policy-0 reveal) (:: policy-1 conceal))]
+ (test "Can use delegation to share private values between policies."
+ (:: policy-1 = (delegate password) (delegate password))))
+ )))
+
+(context: "Structures."
+ (do @
+ [#let [duplicate (: (-> Text Text)
+ (function (_ raw) (format raw raw)))
+ policy-0 (policy 0)]
+ raw-password (r.ascii 10)
+ #let [password (:: policy-0 password raw-password)]
+ #let [check (:: policy-0 =
+ (:: policy-0 password (duplicate raw-password)))
+ (^open "@/.") @.functor
+ (^open "@/.") @.apply
+ (^open "@/.") @.monad]]
+ ($_ seq
+ (test "Can use Functor."
+ (check (@/map duplicate password)))
+ (test "Can use Apply."
+ (check (@/apply (@/wrap duplicate) password)))
+ (test "Can use Monad."
+ (check (do @.monad
+ [raw-password' (:: policy-0 password raw-password)]
+ (wrap (duplicate raw-password')))))
+ )))
diff --git a/stdlib/source/test/lux/control/state.lux b/stdlib/source/test/lux/control/state.lux
new file mode 100644
index 000000000..948cbd5bf
--- /dev/null
+++ b/stdlib/source/test/lux/control/state.lux
@@ -0,0 +1,117 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ ["M" monad (#+ do Monad)]
+ pipe
+ ["&" state]]
+ [data
+ ["." product]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: (with-conditions [state output] computation)
+ (-> [Nat Nat] (&.State Nat Nat) Bit)
+ (|> computation
+ (&.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)))
+ ))))
+
+(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))))))
+ ))))
+
+(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')))))
+ ))))
+
+(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'))))))
+ ))))
diff --git a/stdlib/source/test/lux/control/thread.lux b/stdlib/source/test/lux/control/thread.lux
new file mode 100644
index 000000000..8f31addbb
--- /dev/null
+++ b/stdlib/source/test/lux/control/thread.lux
@@ -0,0 +1,21 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ ["/" thread]]])
+
+(def: _test0_
+ Nat
+ (/.run (do /.monad
+ [box (/.box 123)
+ old (/.update (n/* 2) box)
+ new (/.read box)]
+ (wrap (n/+ old new)))))
+
+(def: _test1_
+ (All [!] (/.Thread ! Nat))
+ (do /.monad
+ [box (/.box 123)
+ old (/.update (n/* 2) box)
+ new (/.read box)]
+ (wrap (n/+ old new))))
diff --git a/stdlib/source/test/lux/control/writer.lux b/stdlib/source/test/lux/control/writer.lux
new file mode 100644
index 000000000..b5fb372d8
--- /dev/null
+++ b/stdlib/source/test/lux/control/writer.lux
@@ -0,0 +1,45 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ ["M" monad (#+ Monad do)]
+ pipe
+ ["&" writer]]
+ [data
+ ["." product]
+ ["." text ("text/." equivalence)]]]
+ lux/test)
+
+(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"))))
+ )))
+
+(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)))
+ ))
diff --git a/stdlib/source/test/lux/data/bit.lux b/stdlib/source/test/lux/data/bit.lux
new file mode 100644
index 000000000..d064a736b
--- /dev/null
+++ b/stdlib/source/test/lux/data/bit.lux
@@ -0,0 +1,37 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ Monad do)]]
+ [data
+ bit]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Bit operations."
+ (<| (times 100)
+ (do @
+ [value r.bit]
+ (test "" (and (not (and value (not value)))
+ (or value (not value))
+
+ (not (:: disjunction identity))
+ (:: disjunction compose value (not value))
+ (:: conjunction identity)
+ (not (:: conjunction compose value (not value)))
+
+ (:: equivalence = value (not (not value)))
+ (not (:: equivalence = value (not value)))
+
+ (not (:: equivalence = value ((complement id) value)))
+ (:: equivalence = value ((complement not) value))
+
+ (case (|> value
+ (:: codec encode)
+ (:: codec decode))
+ (#.Right dec-value)
+ (:: equivalence = value dec-value)
+
+ (#.Left _)
+ #0)
+ )))))
diff --git a/stdlib/source/test/lux/data/collection/array.lux b/stdlib/source/test/lux/data/collection/array.lux
new file mode 100644
index 000000000..47c384cb7
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/array.lux
@@ -0,0 +1,143 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["." number]
+ ["." maybe]
+ [collection
+ ["@" array (#+ Array)]
+ ["." list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: bounded-size
+ (r.Random Nat)
+ (|> r.nat
+ (:: r.monad map (|>> (n/% 100) (n/+ 1)))))
+
+(context: "Arrays and their copies"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ original (r.array size r.nat)
+ #let [clone (@.clone original)
+ copy (: (Array Nat)
+ (@.new size))
+ manual-copy (: (Array Nat)
+ (@.new size))]]
+ ($_ seq
+ (test "Size function must correctly return size of array."
+ (n/= size (@.size original)))
+ (test "Cloning an array should yield and identical array, but not the same one."
+ (and (:: (@.equivalence number.equivalence) = original clone)
+ (not (is? original clone))))
+ (test "Full-range manual copies should give the same result as cloning."
+ (exec (@.copy size 0 original 0 copy)
+ (and (:: (@.equivalence number.equivalence) = original copy)
+ (not (is? original copy)))))
+ (test "Array folding should go over all values."
+ (exec (:: @.fold fold
+ (function (_ x idx)
+ (exec (@.write idx x manual-copy)
+ (inc idx)))
+ 0
+ original)
+ (:: (@.equivalence number.equivalence) = original manual-copy)))
+ (test "Transformations between (full) arrays and lists shouldn't cause lose or change any values."
+ (|> original
+ @.to-list @.from-list
+ (:: (@.equivalence number.equivalence) = original)))
+ ))))
+
+(context: "Array mutation"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ idx (:: @ map (n/% size) r.nat)
+ array (|> (r.array size r.nat)
+ (r.filter (|>> @.to-list (list.any? n/odd?))))
+ #let [value (maybe.assume (@.read idx array))]]
+ ($_ seq
+ (test "Shouldn't be able to find a value in an unoccupied cell."
+ (case (@.read idx (@.delete idx array))
+ (#.Some _) #0
+ #.None #1))
+ (test "You should be able to access values put into the array."
+ (case (@.read idx (@.write idx value array))
+ (#.Some value') (n/= value' value)
+ #.None #0))
+ (test "All cells should be occupied on a full array."
+ (and (n/= size (@.occupied array))
+ (n/= 0 (@.vacant array))))
+ (test "Filtering mutates the array to remove invalid values."
+ (exec (@.filter! n/even? array)
+ (and (n/< size (@.occupied array))
+ (n/> 0 (@.vacant array))
+ (n/= size (n/+ (@.occupied array)
+ (@.vacant array))))))
+ ))))
+
+(context: "Finding values."
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ array (|> (r.array size r.nat)
+ (r.filter (|>> @.to-list (list.any? n/even?))))]
+ ($_ seq
+ (test "Can find values inside arrays."
+ (|> (@.find n/even? array)
+ (case> (#.Some _) #1
+ #.None #0)))
+ (test "Can find values inside arrays (with access to indices)."
+ (|> (@.find+ (function (_ idx n)
+ (and (n/even? n)
+ (n/< size idx)))
+ array)
+ (case> (#.Some _) #1
+ #.None #0)))))))
+
+(context: "Functor"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ array (r.array size r.nat)]
+ (let [(^open ".") @.functor
+ (^open ".") (@.equivalence number.equivalence)]
+ ($_ seq
+ (test "Functor shouldn't alter original array."
+ (let [copy (map id array)]
+ (and (= array copy)
+ (not (is? array copy)))))
+ (test "Functor should go over all available array elements."
+ (let [there (map inc array)
+ back-again (map dec there)]
+ (and (not (= array there))
+ (= array back-again)))))))))
+
+(context: "Monoid"
+ (<| (times 100)
+ (do @
+ [sizeL bounded-size
+ sizeR bounded-size
+ left (r.array sizeL r.nat)
+ right (r.array sizeR r.nat)
+ #let [(^open ".") @.monoid
+ (^open ".") (@.equivalence number.equivalence)
+ fusion (compose left right)]]
+ ($_ seq
+ (test "Appending two arrays should produce a new one twice as large."
+ (n/= (n/+ sizeL sizeR) (@.size fusion)))
+ (test "First elements of fused array should equal the first array."
+ (|> (: (Array Nat)
+ (@.new sizeL))
+ (@.copy sizeL 0 fusion 0)
+ (= left)))
+ (test "Last elements of fused array should equal the second array."
+ (|> (: (Array Nat)
+ (@.new sizeR))
+ (@.copy sizeR sizeL fusion 0)
+ (= right)))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/bits.lux b/stdlib/source/test/lux/data/collection/bits.lux
new file mode 100644
index 000000000..aeeac1429
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/bits.lux
@@ -0,0 +1,87 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ ["." predicate]]
+ [data
+ [collection
+ ["/" bits]]]
+ [math
+ ["r" random]]]
+ lux/test
+ [test
+ [lux
+ [control
+ ["_eq" equivalence]]]])
+
+(def: (size min max)
+ (-> Nat Nat (r.Random Nat))
+ (|> r.nat
+ (:: r.monad map (|>> (n/% max) (n/max min)))))
+
+(def: bits
+ (r.Random /.Bits)
+ (do r.monad
+ [size (size 1 1_000)
+ idx (|> r.nat (:: @ map (n/% size)))]
+ (wrap (|> /.empty (/.set idx)))))
+
+(context: "Bits."
+ (<| (times 100)
+ (do @
+ [size (size 1 1_000)
+ idx (|> r.nat (:: @ map (n/% size)))
+ sample bits]
+ ($_ seq
+ (test "Can set individual bits."
+ (and (|> /.empty (/.get idx) not)
+ (|> /.empty (/.set idx) (/.get idx))))
+ (test "Can clear individual bits."
+ (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not))
+ (test "Can flip individual bits."
+ (and (|> /.empty (/.flip idx) (/.get idx))
+ (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not)))
+
+ (test "Bits (only) grow when (and as much as) necessary."
+ (and (n/= 0 (/.capacity /.empty))
+ (|> /.empty (/.set idx) /.capacity
+ (n/- idx)
+ (predicate.union (n/>= 0)
+ (n/< /.chunk-size)))))
+ (test "Bits (must) shrink when (and as much as) possible."
+ (let [grown (/.flip idx /.empty)]
+ (and (n/> 0 (/.capacity grown))
+ (is? /.empty (/.flip idx grown)))))
+
+ (test "Intersection can be detected when there are set bits in common."
+ (and (not (/.intersects? /.empty
+ /.empty))
+ (/.intersects? (/.set idx /.empty)
+ (/.set idx /.empty))
+ (not (/.intersects? (/.set (inc idx) /.empty)
+ (/.set idx /.empty)))))
+ (test "Cannot intersect with one's opposite."
+ (not (/.intersects? sample (/.not sample))))
+
+ (test "'and' with oneself changes nothing"
+ (:: /.equivalence = sample (/.and sample sample)))
+ (test "'and' with one's opposite yields the empty bit-set."
+ (is? /.empty (/.and sample (/.not sample))))
+
+ (test "'or' with one's opposite fully saturates a bit-set."
+ (n/= (/.size (/.or sample (/.not sample)))
+ (/.capacity sample)))
+
+ (test "'xor' with oneself yields the empty bit-set."
+ (is? /.empty (/.xor sample sample)))
+ (test "'xor' with one's opposite fully saturates a bit-set."
+ (n/= (/.size (/.xor sample (/.not sample)))
+ (/.capacity sample)))
+
+ (test "Double negation results in original bit-set."
+ (:: /.equivalence = sample (/.not (/.not sample))))
+ (test "Negation does not affect the empty bit-set."
+ (is? /.empty (/.not /.empty)))
+
+ (_eq.spec /.equivalence ..bits)
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/dictionary.lux b/stdlib/source/test/lux/data/collection/dictionary.lux
new file mode 100644
index 000000000..3ad45704e
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/dictionary.lux
@@ -0,0 +1,129 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ ["eq" equivalence]]
+ [data
+ ["." number]
+ ["." maybe]
+ [collection
+ ["&" dictionary]
+ ["." list ("list/." fold functor)]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Dictionaries."
+ (<| (times 100)
+ (do @
+ [#let [capped-nat (:: r.monad map (n/% 100) r.nat)]
+ size capped-nat
+ dict (r.dictionary number.hash size r.nat capped-nat)
+ non-key (|> r.nat (r.filter (function (_ key) (not (&.contains? key dict)))))
+ test-val (|> r.nat (r.filter (function (_ val) (not (list.member? number.equivalence (&.values dict) val)))))]
+ ($_ seq
+ (test "Size function should correctly represent Dictionary size."
+ (n/= size (&.size dict)))
+
+ (test "Dictionaries of size 0 should be considered empty."
+ (if (n/= 0 size)
+ (&.empty? dict)
+ (not (&.empty? dict))))
+
+ (test "The functions 'entries', 'keys' and 'values' should be synchronized."
+ (:: (list.equivalence (eq.product number.equivalence number.equivalence)) =
+ (&.entries dict)
+ (list.zip2 (&.keys dict)
+ (&.values dict))))
+
+ (test "Dictionary should be able to recognize it's own keys."
+ (list.every? (function (_ key) (&.contains? key dict))
+ (&.keys dict)))
+
+ (test "Should be able to get every key."
+ (list.every? (function (_ key) (case (&.get key dict)
+ (#.Some _) #1
+ _ #0))
+ (&.keys dict)))
+
+ (test "Shouldn't be able to access non-existant keys."
+ (case (&.get non-key dict)
+ (#.Some _) #0
+ _ #1))
+
+ (test "Should be able to put and then get a value."
+ (case (&.get non-key (&.put non-key test-val dict))
+ (#.Some v) (n/= test-val v)
+ _ #1))
+
+ (test "Should be able to put~ and then get a value."
+ (case (&.get non-key (&.put~ non-key test-val dict))
+ (#.Some v) (n/= test-val v)
+ _ #1))
+
+ (test "Shouldn't be able to put~ an existing key."
+ (or (n/= 0 size)
+ (let [first-key (|> dict &.keys list.head maybe.assume)]
+ (case (&.get first-key (&.put~ first-key test-val dict))
+ (#.Some v) (not (n/= test-val v))
+ _ #1))))
+
+ (test "Removing a key should make it's value inaccessible."
+ (let [base (&.put non-key test-val dict)]
+ (and (&.contains? non-key base)
+ (not (&.contains? non-key (&.remove non-key base))))))
+
+ (test "Should be possible to update values via their keys."
+ (let [base (&.put non-key test-val dict)
+ updt (&.update non-key inc base)]
+ (case [(&.get non-key base) (&.get non-key updt)]
+ [(#.Some x) (#.Some y)]
+ (n/= (inc x) y)
+
+ _
+ #0)))
+
+ (test "Additions and removals to a Dictionary should affect its size."
+ (let [plus (&.put non-key test-val dict)
+ base (&.remove non-key plus)]
+ (and (n/= (inc (&.size dict)) (&.size plus))
+ (n/= (dec (&.size plus)) (&.size base)))))
+
+ (test "A Dictionary should equal itself & going to<->from lists shouldn't change that."
+ (let [(^open ".") (&.equivalence number.equivalence)]
+ (and (= dict dict)
+ (|> dict &.entries (&.from-list number.hash) (= dict)))))
+
+ (test "Merging a Dictionary to itself changes nothing."
+ (let [(^open ".") (&.equivalence number.equivalence)]
+ (= dict (&.merge dict dict))))
+
+ (test "If you merge, and the second dict has overlapping keys, it should overwrite yours."
+ (let [dict' (|> dict &.entries
+ (list/map (function (_ [k v]) [k (inc v)]))
+ (&.from-list number.hash))
+ (^open ".") (&.equivalence number.equivalence)]
+ (= dict' (&.merge dict' dict))))
+
+ (test "Can merge values in such a way that they become combined."
+ (list.every? (function (_ [x x*2]) (n/= (n/* 2 x) x*2))
+ (list.zip2 (&.values dict)
+ (&.values (&.merge-with n/+ dict dict)))))
+
+ (test "Should be able to select subset of keys from dict."
+ (|> dict
+ (&.put non-key test-val)
+ (&.select (list non-key))
+ &.size
+ (n/= 1)))
+
+ (test "Should be able to re-bind existing values to different keys."
+ (or (n/= 0 size)
+ (let [first-key (|> dict &.keys list.head maybe.assume)
+ rebound (&.re-bind first-key non-key dict)]
+ (and (n/= (&.size dict) (&.size rebound))
+ (&.contains? non-key rebound)
+ (not (&.contains? first-key rebound))
+ (n/= (maybe.assume (&.get first-key dict))
+ (maybe.assume (&.get non-key rebound)))))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/dictionary/ordered.lux b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux
new file mode 100644
index 000000000..6b1f131cb
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux
@@ -0,0 +1,91 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." product]
+ ["." number]
+ [collection
+ ["s" set]
+ ["dict" dictionary
+ ["&" ordered]]
+ ["." list ("list/." functor)]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Dictionary"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (n/% 100)))
+ keys (r.set number.nat-hash size r.nat)
+ values (r.set number.nat-hash size r.nat)
+ extra-key (|> r.nat (r.filter (|>> (s.member? keys) not)))
+ extra-value r.nat
+ #let [pairs (list.zip2 (s.to-list keys)
+ (s.to-list values))
+ sample (&.from-list number.nat-order pairs)
+ sorted-pairs (list.sort (function (_ [left _] [right _])
+ (n/< left right))
+ pairs)
+ sorted-values (list/map product.right sorted-pairs)
+ (^open "&/.") (&.equivalence number.nat-equivalence)]]
+ ($_ seq
+ (test "Can query the size of a dictionary."
+ (n/= size (&.size sample)))
+
+ (test "Can query value for minimum key."
+ (case [(&.min sample) (list.head sorted-values)]
+ [#.None #.None]
+ #1
+
+ [(#.Some reference) (#.Some sample)]
+ (n/= reference sample)
+
+ _
+ #0))
+
+ (test "Can query value for maximum key."
+ (case [(&.max sample) (list.last sorted-values)]
+ [#.None #.None]
+ #1
+
+ [(#.Some reference) (#.Some sample)]
+ (n/= reference sample)
+
+ _
+ #0))
+
+ (test "Converting dictionaries to/from lists cannot change their values."
+ (|> sample
+ &.entries (&.from-list number.nat-order)
+ (&/= sample)))
+
+ (test "Order is preserved."
+ (let [(^open "list/.") (list.equivalence (: (Equivalence [Nat Nat])
+ (function (_ [kr vr] [ks vs])
+ (and (n/= kr ks)
+ (n/= vr vs)))))]
+ (list/= (&.entries sample)
+ sorted-pairs)))
+
+ (test "Every key in a dictionary must be identifiable."
+ (list.every? (function (_ key) (&.contains? key sample))
+ (&.keys sample)))
+
+ (test "Can add and remove elements in a dictionary."
+ (and (not (&.contains? extra-key sample))
+ (let [sample' (&.put extra-key extra-value sample)
+ sample'' (&.remove extra-key sample')]
+ (and (&.contains? extra-key sample')
+ (not (&.contains? extra-key sample''))
+ (case [(&.get extra-key sample')
+ (&.get extra-key sample'')]
+ [(#.Some found) #.None]
+ (n/= extra-value found)
+
+ _
+ #0)))
+ ))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/list.lux b/stdlib/source/test/lux/data/collection/list.lux
new file mode 100644
index 000000000..9919f3dd1
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/list.lux
@@ -0,0 +1,239 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["." number]
+ ["." bit]
+ ["." product]
+ ["." maybe]
+ [collection
+ ["&" list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: bounded-size
+ (r.Random Nat)
+ (|> r.nat
+ (:: r.monad map (|>> (n/% 100) (n/+ 10)))))
+
+(context: "Lists: Part 1"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ idx (:: @ map (n/% size) r.nat)
+ sample (r.list size r.nat)
+ other-size bounded-size
+ other-sample (r.list other-size r.nat)
+ separator r.nat
+ #let [(^open ".") (&.equivalence number.equivalence)
+ (^open "&/.") &.functor]]
+ ($_ seq
+ (test "The size function should correctly portray the size of the list."
+ (n/= size (&.size sample)))
+
+ (test "The repeat function should produce as many elements as asked of it."
+ (n/= size (&.size (&.repeat size []))))
+
+ (test "Reversing a list does not change it's size."
+ (n/= (&.size sample)
+ (&.size (&.reverse sample))))
+
+ (test "Reversing a list twice results in the original list."
+ (= sample
+ (&.reverse (&.reverse sample))))
+
+ (test "Filtering by a predicate and its complement should result in a number of elements equal to the original list."
+ (and (n/= (&.size sample)
+ (n/+ (&.size (&.filter n/even? sample))
+ (&.size (&.filter (bit.complement n/even?) sample))))
+ (let [[plus minus] (&.partition n/even? sample)]
+ (n/= (&.size sample)
+ (n/+ (&.size plus)
+ (&.size minus))))))
+
+ (test "If every element in a list satisfies a predicate, there can't be any that satisfy its complement."
+ (if (&.every? n/even? sample)
+ (and (not (&.any? (bit.complement n/even?) sample))
+ (&.empty? (&.filter (bit.complement n/even?) sample)))
+ (&.any? (bit.complement n/even?) sample)))
+
+ (test "Any element of the list can be considered its member."
+ (let [elem (maybe.assume (&.nth idx sample))]
+ (&.member? number.equivalence sample elem)))
+ ))))
+
+(context: "Lists: Part 2"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ idx (:: @ map (n/% size) r.nat)
+ sample (r.list size r.nat)
+ other-size bounded-size
+ other-sample (r.list other-size r.nat)
+ separator r.nat
+ #let [(^open ".") (&.equivalence number.equivalence)
+ (^open "&/.") &.functor]]
+ ($_ seq
+ (test "Appending the head and the tail should yield the original list."
+ (let [head (maybe.assume (&.head sample))
+ tail (maybe.assume (&.tail sample))]
+ (= sample
+ (#.Cons head tail))))
+
+ (test "Appending the inits and the last should yield the original list."
+ (let [(^open ".") &.monoid
+ inits (maybe.assume (&.inits sample))
+ last (maybe.assume (&.last sample))]
+ (= sample
+ (compose inits (list last)))))
+
+ (test "Functor should go over every element of the list."
+ (let [(^open ".") &.functor
+ there (map inc sample)
+ back-again (map dec there)]
+ (and (not (= sample there))
+ (= sample back-again))))
+
+ (test "Splitting a list into chunks and re-appending them should yield the original list."
+ (let [(^open ".") &.monoid
+ [left right] (&.split idx sample)
+ [left' right'] (&.split-with n/even? sample)]
+ (and (= sample
+ (compose left right))
+ (= sample
+ (compose left' right'))
+ (= sample
+ (compose (&.take idx sample)
+ (&.drop idx sample)))
+ (= sample
+ (compose (&.take-while n/even? sample)
+ (&.drop-while n/even? sample)))
+ )))
+
+ (test "Segmenting the list in pairs should yield as many elements as N/2."
+ (n/= (n// 2 size)
+ (&.size (&.as-pairs sample))))
+
+ (test "Sorting a list shouldn't change it's size."
+ (n/= (&.size sample)
+ (&.size (&.sort n/< sample))))
+
+ (test "Sorting a list with one order should yield the reverse of sorting it with the opposite order."
+ (= (&.sort n/< sample)
+ (&.reverse (&.sort n/> sample))))
+ ))))
+
+(context: "Lists: Part 3"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ idx (:: @ map (n/% size) r.nat)
+ sample (r.list size r.nat)
+ other-size bounded-size
+ other-sample (r.list other-size r.nat)
+ separator r.nat
+ from (|> r.nat (:: @ map (n/% 10)))
+ to (|> r.nat (:: @ map (n/% 10)))
+ #let [(^open ".") (&.equivalence number.equivalence)
+ (^open "&/.") &.functor]]
+ ($_ seq
+ (test "If you zip 2 lists, the result's size will be that of the smaller list."
+ (n/= (&.size (&.zip2 sample other-sample))
+ (n/min (&.size sample) (&.size other-sample))))
+
+ (test "I can pair-up elements of a list in order."
+ (let [(^open ".") &.functor
+ zipped (&.zip2 sample other-sample)
+ num-zipper (&.size zipped)]
+ (and (|> zipped (map product.left) (= (&.take num-zipper sample)))
+ (|> zipped (map product.right) (= (&.take num-zipper other-sample))))))
+
+ (test "You can generate indices for any size, and they will be in ascending order."
+ (let [(^open ".") &.functor
+ indices (&.indices size)]
+ (and (n/= size (&.size indices))
+ (= indices
+ (&.sort n/< indices))
+ (&.every? (n/= (dec size))
+ (&.zip2-with n/+
+ indices
+ (&.sort n/> indices)))
+ )))
+
+ (test "The 'interpose' function places a value between every member of a list."
+ (let [(^open ".") &.functor
+ sample+ (&.interpose separator sample)]
+ (and (n/= (|> size (n/* 2) dec)
+ (&.size sample+))
+ (|> sample+ &.as-pairs (map product.right) (&.every? (n/= separator))))))
+
+ (test "List append is a monoid."
+ (let [(^open ".") &.monoid]
+ (and (= sample (compose identity sample))
+ (= sample (compose sample identity))
+ (let [[left right] (&.split size (compose sample other-sample))]
+ (and (= sample left)
+ (= other-sample right))))))
+
+ (test "Apply allows you to create singleton lists, and apply lists of functions to lists of values."
+ (let [(^open ".") &.monad
+ (^open ".") &.apply]
+ (and (= (list separator) (wrap separator))
+ (= (map inc sample)
+ (apply (wrap inc) sample)))))
+
+ (test "List concatenation is a monad."
+ (let [(^open ".") &.monad
+ (^open ".") &.monoid]
+ (= (compose sample other-sample)
+ (join (list sample other-sample)))))
+
+ (test "You can find any value that satisfies some criterium, if such values exist in the list."
+ (case (&.find n/even? sample)
+ (#.Some found)
+ (and (n/even? found)
+ (&.any? n/even? sample)
+ (not (&.every? (bit.complement n/even?) sample)))
+
+ #.None
+ (and (not (&.any? n/even? sample))
+ (&.every? (bit.complement n/even?) sample))))
+
+ (test "You can iteratively construct a list, generating values until you're done."
+ (= (&.n/range 0 (dec size))
+ (&.iterate (function (_ n) (if (n/< size n) (#.Some (inc n)) #.None))
+ 0)))
+
+ (test "Can enumerate all elements in a list."
+ (let [enum-sample (&.enumerate sample)]
+ (and (= (&.indices (&.size enum-sample))
+ (&/map product.left enum-sample))
+ (= sample
+ (&/map product.right enum-sample)))))
+
+ (test "Ranges can be constructed forward and backwards."
+ (and (let [(^open "list/.") (&.equivalence number.equivalence)]
+ (list/= (&.n/range from to)
+ (&.reverse (&.n/range to from))))
+ (let [(^open "list/.") (&.equivalence number.equivalence)
+ from (.int from)
+ to (.int to)]
+ (list/= (&.i/range from to)
+ (&.reverse (&.i/range to from))))))
+ ))))
+
+## TODO: Add again once new-luxc becomes the standard compiler.
+(context: "Monad transformer"
+ (let [lift (&.lift io.monad)
+ (^open "io/.") io.monad]
+ (test "Can add list functionality to any monad."
+ (|> (io.run (do (&.ListT io.monad)
+ [a (lift (io/wrap +123))
+ b (wrap +456)]
+ (wrap (i/+ a b))))
+ (case> (^ (list +579)) #1
+ _ #0)))))
diff --git a/stdlib/source/test/lux/data/collection/queue.lux b/stdlib/source/test/lux/data/collection/queue.lux
new file mode 100644
index 000000000..4f4f12ef0
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/queue.lux
@@ -0,0 +1,54 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["." number]
+ [collection
+ ["&" queue]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Queues"
+ (<| (times 100)
+ (do @
+ [size (:: @ map (n/% 100) r.nat)
+ sample (r.queue size r.nat)
+ non-member (|> r.nat
+ (r.filter (|>> (&.member? number.equivalence sample) not)))]
+ ($_ seq
+ (test "I can query the size of a queue (and empty queues have size 0)."
+ (if (n/= 0 size)
+ (&.empty? sample)
+ (n/= size (&.size sample))))
+
+ (test "Enqueueing and dequeing affects the size of queues."
+ (and (n/= (inc size) (&.size (&.push non-member sample)))
+ (or (&.empty? sample)
+ (n/= (dec size) (&.size (&.pop sample))))
+ (n/= size (&.size (&.pop (&.push non-member sample))))))
+
+ (test "Transforming to/from list can't change the queue."
+ (let [(^open "&/.") (&.equivalence number.equivalence)]
+ (|> sample
+ &.to-list &.from-list
+ (&/= sample))))
+
+ (test "I can always peek at a non-empty queue."
+ (case (&.peek sample)
+ #.None (&.empty? sample)
+ (#.Some _) #1))
+
+ (test "I can query whether an element belongs to a queue."
+ (and (not (&.member? number.equivalence sample non-member))
+ (&.member? number.equivalence (&.push non-member sample)
+ non-member)
+ (case (&.peek sample)
+ #.None
+ (&.empty? sample)
+
+ (#.Some first)
+ (and (&.member? number.equivalence sample first)
+ (not (&.member? number.equivalence (&.pop sample) first))))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/queue/priority.lux b/stdlib/source/test/lux/data/collection/queue/priority.lux
new file mode 100644
index 000000000..3868a01a8
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/queue/priority.lux
@@ -0,0 +1,57 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do Monad)]]
+ [data
+ [number
+ ["." nat]]
+ ["." maybe]
+ [collection
+ [queue
+ ["&" priority]]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: (gen-queue size)
+ (-> Nat (r.Random (&.Queue Nat)))
+ (do r.monad
+ [inputs (r.list size r.nat)]
+ (monad.fold @ (function (_ head tail)
+ (do @
+ [priority r.nat]
+ (wrap (&.push priority head tail))))
+ &.empty
+ inputs)))
+
+(context: "Queues"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (n/% 100)))
+ sample (gen-queue size)
+ non-member-priority r.nat
+ non-member (|> r.nat (r.filter (|>> (&.member? nat.equivalence sample) not)))]
+ ($_ seq
+ (test "I can query the size of a queue (and empty queues have size 0)."
+ (n/= size (&.size sample)))
+
+ (test "Enqueueing and dequeing affects the size of queues."
+ (and (n/= (inc size)
+ (&.size (&.push non-member-priority non-member sample)))
+ (or (n/= 0 (&.size sample))
+ (n/= (dec size)
+ (&.size (&.pop sample))))))
+
+ (test "I can query whether an element belongs to a queue."
+ (and (and (not (&.member? nat.equivalence sample non-member))
+ (&.member? nat.equivalence
+ (&.push non-member-priority non-member sample)
+ non-member))
+ (or (n/= 0 (&.size sample))
+ (and (&.member? nat.equivalence
+ sample
+ (maybe.assume (&.peek sample)))
+ (not (&.member? nat.equivalence
+ (&.pop sample)
+ (maybe.assume (&.peek sample))))))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/row.lux b/stdlib/source/test/lux/data/collection/row.lux
new file mode 100644
index 000000000..2eb342e6e
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/row.lux
@@ -0,0 +1,82 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]]
+ [data
+ ["." number]
+ ["." maybe]
+ [collection
+ ["&" row]
+ [list ("list/." fold)]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Rows"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))
+ idx (|> r.nat (:: @ map (n/% size)))
+ sample (r.row size r.nat)
+ other-sample (r.row size r.nat)
+ non-member (|> r.nat (r.filter (|>> (&.member? number.equivalence sample) not)))
+ #let [(^open "&/.") (&.equivalence number.equivalence)
+ (^open "&/.") &.apply
+ (^open "&/.") &.monad
+ (^open "&/.") &.fold
+ (^open "&/.") &.monoid]]
+ ($_ seq
+ (test "Can query size of row."
+ (if (&.empty? sample)
+ (and (n/= 0 size)
+ (n/= 0 (&.size sample)))
+ (n/= size (&.size sample))))
+
+ (test "Can add and remove elements to rows."
+ (and (n/= (inc size) (&.size (&.add non-member sample)))
+ (n/= (dec size) (&.size (&.pop sample)))))
+
+ (test "Can put and get elements into rows."
+ (|> sample
+ (&.put idx non-member)
+ (&.nth idx)
+ maybe.assume
+ (is? non-member)))
+
+ (test "Can update elements of rows."
+ (|> sample
+ (&.put idx non-member) (&.update idx inc)
+ (&.nth idx) maybe.assume
+ (n/= (inc non-member))))
+
+ (test "Can safely transform to/from lists."
+ (|> sample &.to-list &.from-list (&/= sample)))
+
+ (test "Can identify members of a row."
+ (and (not (&.member? number.equivalence sample non-member))
+ (&.member? number.equivalence (&.add non-member sample) non-member)))
+
+ (test "Can fold over elements of row."
+ (n/= (list/fold n/+ 0 (&.to-list sample))
+ (&/fold n/+ 0 sample)))
+
+ (test "Functor goes over every element."
+ (let [there (&/map inc sample)
+ back-again (&/map dec there)]
+ (and (not (&/= sample there))
+ (&/= sample back-again))))
+
+ (test "Apply allows you to create singleton rows, and apply rows of functions to rows of values."
+ (and (&/= (&.row non-member) (&/wrap non-member))
+ (&/= (&/map inc sample) (&/apply (&/wrap inc) sample))))
+
+ (test "Row concatenation is a monad."
+ (&/= (&/compose sample other-sample)
+ (&/join (&.row sample other-sample))))
+
+ (test "Can reverse."
+ (and (not (&/= sample
+ (&.reverse sample)))
+ (not (&/= sample
+ (&.reverse (&.reverse sample))))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/sequence.lux b/stdlib/source/test/lux/data/collection/sequence.lux
new file mode 100644
index 000000000..de398e6f6
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/sequence.lux
@@ -0,0 +1,103 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ comonad]
+ [data
+ ["." maybe]
+ ["." number ("nat/." codec)]
+ ["." text ("text/." monoid)]
+ [collection
+ ["." list]
+ ["&" sequence]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Sequences"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 2))))
+ offset (|> r.nat (:: @ map (n/% 100)))
+ factor (|> r.nat (:: @ map (|>> (n/% 100) (n/max 2))))
+ elem r.nat
+ cycle-seed (r.list size r.nat)
+ cycle-sample-idx (|> r.nat (:: @ map (n/% 1000)))
+ #let [(^open "List/.") (list.equivalence number.equivalence)
+ sample0 (&.iterate inc 0)
+ sample1 (&.iterate inc offset)]]
+ ($_ seq
+ (test "Can move along a sequence and take slices off it."
+ (and (and (List/= (list.n/range 0 (dec size))
+ (&.take size sample0))
+ (List/= (list.n/range offset (dec (n/+ offset size)))
+ (&.take size (&.drop offset sample0)))
+ (let [[drops takes] (&.split size sample0)]
+ (and (List/= (list.n/range 0 (dec size))
+ drops)
+ (List/= (list.n/range size (dec (n/* 2 size)))
+ (&.take size takes)))))
+ (and (List/= (list.n/range 0 (dec size))
+ (&.take-while (n/< size) sample0))
+ (List/= (list.n/range offset (dec (n/+ offset size)))
+ (&.take-while (n/< (n/+ offset size))
+ (&.drop-while (n/< offset) sample0)))
+ (let [[drops takes] (&.split-while (n/< size) sample0)]
+ (and (List/= (list.n/range 0 (dec size))
+ drops)
+ (List/= (list.n/range size (dec (n/* 2 size)))
+ (&.take-while (n/< (n/* 2 size)) takes)))))
+ ))
+
+ (test "Can repeat any element and infinite number of times."
+ (n/= elem (&.nth offset (&.repeat elem))))
+
+ (test "Can obtain the head & tail of a sequence."
+ (and (n/= offset (&.head sample1))
+ (List/= (list.n/range (inc offset) (n/+ offset size))
+ (&.take size (&.tail sample1)))))
+
+ (test "Can filter sequences."
+ (and (n/= (n/* 2 offset)
+ (&.nth offset
+ (&.filter n/even? sample0)))
+ (let [[evens odds] (&.partition n/even? (&.iterate inc 0))]
+ (and (n/= (n/* 2 offset)
+ (&.nth offset evens))
+ (n/= (inc (n/* 2 offset))
+ (&.nth offset odds))))))
+
+ (test "Functor goes over 'all' elements in a sequence."
+ (let [(^open "&/.") &.functor
+ there (&/map (n/* factor) sample0)
+ back-again (&/map (n// factor) there)]
+ (and (not (List/= (&.take size sample0)
+ (&.take size there)))
+ (List/= (&.take size sample0)
+ (&.take size back-again)))))
+
+ (test "CoMonad produces a value for every element in a sequence."
+ (let [(^open "&/.") &.functor]
+ (List/= (&.take size (&/map (n/* factor) sample1))
+ (&.take size
+ (be &.comonad
+ [inputs sample1]
+ (n/* factor (&.head inputs)))))))
+
+ (test "'unfold' generalizes 'iterate'."
+ (let [(^open "&/.") &.functor
+ (^open "List/.") (list.equivalence text.equivalence)]
+ (List/= (&.take size
+ (&/map nat/encode (&.iterate inc offset)))
+ (&.take size
+ (&.unfold (function (_ n) [(inc n) (nat/encode n)])
+ offset)))))
+
+ (test "Can cycle over the same elements as an infinite sequence."
+ (|> (&.cycle cycle-seed)
+ maybe.assume
+ (&.nth cycle-sample-idx)
+ (n/= (|> cycle-seed
+ (list.nth (n/% size cycle-sample-idx))
+ maybe.assume))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/set.lux b/stdlib/source/test/lux/data/collection/set.lux
new file mode 100644
index 000000000..bbdc945f7
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/set.lux
@@ -0,0 +1,67 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["." number]
+ [collection
+ ["&" set (#+ Set)]
+ ["." list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: gen-nat
+ (r.Random Nat)
+ (|> r.nat
+ (:: r.monad map (n/% 100))))
+
+(context: "Sets"
+ (<| (times 100)
+ (do @
+ [sizeL gen-nat
+ sizeR gen-nat
+ setL (r.set number.hash sizeL gen-nat)
+ setR (r.set number.hash sizeR gen-nat)
+ non-member (|> gen-nat
+ (r.filter (|>> (&.member? setL) not)))
+ #let [(^open "&/.") &.equivalence]]
+ ($_ seq
+ (test "I can query the size of a set."
+ (and (n/= sizeL (&.size setL))
+ (n/= sizeR (&.size setR))))
+
+ (test "Converting sets to/from lists can't change their values."
+ (|> setL
+ &.to-list (&.from-list number.hash)
+ (&/= setL)))
+
+ (test "Every set is a sub-set of the union of itself with another."
+ (let [setLR (&.union setL setR)]
+ (and (&.sub? setLR setL)
+ (&.sub? setLR setR))))
+
+ (test "Every set is a super-set of the intersection of itself with another."
+ (let [setLR (&.intersection setL setR)]
+ (and (&.super? setLR setL)
+ (&.super? setLR setR))))
+
+ (test "Union with the empty set leaves a set unchanged."
+ (&/= setL
+ (&.union (&.new number.hash)
+ setL)))
+
+ (test "Intersection with the empty set results in the empty set."
+ (let [empty-set (&.new number.hash)]
+ (&/= empty-set
+ (&.intersection empty-set setL))))
+
+ (test "After substracting a set A from another B, no member of A can be a member of B."
+ (let [sub (&.difference setR setL)]
+ (not (list.any? (&.member? sub) (&.to-list setR)))))
+
+ (test "Every member of a set must be identifiable."
+ (and (not (&.member? setL non-member))
+ (&.member? (&.add non-member setL) non-member)
+ (not (&.member? (&.remove non-member (&.add non-member setL)) non-member))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/set/ordered.lux b/stdlib/source/test/lux/data/collection/set/ordered.lux
new file mode 100644
index 000000000..384a0506b
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/set/ordered.lux
@@ -0,0 +1,98 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["." number]
+ [text
+ format]
+ [collection
+ ["." set
+ ["&" ordered]]
+ ["." list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: gen-nat
+ (r.Random Nat)
+ (|> r.nat
+ (:: r.monad map (n/% 100))))
+
+(context: "Sets"
+ (<| (times 100)
+ (do @
+ [sizeL gen-nat
+ sizeR gen-nat
+ listL (|> (r.set number.hash sizeL gen-nat) (:: @ map set.to-list))
+ listR (|> (r.set number.hash sizeR gen-nat) (:: @ map set.to-list))
+ #let [(^open "&/.") &.equivalence
+ setL (&.from-list number.order listL)
+ setR (&.from-list number.order listR)
+ sortedL (list.sort n/< listL)
+ minL (list.head sortedL)
+ maxL (list.last sortedL)]]
+ ($_ seq
+ (test "I can query the size of a set."
+ (n/= sizeL (&.size setL)))
+
+ (test "Can query minimum value."
+ (case [(&.min setL) minL]
+ [#.None #.None]
+ #1
+
+ [(#.Some reference) (#.Some sample)]
+ (n/= reference sample)
+
+ _
+ #0))
+
+ (test "Can query maximum value."
+ (case [(&.max setL) maxL]
+ [#.None #.None]
+ #1
+
+ [(#.Some reference) (#.Some sample)]
+ (n/= reference sample)
+
+ _
+ #0))
+
+ (test "Converting sets to/from lists can't change their values."
+ (|> setL
+ &.to-list (&.from-list number.order)
+ (&/= setL)))
+
+ (test "Order is preserved."
+ (let [listL (&.to-list setL)
+ (^open "L/.") (list.equivalence number.equivalence)]
+ (L/= listL
+ (list.sort n/< listL))))
+
+ (test "Every set is a sub-set of the union of itself with another."
+ (let [setLR (&.union setL setR)]
+ (and (&.sub? setLR setL)
+ (&.sub? setLR setR))))
+
+ (test "Every set is a super-set of the intersection of itself with another."
+ (let [setLR (&.intersection setL setR)]
+ (and (&.super? setLR setL)
+ (&.super? setLR setR))))
+
+ (test "Union with the empty set leaves a set unchanged."
+ (&/= setL
+ (&.union (&.new number.order)
+ setL)))
+
+ (test "Intersection with the empty set results in the empty set."
+ (let [empty-set (&.new number.order)]
+ (&/= empty-set
+ (&.intersection empty-set setL))))
+
+ (test "After substracting a set A from another B, no member of A can be a member of B."
+ (let [sub (&.difference setR setL)]
+ (not (list.any? (&.member? sub) (&.to-list setR)))))
+
+ (test "Every member of a set must be identifiable."
+ (list.every? (&.member? setL) (&.to-list setL)))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/stack.lux b/stdlib/source/test/lux/data/collection/stack.lux
new file mode 100644
index 000000000..d203b4246
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/stack.lux
@@ -0,0 +1,46 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ ["." maybe]
+ [collection
+ ["&" stack]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: gen-nat
+ (r.Random Nat)
+ (|> r.nat
+ (:: r.monad map (n/% 100))))
+
+(context: "Stacks"
+ (<| (times 100)
+ (do @
+ [size gen-nat
+ sample (r.stack size gen-nat)
+ new-top gen-nat]
+ ($_ seq
+ (test "Can query the size of a stack."
+ (n/= size (&.size sample)))
+
+ (test "Can peek inside non-empty stacks."
+ (case (&.peek sample)
+ #.None (&.empty? sample)
+ (#.Some _) (not (&.empty? sample))))
+
+ (test "Popping empty stacks doesn't change anything.
+ But, if they're non-empty, the top of the stack is removed."
+ (let [sample' (&.pop sample)]
+ (or (n/= (&.size sample) (inc (&.size sample')))
+ (and (&.empty? sample) (&.empty? sample')))
+ ))
+
+ (test "Pushing onto a stack always increases it by 1, adding a new value at the top."
+ (and (is? sample
+ (&.pop (&.push new-top sample)))
+ (n/= (inc (&.size sample)) (&.size (&.push new-top sample)))
+ (|> (&.push new-top sample) &.peek maybe.assume
+ (is? new-top))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/tree/rose.lux b/stdlib/source/test/lux/data/collection/tree/rose.lux
new file mode 100644
index 000000000..47dbf94cf
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/tree/rose.lux
@@ -0,0 +1,51 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["." product]
+ ["." number]
+ [text ("text/." equivalence)
+ format]
+ [collection
+ ["." list ("list/." functor fold)]
+ [tree
+ ["&" rose]]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: gen-tree
+ (r.Random [Nat (&.Tree Nat)])
+ (r.rec
+ (function (_ gen-tree)
+ (r.either (:: r.monad map (|>> &.leaf [1]) r.nat)
+ (do r.monad
+ [value r.nat
+ num-children (|> r.nat (:: @ map (n/% 3)))
+ children' (r.list num-children gen-tree)
+ #let [size' (list/fold n/+ 0 (list/map product.left children'))
+ children (list/map product.right children')]]
+ (wrap [(inc size')
+ (&.branch value children)]))
+ ))))
+
+(context: "Trees"
+ (<| (times 100)
+ (do @
+ [[size sample] gen-tree
+ #let [(^open "&/.") (&.equivalence number.equivalence)
+ (^open "&/.") &.fold
+ concat (function (_ addition partial) (format partial (%n addition)))]]
+ ($_ seq
+ (test "Can compare trees for equivalence."
+ (&/= sample sample))
+
+ (test "Can flatten a tree to get all the nodes as a flat tree."
+ (n/= size
+ (list.size (&.flatten sample))))
+
+ (test "Can fold trees."
+ (text/= (&/fold concat "" sample)
+ (list/fold concat "" (&.flatten sample))))
+ ))))
diff --git a/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux
new file mode 100644
index 000000000..3abf1dd26
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux
@@ -0,0 +1,128 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["." number]
+ ["." maybe]
+ ["." text
+ format]
+ [collection
+ ["." list]
+ [tree
+ ["." rose
+ ["&" zipper]]]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: gen-tree
+ (r.Random (rose.Tree Nat))
+ (r.rec (function (_ gen-tree)
+ (do r.monad
+ ## Each branch can have, at most, 1 child.
+ [size (|> r.nat (:: @ map (n/% 2)))]
+ (r.and r.nat
+ (r.list size gen-tree))))))
+
+(def: (to-end zipper)
+ (All [a] (-> (&.Zipper a) (&.Zipper a)))
+ (loop [zipper zipper]
+ (if (&.end? zipper)
+ zipper
+ (recur (&.next zipper)))))
+
+(context: "Zippers."
+ (<| (times 100)
+ (do @
+ [sample gen-tree
+ new-val r.nat
+ pre-val r.nat
+ post-val r.nat
+ #let [(^open "tree/.") (rose.equivalence number.equivalence)
+ (^open "list/.") (list.equivalence number.equivalence)]]
+ ($_ seq
+ (test "Trees can be converted to/from zippers."
+ (|> sample
+ &.zip &.unzip
+ (tree/= sample)))
+
+ (test "Creating a zipper gives you a root node."
+ (|> sample &.zip &.root?))
+
+ (test "Can move down inside branches. Can move up from lower nodes."
+ (let [zipper (&.zip sample)]
+ (if (&.branch? zipper)
+ (let [child (|> zipper &.down)]
+ (and (not (tree/= sample (&.unzip child)))
+ (|> child &.up (is? zipper) not)
+ (|> child &.root (is? zipper) not)))
+ (and (&.leaf? zipper)
+ (|> zipper (&.prepend-child new-val) &.branch?)))))
+
+ (test "Can prepend and append children."
+ (let [zipper (&.zip sample)]
+ (if (&.branch? zipper)
+ (let [mid-val (|> zipper &.down &.value)
+ zipper (|> zipper
+ (&.prepend-child pre-val)
+ (&.append-child post-val))]
+ (and (|> zipper &.down &.value (is? pre-val))
+ (|> zipper &.down &.right &.value (is? mid-val))
+ (|> zipper &.down &.right &.right &.value (is? post-val))
+ (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val))
+ (|> zipper &.down &.right &.left &.value (is? pre-val))
+ (|> zipper &.down &.rightmost &.value (is? post-val))))
+ #1)))
+
+ (test "Can insert children around a node (unless it's root)."
+ (let [zipper (&.zip sample)]
+ (if (&.branch? zipper)
+ (let [mid-val (|> zipper &.down &.value)
+ zipper (|> zipper
+ &.down
+ (&.insert-left pre-val)
+ maybe.assume
+ (&.insert-right post-val)
+ maybe.assume
+ &.up)]
+ (and (|> zipper &.down &.value (is? pre-val))
+ (|> zipper &.down &.right &.value (is? mid-val))
+ (|> zipper &.down &.right &.right &.value (is? post-val))
+ (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val))
+ (|> zipper &.down &.right &.left &.value (is? pre-val))
+ (|> zipper &.down &.rightmost &.value (is? post-val))))
+ (and (|> zipper (&.insert-left pre-val) (case> (#.Some _) #0
+ #.None #1))
+ (|> zipper (&.insert-right post-val) (case> (#.Some _) #0
+ #.None #1))))))
+
+ (test "Can set and update the value of a node."
+ (|> sample &.zip (&.set new-val) &.value (n/= new-val)))
+
+ (test "Zipper traversal follows the outline of the tree depth-first."
+ (list/= (rose.flatten sample)
+ (loop [zipper (&.zip sample)]
+ (if (&.end? zipper)
+ (list (&.value zipper))
+ (#.Cons (&.value zipper)
+ (recur (&.next zipper)))))))
+
+ (test "Backwards zipper traversal yield reverse tree flatten."
+ (list/= (list.reverse (rose.flatten sample))
+ (loop [zipper (to-end (&.zip sample))]
+ (if (&.root? zipper)
+ (list (&.value zipper))
+ (#.Cons (&.value zipper)
+ (recur (&.prev zipper)))))))
+
+ (test "Can remove nodes (except root nodes)."
+ (let [zipper (&.zip sample)]
+ (if (&.branch? zipper)
+ (and (|> zipper &.down &.root? not)
+ (|> zipper &.down &.remove (case> #.None #0
+ (#.Some node) (&.root? node))))
+ (|> zipper &.remove (case> #.None #1
+ (#.Some _) #0)))))
+ ))))
diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux
new file mode 100644
index 000000000..503421db2
--- /dev/null
+++ b/stdlib/source/test/lux/data/color.lux
@@ -0,0 +1,99 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ ["@" color]
+ [number ("frac/." number)]]
+ ["." math
+ ["r" random]]]
+ lux/test)
+
+(def: color
+ (r.Random @.Color)
+ (|> ($_ r.and r.nat r.nat r.nat)
+ (:: r.monad map @.from-rgb)))
+
+(def: scale
+ (-> Nat Frac)
+ (|>> .int int-to-frac))
+
+(def: square (-> Frac Frac) (math.pow +2.0))
+
+(def: (distance from to)
+ (-> @.Color @.Color Frac)
+ (let [[fr fg fb] (@.to-rgb from)
+ [tr tg tb] (@.to-rgb to)]
+ (math.pow +0.5 ($_ f/+
+ (|> (scale tr) (f/- (scale fr)) square)
+ (|> (scale tg) (f/- (scale fg)) square)
+ (|> (scale tb) (f/- (scale fb)) square)))))
+
+(def: error-margin Frac +1.8)
+
+(def: black (@.from-rgb [0 0 0]))
+(def: white (@.from-rgb [255 255 255]))
+
+(do-template [<field>]
+ [(def: (<field> color)
+ (-> @.Color Frac)
+ (let [[hue saturation luminance] (@.to-hsl color)]
+ <field>))]
+
+ [saturation]
+ [luminance]
+ )
+
+(context: "Color."
+ (<| (times 100)
+ (do @
+ [any color
+ colorful (|> color
+ (r.filter (function (_ color) (|> (distance color black) (f/>= +100.0))))
+ (r.filter (function (_ color) (|> (distance color white) (f/>= +100.0)))))
+ mediocre (|> color
+ (r.filter (|>> saturation
+ ((function (_ saturation)
+ (and (f/>= +0.25 saturation)
+ (f/<= +0.75 saturation)))))))
+ ratio (|> r.frac (r.filter (f/>= +0.5)))]
+ ($_ seq
+ (test "Has equivalence."
+ (:: @.equivalence = any any))
+ (test "Can convert to/from HSL."
+ (|> any @.to-hsl @.from-hsl
+ (distance any)
+ (f/<= error-margin)))
+ (test "Can convert to/from HSB."
+ (|> any @.to-hsb @.from-hsb
+ (distance any)
+ (f/<= error-margin)))
+ (test "Can convert to/from CMYK."
+ (|> any @.to-cmyk @.from-cmyk
+ (distance any)
+ (f/<= error-margin)))
+ (test "Can interpolate between 2 colors."
+ (and (f/<= (distance colorful black)
+ (distance (@.darker ratio colorful) black))
+ (f/<= (distance colorful white)
+ (distance (@.brighter ratio colorful) white))))
+ (test "Can calculate complement."
+ (let [~any (@.complement any)
+ (^open "@/.") @.equivalence]
+ (and (not (@/= any ~any))
+ (@/= any (@.complement ~any)))))
+ (test "Can saturate color."
+ (f/> (saturation mediocre)
+ (saturation (@.saturate ratio mediocre))))
+ (test "Can de-saturate color."
+ (f/< (saturation mediocre)
+ (saturation (@.de-saturate ratio mediocre))))
+ (test "Can gray-scale color."
+ (let [gray'ed (@.gray-scale mediocre)]
+ (and (f/= +0.0
+ (saturation gray'ed))
+ (|> (luminance gray'ed)
+ (f/- (luminance mediocre))
+ frac/abs
+ (f/<= error-margin)))))
+ ))))
diff --git a/stdlib/source/test/lux/data/error.lux b/stdlib/source/test/lux/data/error.lux
new file mode 100644
index 000000000..7f491dc2c
--- /dev/null
+++ b/stdlib/source/test/lux/data/error.lux
@@ -0,0 +1,61 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["/" error (#+ Error)]]]
+ lux/test)
+
+(context: "Errors"
+ (let [(^open "//.") /.apply
+ (^open "//.") /.monad]
+ ($_ seq
+ (test "Functor correctly handles both cases."
+ (and (|> (: (Error Int) (#/.Success +10))
+ (//map inc)
+ (case> (#/.Success +11) #1 _ #0))
+
+ (|> (: (Error Int) (#/.Failure "YOLO"))
+ (//map inc)
+ (case> (#/.Failure "YOLO") #1 _ #0))
+ ))
+
+ (test "Apply correctly handles both cases."
+ (and (|> (//wrap +20)
+ (case> (#/.Success +20) #1 _ #0))
+ (|> (//apply (//wrap inc) (//wrap +10))
+ (case> (#/.Success +11) #1 _ #0))
+ (|> (//apply (//wrap inc) (#/.Failure "YOLO"))
+ (case> (#/.Failure "YOLO") #1 _ #0))))
+
+ (test "Monad correctly handles both cases."
+ (and (|> (do /.monad
+ [f (wrap i/+)
+ a (wrap +10)
+ b (wrap +20)]
+ (wrap (f a b)))
+ (case> (#/.Success +30) #1 _ #0))
+ (|> (do /.monad
+ [f (wrap i/+)
+ a (#/.Failure "YOLO")
+ b (wrap +20)]
+ (wrap (f a b)))
+ (case> (#/.Failure "YOLO") #1 _ #0))
+ ))
+ )))
+
+(context: "Monad transformer"
+ (let [lift (/.lift io.monad)
+ (^open "io/.") io.monad]
+ (test "Can add error functionality to any monad."
+ (|> (io.run (do (/.ErrorT io.monad)
+ [a (lift (io/wrap +123))
+ b (wrap +456)]
+ (wrap (i/+ a b))))
+ (case> (#/.Success +579)
+ #1
+
+ _
+ #0)))))
diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux
new file mode 100644
index 000000000..f54b51c3b
--- /dev/null
+++ b/stdlib/source/test/lux/data/format/json.lux
@@ -0,0 +1,183 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ codec
+ [equivalence (#+ Equivalence)]
+ pipe
+ ["p" parser]]
+ [data
+ ["." error]
+ ["." bit]
+ ["." maybe]
+ ["." number]
+ ["." text
+ format]
+ [format
+ ["@" json]]
+ [collection
+ [row (#+ row)]
+ ["d" dictionary]
+ ["." list]]]
+ [macro
+ [poly (#+ derived:)]
+ ["." poly/equivalence]
+ ["." poly/json]]
+ [type
+ ["." unit]]
+ [math
+ ["r" random]]
+ [time
+ ["ti" instant]
+ ["tda" date]
+ ## ["tdu" duration]
+ ]
+ test]
+ [test
+ [lux
+ [time
+ ["_." instant]
+ ## ["_." duration]
+ ["_." date]]]]
+ )
+
+(def: gen-json
+ (r.Random @.JSON)
+ (r.rec (function (_ gen-json)
+ (do r.monad
+ [size (:: @ map (n/% 2) r.nat)]
+ ($_ r.or
+ (:: @ wrap [])
+ r.bit
+ (|> r.frac (:: @ map (f/* +1_000_000.0)))
+ (r.unicode size)
+ (r.row size gen-json)
+ (r.dictionary text.hash size (r.unicode size) gen-json)
+ )))))
+
+(context: "JSON"
+ (<| (times 100)
+ (do @
+ [sample gen-json
+ #let [(^open "@/.") @.equivalence
+ (^open "@/.") @.codec]]
+ ($_ seq
+ (test "Every JSON is equal to itself."
+ (@/= sample sample))
+
+ (test "Can encode/decode JSON."
+ (|> sample @/encode @/decode
+ (case> (#.Right result)
+ (@/= sample result)
+
+ (#.Left _)
+ #0)))
+ ))))
+
+(type: Variant
+ (#Case0 Bit)
+ (#Case1 Text)
+ (#Case2 Frac))
+
+(type: #rec Recursive
+ (#Number Frac)
+ (#Addition Frac Recursive))
+
+(type: Record
+ {#bit Bit
+ #frac Frac
+ #text Text
+ #maybe (Maybe Frac)
+ #list (List Frac)
+ #dict (d.Dictionary Text Frac)
+ ## #variant Variant
+ ## #tuple [Bit Frac Text]
+ #recursive Recursive
+ ## #instant ti.Instant
+ ## #duration tdu.Duration
+ #date tda.Date
+ #grams (unit.Qty unit.Gram)
+ })
+
+(def: gen-recursive
+ (r.Random Recursive)
+ (r.rec (function (_ gen-recursive)
+ (r.or r.frac
+ (r.and r.frac gen-recursive)))))
+
+(derived: (poly/equivalence.Equivalence<?> Recursive))
+
+(def: qty
+ (All [unit] (r.Random (unit.Qty unit)))
+ (|> r.int (:: r.monad map unit.in)))
+
+(def: gen-record
+ (r.Random Record)
+ (do r.monad
+ [size (:: @ map (n/% 2) r.nat)]
+ ($_ r.and
+ r.bit
+ r.frac
+ (r.unicode size)
+ (r.maybe r.frac)
+ (r.list size r.frac)
+ (r.dictionary text.hash size (r.unicode size) r.frac)
+ ## ($_ r.or r.bit (r.unicode size) r.frac)
+ ## ($_ r.and r.bit r.frac (r.unicode size))
+ gen-recursive
+ ## _instant.instant
+ ## _duration.duration
+ _date.date
+ qty
+ )))
+
+(derived: (poly/json.codec Record))
+
+(structure: _ (Equivalence Record)
+ (def: (= recL recR)
+ (let [variant/= (function (_ left right)
+ (case [left right]
+ [(#Case0 left') (#Case0 right')]
+ (:: bit.equivalence = left' right')
+
+ [(#Case1 left') (#Case1 right')]
+ (:: text.equivalence = left' right')
+
+ [(#Case2 left') (#Case2 right')]
+ (f/= left' right')
+
+ _
+ #0))]
+ (and (:: bit.equivalence = (get@ #bit recL) (get@ #bit recR))
+ (f/= (get@ #frac recL) (get@ #frac recR))
+ (:: text.equivalence = (get@ #text recL) (get@ #text recR))
+ (:: (maybe.equivalence number.equivalence) = (get@ #maybe recL) (get@ #maybe recR))
+ (:: (list.equivalence number.equivalence) = (get@ #list recL) (get@ #list recR))
+ (:: (d.equivalence number.equivalence) = (get@ #dict recL) (get@ #dict recR))
+ ## (variant/= (get@ #variant recL) (get@ #variant recR))
+ ## (let [[tL0 tL1 tL2] (get@ #tuple recL)
+ ## [tR0 tR1 tR2] (get@ #tuple recR)]
+ ## (and (:: bit.equivalence = tL0 tR0)
+ ## (f/= tL1 tR1)
+ ## (:: text.equivalence = tL2 tR2)))
+ (:: equivalence = (get@ #recursive recL) (get@ #recursive recR))
+ ## (:: ti.equivalence = (get@ #instant recL) (get@ #instant recR))
+ ## (:: tdu.equivalence = (get@ #duration recL) (get@ #duration recR))
+ (:: tda.equivalence = (get@ #date recL) (get@ #date recR))
+ (:: unit.equivalence = (get@ #grams recL) (get@ #grams recR))
+ ))))
+
+(context: "Polytypism"
+ (<| (seed 14562075782602945288)
+ ## (times 100)
+ (do @
+ [sample gen-record
+ #let [(^open "@/.") ..equivalence
+ (^open "@/.") ..codec]]
+ (test "Can encode/decode arbitrary types."
+ (|> sample @/encode @/decode
+ (case> (#error.Success result)
+ (@/= sample result)
+
+ (#error.Failure error)
+ #0))))))
diff --git a/stdlib/source/test/lux/data/format/xml.lux b/stdlib/source/test/lux/data/format/xml.lux
new file mode 100644
index 000000000..0f86eb63d
--- /dev/null
+++ b/stdlib/source/test/lux/data/format/xml.lux
@@ -0,0 +1,121 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]
+ ["p" parser]
+ pipe]
+ [data
+ ["." name]
+ ["E" error]
+ ["." maybe]
+ ["." text ("text/." equivalence)
+ format]
+ [format
+ ["&" xml]]
+ [collection
+ ["dict" dictionary]
+ ["." list ("list/." functor)]]]
+ [math
+ ["r" random ("r/." monad)]]]
+ lux/test)
+
+(def: char-range
+ Text
+ (format "_"
+ "abcdefghijklmnopqrstuvwxyz"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+
+(def: xml-char^
+ (r.Random Nat)
+ (do r.monad
+ [idx (|> r.nat (:: @ map (n/% (text.size char-range))))]
+ (wrap (maybe.assume (text.nth idx char-range)))))
+
+(def: (size^ bottom top)
+ (-> Nat Nat (r.Random Nat))
+ (let [constraint (|>> (n/% top) (n/max bottom))]
+ (r/map constraint r.nat)))
+
+(def: (xml-text^ bottom top)
+ (-> Nat Nat (r.Random Text))
+ (do r.monad
+ [size (size^ bottom top)]
+ (r.text xml-char^ size)))
+
+(def: xml-identifier^
+ (r.Random Name)
+ (r.and (xml-text^ 0 10)
+ (xml-text^ 1 10)))
+
+(def: gen-xml
+ (r.Random &.XML)
+ (r.rec (function (_ gen-xml)
+ (r.or (xml-text^ 1 10)
+ (do r.monad
+ [size (size^ 0 2)]
+ ($_ r.and
+ xml-identifier^
+ (r.dictionary name.hash size xml-identifier^ (xml-text^ 0 10))
+ (r.list size gen-xml)))))))
+
+(context: "XML."
+ (<| (times 100)
+ (do @
+ [sample gen-xml
+ #let [(^open "&/.") &.equivalence
+ (^open "&/.") &.codec]]
+ ($_ seq
+ (test "Every XML is equal to itself."
+ (&/= sample sample))
+
+ (test "Can encode/decode XML."
+ (|> sample &/encode &/decode
+ (case> (#.Right result)
+ (&/= sample result)
+
+ (#.Left error)
+ #0)))
+ ))))
+
+(context: "Parsing."
+ (<| (times 100)
+ (do @
+ [text (xml-text^ 1 10)
+ num-children (|> r.nat (:: @ map (n/% 5)))
+ children (r.list num-children (xml-text^ 1 10))
+ tag xml-identifier^
+ attr xml-identifier^
+ value (xml-text^ 1 10)
+ #let [node (#&.Node tag
+ (dict.put attr value &.attrs)
+ (list/map (|>> #&.Text) children))]]
+ ($_ seq
+ (test "Can parse text."
+ (E.default #0
+ (do E.monad
+ [output (&.run (#&.Text text)
+ &.text)]
+ (wrap (text/= text output)))))
+ (test "Can parse attributes."
+ (E.default #0
+ (do E.monad
+ [output (|> (&.attr attr)
+ (p.before &.ignore)
+ (&.run node))]
+ (wrap (text/= value output)))))
+ (test "Can parse nodes."
+ (E.default #0
+ (do E.monad
+ [_ (|> (&.node tag)
+ (p.before &.ignore)
+ (&.run node))]
+ (wrap #1))))
+ (test "Can parse children."
+ (E.default #0
+ (do E.monad
+ [outputs (|> (&.children (p.some &.text))
+ (&.run node))]
+ (wrap (:: (list.equivalence text.equivalence) =
+ children
+ outputs)))))
+ ))))
diff --git a/stdlib/source/test/lux/data/identity.lux b/stdlib/source/test/lux/data/identity.lux
new file mode 100644
index 000000000..31bf105cd
--- /dev/null
+++ b/stdlib/source/test/lux/data/identity.lux
@@ -0,0 +1,37 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ Monad do)]
+ comonad]
+ [data
+ ["&" identity]
+ [text ("text/." monoid equivalence)]]]
+ lux/test)
+
+(context: "Identity"
+ (let [(^open "&/.") &.apply
+ (^open "&/.") &.monad
+ (^open "&/.") &.comonad]
+ ($_ seq
+ (test "Functor does not affect values."
+ (text/= "yololol" (&/map (text/compose "yolo") "lol")))
+
+ (test "Apply does not affect values."
+ (and (text/= "yolo" (&/wrap "yolo"))
+ (text/= "yololol" (&/apply (&/wrap (text/compose "yolo")) (&/wrap "lol")))))
+
+ (test "Monad does not affect values."
+ (text/= "yololol" (do &.monad
+ [f (wrap text/compose)
+ a (wrap "yolo")
+ b (wrap "lol")]
+ (wrap (f a b)))))
+
+ (test "CoMonad does not affect values."
+ (and (text/= "yololol" (&/unwrap "yololol"))
+ (text/= "yololol" (be &.comonad
+ [f text/compose
+ a "yolo"
+ b "lol"]
+ (f a b)))))
+ )))
diff --git a/stdlib/source/test/lux/data/lazy.lux b/stdlib/source/test/lux/data/lazy.lux
new file mode 100644
index 000000000..f00b572ab
--- /dev/null
+++ b/stdlib/source/test/lux/data/lazy.lux
@@ -0,0 +1,54 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["&" lazy]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Lazy."
+ (<| (times 100)
+ (do @
+ [left r.nat
+ right r.nat
+ #let [lazy (&.freeze (n/* left right))
+ expected (n/* left right)]]
+ ($_ seq
+ (test "Lazying does not alter the expected value."
+ (n/= expected
+ (&.thaw lazy)))
+ (test "Lazy values only evaluate once."
+ (and (not (is? expected
+ (&.thaw lazy)))
+ (is? (&.thaw lazy)
+ (&.thaw lazy))))
+ ))))
+
+(context: "Functor, Apply, Monad."
+ (<| (times 100)
+ (do @
+ [sample r.nat]
+ ($_ seq
+ (test "Functor map."
+ (|> (&.freeze sample)
+ (:: &.functor map inc)
+ &.thaw
+ (n/= (inc sample))))
+
+ (test "Monad."
+ (|> (do &.monad
+ [f (wrap inc)
+ a (wrap sample)]
+ (wrap (f a)))
+ &.thaw
+ (n/= (inc sample))))
+
+ (test "Apply apply."
+ (let [(^open "&/.") &.monad
+ (^open "&/.") &.apply]
+ (|> (&/apply (&/wrap inc) (&/wrap sample))
+ &.thaw
+ (n/= (inc sample)))))
+ ))))
diff --git a/stdlib/source/test/lux/data/maybe.lux b/stdlib/source/test/lux/data/maybe.lux
new file mode 100644
index 000000000..eb09491a1
--- /dev/null
+++ b/stdlib/source/test/lux/data/maybe.lux
@@ -0,0 +1,69 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ Monad do)]
+ pipe]
+ [data
+ ["&" maybe ("&/." monoid)]
+ ["." text ("text/." monoid)]]
+ ["." io ("io/." monad)]]
+ lux/test)
+
+(context: "Maybe"
+ (let [(^open "&/.") &.apply
+ (^open "&/.") &.monad
+ (^open "&/.") (&.equivalence text.equivalence)]
+ ($_ seq
+ (test "Can compare Maybe values."
+ (and (&/= #.None #.None)
+ (&/= (#.Some "yolo") (#.Some "yolo"))
+ (not (&/= (#.Some "yolo") (#.Some "lol")))
+ (not (&/= (#.Some "yolo") #.None))))
+
+ (test "Monoid respects Maybe."
+ (and (&/= #.None &/identity)
+ (&/= (#.Some "yolo") (&/compose (#.Some "yolo") (#.Some "lol")))
+ (&/= (#.Some "yolo") (&/compose (#.Some "yolo") #.None))
+ (&/= (#.Some "lol") (&/compose #.None (#.Some "lol")))
+ (&/= #.None (: (Maybe Text) (&/compose #.None #.None)))))
+
+ (test "Functor respects Maybe."
+ (and (&/= #.None (&/map (text/compose "yolo") #.None))
+ (&/= (#.Some "yololol") (&/map (text/compose "yolo") (#.Some "lol")))))
+
+ (test "Apply respects Maybe."
+ (and (&/= (#.Some "yolo") (&/wrap "yolo"))
+ (&/= (#.Some "yololol")
+ (&/apply (&/wrap (text/compose "yolo")) (&/wrap "lol")))))
+
+ (test "Monad respects Maybe."
+ (&/= (#.Some "yololol")
+ (do &.monad
+ [f (wrap text/compose)
+ a (wrap "yolo")
+ b (wrap "lol")]
+ (wrap (f a b)))))
+
+ (do r.monad
+ [default r.nat
+ maybe r.nat]
+ (_.test "Can have defaults for Maybe values."
+ (and (is? default (maybe.default default
+ #.None))
+
+ (is? maybe (maybe.default default
+ (#.Some maybe))))))
+ )))
+
+(context: "Monad transformer"
+ (let [lift (&.lift io.monad)]
+ (test "Can add maybe functionality to any monad."
+ (|> (io.run (do (&.MaybeT io.monad)
+ [a (lift (io/wrap +123))
+ b (wrap +456)]
+ (wrap (i/+ a b))))
+ (case> (#.Some +579)
+ #1
+
+ _
+ #0)))))
diff --git a/stdlib/source/test/lux/data/name.lux b/stdlib/source/test/lux/data/name.lux
new file mode 100644
index 000000000..3855fe221
--- /dev/null
+++ b/stdlib/source/test/lux/data/name.lux
@@ -0,0 +1,73 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["&" name]
+ ["." text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: (gen-part size)
+ (-> Nat (r.Random Text))
+ (|> (r.unicode size) (r.filter (|>> (text.contains? ".") not))))
+
+(context: "Names"
+ (<| (times 100)
+ (do @
+ [## First Name
+ sizeM1 (|> r.nat (:: @ map (n/% 100)))
+ sizeN1 (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))
+ module1 (gen-part sizeM1)
+ short1 (gen-part sizeN1)
+ #let [name1 [module1 short1]]
+ ## Second Name
+ sizeM2 (|> r.nat (:: @ map (n/% 100)))
+ sizeN2 (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))
+ module2 (gen-part sizeM2)
+ short2 (gen-part sizeN2)
+ #let [name2 [module2 short2]]
+ #let [(^open "&/.") &.equivalence
+ (^open "&/.") &.codec]]
+ ($_ seq
+ (test "Can get the module & short parts of an name."
+ (and (is? module1 (&.module name1))
+ (is? short1 (&.short name1))))
+
+ (test "Can compare names for equivalence."
+ (and (&/= name1 name1)
+ (if (&/= name1 name2)
+ (and (text/= module1 module2)
+ (text/= short1 short2))
+ (or (not (text/= module1 module2))
+ (not (text/= short1 short2))))))
+
+ (test "Can encode names as text."
+ (|> name1
+ &/encode &/decode
+ (case> (#.Right dec-name) (&/= name1 dec-name)
+ _ #0)))
+
+ (test "Encoding an name without a module component results in text equal to the short of the name."
+ (if (text.empty? module1)
+ (text/= short1 (&/encode name1))
+ #1))
+ ))))
+
+(context: "Name-related macros."
+ (let [(^open "&/.") &.equivalence]
+ ($_ seq
+ (test "Can obtain Name from identifier."
+ (and (&/= ["lux" "yolo"] (name-of .yolo))
+ (&/= ["test/lux/data/name" "yolo"] (name-of ..yolo))
+ (&/= ["" "yolo"] (name-of yolo))
+ (&/= ["lux/test" "yolo"] (name-of lux/test.yolo))))
+
+ (test "Can obtain Name from tag."
+ (and (&/= ["lux" "yolo"] (name-of #.yolo))
+ (&/= ["test/lux/data/name" "yolo"] (name-of #..yolo))
+ (&/= ["" "yolo"] (name-of #yolo))
+ (&/= ["lux/test" "yolo"] (name-of #lux/test.yolo)))))))
diff --git a/stdlib/source/test/lux/data/number.lux b/stdlib/source/test/lux/data/number.lux
new file mode 100644
index 000000000..9d870ab08
--- /dev/null
+++ b/stdlib/source/test/lux/data/number.lux
@@ -0,0 +1,185 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ Monad do)]
+ pipe]
+ [data
+ number
+ [text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(do-template [category rand-gen <Equivalence> <Order>]
+ [(context: (format "[" category "] " "Equivalence & Order")
+ (<| (times 100)
+ (do @
+ [x rand-gen
+ y rand-gen]
+ (test "" (and (:: <Equivalence> = x x)
+ (or (:: <Equivalence> = x y)
+ (:: <Order> < y x)
+ (:: <Order> > y x)))))))]
+
+ ["Nat" r.nat equivalence order]
+ ["Int" r.int equivalence order]
+ ["Rev" r.rev equivalence order]
+ ["Frac" r.frac equivalence order]
+ )
+
+(do-template [category rand-gen <Number> <Order>]
+ [(context: (format "[" category "] " "Number")
+ (<| (times 100)
+ (do @
+ [x rand-gen
+ #let [(^open ".") <Number>
+ (^open ".") <Order>]]
+ (test "" (and (>= x (abs x))
+ ## abs(0.0) == 0.0 && negate(abs(0.0)) == -0.0
+ (or (text/= "Frac" category)
+ (not (= x (negate x))))
+ (= x (negate (negate x)))
+ ## There is loss of precision when multiplying
+ (or (text/= "Rev" category)
+ (= x (* (signum x)
+ (abs x)))))))))]
+
+ ["Nat" r.nat number order]
+ ["Int" r.int number order]
+ ["Rev" r.rev number order]
+ ["Frac" r.frac number order]
+ )
+
+(do-template [category rand-gen <Enum> <Number> <Order>]
+ [(context: (format "[" category "] " "Enum")
+ (<| (times 100)
+ (do @
+ [x rand-gen]
+ (test "" (let [(^open ".") <Number>
+ (^open ".") <Order>]
+ (and (> x
+ (:: <Enum> succ x))
+ (< x
+ (:: <Enum> pred x))
+
+ (= x
+ (|> x (:: <Enum> pred) (:: <Enum> succ)))
+ (= x
+ (|> x (:: <Enum> succ) (:: <Enum> pred)))
+ ))))))]
+
+ ["Nat" r.nat enum number order]
+ ["Int" r.int enum number order]
+ )
+
+(do-template [category rand-gen <Number> <Order> <Interval> <test>]
+ [(context: (format "[" category "] " "Interval")
+ (<| (times 100)
+ (do @
+ [x (|> rand-gen (r.filter <test>))
+ #let [(^open ".") <Number>
+ (^open ".") <Order>]]
+ (test "" (and (<= x (:: <Interval> bottom))
+ (>= x (:: <Interval> top)))))))]
+
+ ["Nat" r.nat number order interval (function (_ _) #1)]
+ ["Int" r.int number order interval (function (_ _) #1)]
+ ## Both min and max values will be positive (thus, greater than zero)
+ ["Rev" r.rev number order interval (function (_ _) #1)]
+ ["Frac" r.frac number order interval (f/> +0.0)]
+ )
+
+(do-template [category rand-gen <Number> <Order> <Monoid> <cap> <test>]
+ [(context: (format "[" category "] " "Monoid")
+ (<| (times 100)
+ (do @
+ [x (|> rand-gen (:: @ map (|>> (:: <Number> abs) <cap>)) (r.filter <test>))
+ #let [(^open ".") <Number>
+ (^open ".") <Order>
+ (^open ".") <Monoid>]]
+ (test "Composing with identity doesn't change the value."
+ (and (= x (compose identity x))
+ (= x (compose x identity))
+ (= identity (compose identity identity)))))))]
+
+ ["Nat/Add" r.nat number order add@monoid (n/% 1000) (function (_ _) #1)]
+ ["Nat/Mul" r.nat number order mul@monoid (n/% 1000) (function (_ _) #1)]
+ ["Nat/Min" r.nat number order min@monoid (n/% 1000) (function (_ _) #1)]
+ ["Nat/Max" r.nat number order max@monoid (n/% 1000) (function (_ _) #1)]
+ ["Int/Add" r.int number order add@monoid (i/% +1000) (function (_ _) #1)]
+ ["Int/Mul" r.int number order mul@monoid (i/% +1000) (function (_ _) #1)]
+ ["Int/Min" r.int number order min@monoid (i/% +1000) (function (_ _) #1)]
+ ["Int/Max" r.int number order max@monoid (i/% +1000) (function (_ _) #1)]
+ ["Rev/Add" r.rev number order add@monoid (r/% .125) (function (_ _) #1)]
+ ["Rev/Mul" r.rev number order mul@monoid (r/% .125) (function (_ _) #1)]
+ ["Rev/Min" r.rev number order min@monoid (r/% .125) (function (_ _) #1)]
+ ["Rev/Max" r.rev number order max@monoid (r/% .125) (function (_ _) #1)]
+ ["Frac/Add" r.frac number order add@monoid (f/% +1000.0) (f/> +0.0)]
+ ["Frac/Mul" r.frac number order mul@monoid (f/% +1000.0) (f/> +0.0)]
+ ["Frac/Min" r.frac number order min@monoid (f/% +1000.0) (f/> +0.0)]
+ ["Frac/Max" r.frac number order max@monoid (f/% +1000.0) (f/> +0.0)]
+ )
+
+(do-template [<category> <rand-gen> <Equivalence> <Codec>]
+ [(context: (format "[" <category> "] " "Alternative formats")
+ (<| (times 100)
+ (do @
+ [x <rand-gen>]
+ (test "Can encode/decode values."
+ (|> x
+ (:: <Codec> encode)
+ (:: <Codec> decode)
+ (case> (#.Right x')
+ (:: <Equivalence> = x x')
+
+ (#.Left _)
+ #0))))))]
+
+ ["Nat/Binary" r.nat equivalence binary@codec]
+ ["Nat/Octal" r.nat equivalence octal@codec]
+ ["Nat/Decimal" r.nat equivalence codec]
+ ["Nat/Hex" r.nat equivalence hex@codec]
+
+ ["Int/Binary" r.int equivalence binary@codec]
+ ["Int/Octal" r.int equivalence octal@codec]
+ ["Int/Decimal" r.int equivalence codec]
+ ["Int/Hex" r.int equivalence hex@codec]
+
+ ["Rev/Binary" r.rev equivalence binary@codec]
+ ["Rev/Octal" r.rev equivalence octal@codec]
+ ["Rev/Decimal" r.rev equivalence codec]
+ ["Rev/Hex" r.rev equivalence hex@codec]
+
+ ["Frac/Binary" r.frac equivalence binary@codec]
+ ["Frac/Octal" r.frac equivalence octal@codec]
+ ["Frac/Decimal" r.frac equivalence codec]
+ ["Frac/Hex" r.frac equivalence hex@codec]
+ )
+
+(context: "Can convert frac values to/from their bit patterns."
+ (<| (times 100)
+ (do @
+ [raw r.frac
+ factor (|> r.nat (:: @ map (|>> (n/% 1000) (n/max 1))))
+ #let [sample (|> factor .int int-to-frac (f/* raw))]]
+ (test "Can convert frac values to/from their bit patterns."
+ (|> sample frac-to-bits bits-to-frac (f/= sample))))))
+
+(context: "Macros for alternative numeric encodings."
+ ($_ seq
+ (test "Binary."
+ (and (n/= (bin "11001001") (bin "11_00_10_01"))
+ (i/= (bin "+11001001") (bin "+11_00_10_01"))
+ (r/= (bin ".11001001") (bin ".11_00_10_01"))
+ (f/= (bin "+1100.1001") (bin "+11_00.10_01"))))
+ (test "Octal."
+ (and (n/= (oct "615243") (oct "615_243"))
+ (i/= (oct "+615243") (oct "+615_243"))
+ (r/= (oct ".615243") (oct ".615_243"))
+ (f/= (oct "+6152.43") (oct "+615_2.43"))))
+ (test "Hexadecimal."
+ (and (n/= (hex "deadBEEF") (hex "dead_BEEF"))
+ (i/= (hex "+deadBEEF") (hex "+dead_BEEF"))
+ (r/= (hex ".deadBEEF") (hex ".dead_BEEF"))
+ (f/= (hex "+deadBE.EF") (hex "+dead_BE.EF"))))))
diff --git a/stdlib/source/test/lux/data/number/complex.lux b/stdlib/source/test/lux/data/number/complex.lux
new file mode 100644
index 000000000..850845296
--- /dev/null
+++ b/stdlib/source/test/lux/data/number/complex.lux
@@ -0,0 +1,201 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["." number ("frac/." number)
+ ["&" complex]]
+ [collection
+ ["." list ("list/." functor)]]]
+ ["." math
+ ["r" random]]]
+ lux/test)
+
+(def: margin-of-error Frac +1.0e-9)
+
+(def: (within? margin standard value)
+ (-> Frac &.Complex &.Complex Bit)
+ (let [real-dist (frac/abs (f/- (get@ #&.real standard)
+ (get@ #&.real value)))
+ imgn-dist (frac/abs (f/- (get@ #&.imaginary standard)
+ (get@ #&.imaginary value)))]
+ (and (f/< margin real-dist)
+ (f/< margin imgn-dist))))
+
+(def: gen-dim
+ (r.Random Frac)
+ (do r.monad
+ [factor (|> r.nat (:: @ map (|>> (n/% 1000) (n/max 1))))
+ measure (|> r.frac (r.filter (f/> +0.0)))]
+ (wrap (f/* (|> factor .int int-to-frac)
+ measure))))
+
+(def: gen-complex
+ (r.Random &.Complex)
+ (do r.monad
+ [real gen-dim
+ imaginary gen-dim]
+ (wrap (&.complex real imaginary))))
+
+(context: "Construction"
+ (<| (times 100)
+ (do @
+ [real gen-dim
+ imaginary gen-dim]
+ ($_ seq
+ (test "Can build and tear apart complex numbers"
+ (let [r+i (&.complex real imaginary)]
+ (and (f/= real (get@ #&.real r+i))
+ (f/= imaginary (get@ #&.imaginary r+i)))))
+
+ (test "If either the real part or the imaginary part is NaN, the composite is NaN."
+ (and (&.not-a-number? (&.complex number.not-a-number imaginary))
+ (&.not-a-number? (&.complex real number.not-a-number))))
+ ))))
+
+(context: "Absolute value"
+ (<| (times 100)
+ (do @
+ [real gen-dim
+ imaginary gen-dim]
+ ($_ seq
+ (test "Absolute value of complex >= absolute value of any of the parts."
+ (let [r+i (&.complex real imaginary)
+ abs (get@ #&.real (&.abs r+i))]
+ (and (f/>= (frac/abs real) abs)
+ (f/>= (frac/abs imaginary) abs))))
+
+ (test "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value."
+ (and (number.not-a-number? (get@ #&.real (&.abs (&.complex number.not-a-number imaginary))))
+ (number.not-a-number? (get@ #&.real (&.abs (&.complex real number.not-a-number))))))
+
+ (test "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value."
+ (and (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex number.positive-infinity imaginary))))
+ (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex real number.positive-infinity))))
+ (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex number.negative-infinity imaginary))))
+ (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex real number.negative-infinity))))))
+ ))))
+
+(context: "Addidion, substraction, multiplication and division"
+ (<| (times 100)
+ (do @
+ [x gen-complex
+ y gen-complex
+ factor gen-dim]
+ ($_ seq
+ (test "Adding 2 complex numbers is the same as adding their parts."
+ (let [z (&.+ y x)]
+ (and (&.= z
+ (&.complex (f/+ (get@ #&.real y)
+ (get@ #&.real x))
+ (f/+ (get@ #&.imaginary y)
+ (get@ #&.imaginary x)))))))
+
+ (test "Subtracting 2 complex numbers is the same as adding their parts."
+ (let [z (&.- y x)]
+ (and (&.= z
+ (&.complex (f/- (get@ #&.real y)
+ (get@ #&.real x))
+ (f/- (get@ #&.imaginary y)
+ (get@ #&.imaginary x)))))))
+
+ (test "Subtraction is the inverse of addition."
+ (and (|> x (&.+ y) (&.- y) (within? margin-of-error x))
+ (|> x (&.- y) (&.+ y) (within? margin-of-error x))))
+
+ (test "Division is the inverse of multiplication."
+ (|> x (&.* y) (&./ y) (within? margin-of-error x)))
+
+ (test "Scalar division is the inverse of scalar multiplication."
+ (|> x (&.*' factor) (&./' factor) (within? margin-of-error x)))
+
+ (test "If you subtract the remainder, all divisions must be exact."
+ (let [rem (&.% y x)
+ quotient (|> x (&.- rem) (&./ y))
+ floored (|> quotient
+ (update@ #&.real math.floor)
+ (update@ #&.imaginary math.floor))]
+ (within? +0.000000000001
+ x
+ (|> quotient (&.* y) (&.+ rem)))))
+ ))))
+
+(context: "Conjugate, reciprocal, signum, negation"
+ (<| (times 100)
+ (do @
+ [x gen-complex]
+ ($_ seq
+ (test "Conjugate has same real part as original, and opposite of imaginary part."
+ (let [cx (&.conjugate x)]
+ (and (f/= (get@ #&.real x)
+ (get@ #&.real cx))
+ (f/= (frac/negate (get@ #&.imaginary x))
+ (get@ #&.imaginary cx)))))
+
+ (test "The reciprocal functions is its own inverse."
+ (|> x &.reciprocal &.reciprocal (within? margin-of-error x)))
+
+ (test "x*(x^-1) = 1"
+ (|> x (&.* (&.reciprocal x)) (within? margin-of-error &.one)))
+
+ (test "Absolute value of signum is always root2(2), 1 or 0."
+ (let [signum-abs (|> x &.signum &.abs (get@ #&.real))]
+ (or (f/= +0.0 signum-abs)
+ (f/= +1.0 signum-abs)
+ (f/= (math.pow +0.5 +2.0) signum-abs))))
+
+ (test "Negation is its own inverse."
+ (let [there (&.negate x)
+ back-again (&.negate there)]
+ (and (not (&.= there x))
+ (&.= back-again x))))
+
+ (test "Negation doesn't change the absolute value."
+ (f/= (get@ #&.real (&.abs x))
+ (get@ #&.real (&.abs (&.negate x)))))
+ ))))
+
+(def: (trigonometric-symmetry forward backward angle)
+ (-> (-> &.Complex &.Complex) (-> &.Complex &.Complex) &.Complex Bit)
+ (let [normal (|> angle forward backward)]
+ (|> normal forward backward (within? margin-of-error normal))))
+
+(context: "Trigonometry"
+ (<| (seed 17274883666004960943)
+ ## (times 100)
+ (do @
+ [angle (|> gen-complex (:: @ map (|>> (update@ #&.real (f/% +1.0))
+ (update@ #&.imaginary (f/% +1.0)))))]
+ ($_ seq
+ (test "Arc-sine is the inverse of sine."
+ (trigonometric-symmetry &.sin &.asin angle))
+
+ (test "Arc-cosine is the inverse of cosine."
+ (trigonometric-symmetry &.cos &.acos angle))
+
+ (test "Arc-tangent is the inverse of tangent."
+ (trigonometric-symmetry &.tan &.atan angle))))))
+
+(context: "Power 2 and exponential/logarithm"
+ (<| (times 100)
+ (do @
+ [x gen-complex]
+ ($_ seq
+ (test "Root 2 is inverse of power 2."
+ (|> x (&.pow' +2.0) (&.pow' +0.5) (within? margin-of-error x)))
+
+ (test "Logarithm is inverse of exponentiation."
+ (|> x &.log &.exp (within? margin-of-error x)))
+ ))))
+
+(context: "Complex roots"
+ (<| (times 100)
+ (do @
+ [sample gen-complex
+ degree (|> r.nat (:: @ map (|>> (n/max 1) (n/% 5))))]
+ (test "Can calculate the N roots for any complex number."
+ (|> sample
+ (&.roots degree)
+ (list/map (&.pow' (|> degree .int int-to-frac)))
+ (list.every? (within? margin-of-error sample)))))))
diff --git a/stdlib/source/test/lux/data/number/i64.lux b/stdlib/source/test/lux/data/number/i64.lux
new file mode 100644
index 000000000..62de5e56e
--- /dev/null
+++ b/stdlib/source/test/lux/data/number/i64.lux
@@ -0,0 +1,75 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ do Monad)]]
+ [data
+ [number #*
+ ["&" i64]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Bitwise operations."
+ (<| (times 100)
+ (do @
+ [pattern r.nat
+ idx (:: @ map (n/% &.width) r.nat)]
+ ($_ seq
+ (test "Clearing and settings bits should alter the count."
+ (and (n/= (dec (&.count (&.set idx pattern)))
+ (&.count (&.clear idx pattern)))
+ (|> (&.count pattern)
+ (n/- (&.count (&.clear idx pattern)))
+ (n/<= 1))
+ (|> (&.count (&.set idx pattern))
+ (n/- (&.count pattern))
+ (n/<= 1))))
+ (test "Can query whether a bit is set."
+ (and (or (and (&.set? idx pattern)
+ (not (&.set? idx (&.clear idx pattern))))
+ (and (not (&.set? idx pattern))
+ (&.set? idx (&.set idx pattern))))
+
+ (or (and (&.set? idx pattern)
+ (not (&.set? idx (&.flip idx pattern))))
+ (and (not (&.set? idx pattern))
+ (&.set? idx (&.flip idx pattern))))))
+ (test "The negation of a bit pattern should have a complementary bit-count."
+ (n/= &.width
+ (n/+ (&.count pattern)
+ (&.count (&.not pattern)))))
+ (test "Can do simple binary logic."
+ (and (n/= 0
+ (&.and pattern
+ (&.not pattern)))
+ (n/= (&.not 0)
+ (&.or pattern
+ (&.not pattern)))
+ (n/= (&.not 0)
+ (&.xor pattern
+ (&.not pattern)))
+ (n/= 0
+ (&.xor pattern
+ pattern))))
+ (test "rotate-left and rotate-right are inverses of one another."
+ (and (|> pattern
+ (&.rotate-left idx)
+ (&.rotate-right idx)
+ (n/= pattern))
+ (|> pattern
+ (&.rotate-right idx)
+ (&.rotate-left idx)
+ (n/= pattern))))
+ (test "Rotate as many spaces as the bit-pattern's width leaves the pattern unchanged."
+ (and (|> pattern
+ (&.rotate-left &.width)
+ (n/= pattern))
+ (|> pattern
+ (&.rotate-right &.width)
+ (n/= pattern))))
+ (test "Shift right respect the sign of ints."
+ (let [value (.int pattern)]
+ (if (i/< +0 value)
+ (i/< +0 (&.arithmetic-right-shift idx value))
+ (i/>= +0 (&.arithmetic-right-shift idx value)))))
+ ))))
diff --git a/stdlib/source/test/lux/data/number/ratio.lux b/stdlib/source/test/lux/data/number/ratio.lux
new file mode 100644
index 000000000..63d1e5fc8
--- /dev/null
+++ b/stdlib/source/test/lux/data/number/ratio.lux
@@ -0,0 +1,116 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ [number
+ ["&" ratio ("&/." number)]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(def: gen-part
+ (r.Random Nat)
+ (|> r.nat (:: r.monad map (|>> (n/% 1000) (n/max 1)))))
+
+(def: gen-ratio
+ (r.Random &.Ratio)
+ (do r.monad
+ [numerator gen-part
+ denominator (|> gen-part
+ (r.filter (|>> (n/= 0) not))
+ (r.filter (|>> (n/= numerator) not)))]
+ (wrap (&.ratio numerator denominator))))
+
+(context: "Normalization"
+ (<| (times 100)
+ (do @
+ [denom1 gen-part
+ denom2 gen-part
+ sample gen-ratio]
+ ($_ seq
+ (test "All zeroes are the same."
+ (&.= (&.ratio 0 denom1)
+ (&.ratio 0 denom2)))
+
+ (test "All ratios are built normalized."
+ (|> sample
+ &.normalize
+ ("lux in-module" "lux/data/number/ratio")
+ (&.= sample)))
+ ))))
+
+(context: "Arithmetic"
+ (<| (times 100)
+ (do @
+ [x gen-ratio
+ y gen-ratio
+ #let [min (&.min x y)
+ max (&.max x y)]]
+ ($_ seq
+ (test "Addition and subtraction are opposites."
+ (and (|> max (&.- min) (&.+ min) (&.= max))
+ (|> max (&.+ min) (&.- min) (&.= max))))
+
+ (test "Multiplication and division are opposites."
+ (and (|> max (&./ min) (&.* min) (&.= max))
+ (|> max (&.* min) (&./ min) (&.= max))))
+
+ (test "Modulus by a larger ratio doesn't change the value."
+ (|> min (&.% max) (&.= min)))
+
+ (test "Modulus by a smaller ratio results in a value smaller than the limit."
+ (|> max (&.% min) (&.< min)))
+
+ (test "Can get the remainder of a division."
+ (let [remainder (&.% min max)
+ multiple (&.- remainder max)
+ factor (&./ min multiple)]
+ (and (|> factor (get@ #&.denominator) (n/= 1))
+ (|> factor (&.* min) (&.+ remainder) (&.= max)))))
+ ))))
+
+(context: "Negation, absolute value and signum"
+ (<| (times 100)
+ (do @
+ [sample gen-ratio]
+ ($_ seq
+ (test "Negation is it's own inverse."
+ (let [there (&/negate sample)
+ back-again (&/negate there)]
+ (and (not (&.= there sample))
+ (&.= back-again sample))))
+
+ (test "All ratios are already at their absolute value."
+ (|> sample &/abs (&.= sample)))
+
+ (test "Signum is the identity."
+ (|> sample (&.* (&/signum sample)) (&.= sample)))
+ ))))
+
+(context: "Order"
+ (<| (times 100)
+ (do @
+ [x gen-ratio
+ y gen-ratio]
+ ($_ seq
+ (test "Can compare ratios."
+ (and (or (&.<= y x)
+ (&.> y x))
+ (or (&.>= y x)
+ (&.< y x))))
+ ))))
+
+(context: "Codec"
+ (<| (times 100)
+ (do @
+ [sample gen-ratio
+ #let [(^open "&/.") &.codec]]
+ (test "Can encode/decode ratios."
+ (|> sample &/encode &/decode
+ (case> (#.Right output)
+ (&.= sample output)
+
+ _
+ #0))))))
diff --git a/stdlib/source/test/lux/data/product.lux b/stdlib/source/test/lux/data/product.lux
new file mode 100644
index 000000000..86db80d0e
--- /dev/null
+++ b/stdlib/source/test/lux/data/product.lux
@@ -0,0 +1,17 @@
+(.module:
+ [lux #*
+ [data
+ ["@" product]]]
+ lux/test)
+
+(context: "Products"
+ ($_ seq
+ (test "Can access the sides of a pair."
+ (and (i/= +1 (@.left [+1 +2]))
+ (i/= +2 (@.right [+1 +2]))))
+
+ (test "Can swap the sides of a pair."
+ (let [[_left _right] (@.swap [+1 +2])]
+ (and (i/= +2 _left)
+ (i/= +1 _right))))
+ ))
diff --git a/stdlib/source/test/lux/data/sum.lux b/stdlib/source/test/lux/data/sum.lux
new file mode 100644
index 000000000..d47922304
--- /dev/null
+++ b/stdlib/source/test/lux/data/sum.lux
@@ -0,0 +1,37 @@
+(.module:
+ [lux #*
+ [control
+ pipe]
+ [data
+ sum
+ ["." text]
+ [collection
+ ["." list]]]]
+ lux/test)
+
+(context: "Sum operations"
+ (let [(^open "List/.") (list.equivalence text.equivalence)]
+ ($_ seq
+ (test "Can inject values into Either."
+ (and (|> (left "Hello") (case> (0 "Hello") #1 _ #0))
+ (|> (right "World") (case> (1 "World") #1 _ #0))))
+
+ (test "Can discriminate eithers based on their cases."
+ (let [[_lefts _rights] (partition (: (List (| Text Text))
+ (list (0 "+0") (1 "+1") (0 "+2"))))]
+ (and (List/= _lefts
+ (lefts (: (List (| Text Text))
+ (list (0 "+0") (1 "+1") (0 "+2")))))
+
+ (List/= _rights
+ (rights (: (List (| Text Text))
+ (list (0 "+0") (1 "+1") (0 "+2"))))))))
+
+ (test "Can apply a function to an Either value depending on the case."
+ (and (i/= +10 (either (function (_ _) +10)
+ (function (_ _) +20)
+ (: (| Text Text) (0 ""))))
+ (i/= +20 (either (function (_ _) +10)
+ (function (_ _) +20)
+ (: (| Text Text) (1 ""))))))
+ )))
diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux
new file mode 100644
index 000000000..01cd2220d
--- /dev/null
+++ b/stdlib/source/test/lux/data/text.lux
@@ -0,0 +1,143 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["&" text
+ format]
+ [collection
+ ["." list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Size"
+ (<| (times 100)
+ (do @
+ [size (:: @ map (n/% 100) r.nat)
+ sample (r.unicode size)]
+ (test "" (or (and (n/= 0 size)
+ (&.empty? sample))
+ (n/= size (&.size sample)))))))
+
+(def: bounded-size
+ (r.Random Nat)
+ (|> r.nat
+ (:: r.monad map (|>> (n/% 20) (n/+ 1)))))
+
+(context: "Locations"
+ (<| (times 100)
+ (do @
+ [size bounded-size
+ idx (:: @ map (n/% size) r.nat)
+ sample (r.unicode size)]
+ (test "" (|> sample
+ (&.nth idx)
+ (case> (^multi (#.Some char)
+ [(&.from-code char) char]
+ [[(&.index-of char sample)
+ (&.last-index-of char sample)
+ (&.index-of' char idx sample)
+ (&.last-index-of' char idx sample)]
+ [(#.Some io) (#.Some lio)
+ (#.Some io') (#.Some lio')]])
+ (and (n/<= idx io)
+ (n/>= idx lio)
+
+ (n/= idx io')
+ (n/>= idx lio')
+
+ (&.contains? char sample))
+
+ _
+ #0
+ ))
+ ))))
+
+(context: "Text functions"
+ (<| (times 100)
+ (do @
+ [sizeL bounded-size
+ sizeR bounded-size
+ sampleL (r.unicode sizeL)
+ sampleR (r.unicode sizeR)
+ #let [sample (&.concat (list sampleL sampleR))
+ fake-sample (&.join-with " " (list sampleL sampleR))
+ dup-sample (&.join-with "" (list sampleL sampleR))
+ enclosed-sample (&.enclose [sampleR sampleR] sampleL)
+ (^open ".") &.equivalence]]
+ (test "" (and (not (= sample fake-sample))
+ (= sample dup-sample)
+ (&.starts-with? sampleL sample)
+ (&.ends-with? sampleR sample)
+ (= enclosed-sample
+ (&.enclose' sampleR sampleL))
+
+ (|> (&.split sizeL sample)
+ (case> (#.Right [_l _r])
+ (and (= sampleL _l)
+ (= sampleR _r)
+ (= sample (&.concat (list _l _r))))
+
+ _
+ #0))
+
+ (|> [(&.clip 0 sizeL sample)
+ (&.clip sizeL (&.size sample) sample)
+ (&.clip' sizeL sample)
+ (&.clip' 0 sample)]
+ (case> [(#.Right _l) (#.Right _r) (#.Right _r') (#.Right _f)]
+ (and (= sampleL _l)
+ (= sampleR _r)
+ (= _r _r')
+ (= sample _f))
+
+ _
+ #0))
+ )
+ ))))
+
+(context: "More text functions"
+ (<| (times 100)
+ (do @
+ [sizeP bounded-size
+ sizeL bounded-size
+ #let [## The wider unicode charset includes control characters that
+ ## can make text replacement work improperly.
+ ## Because of that, I restrict the charset.
+ normal-char-gen (|> r.nat (:: @ map (|>> (n/% 128) (n/max 1))))]
+ sep1 (r.text normal-char-gen 1)
+ sep2 (r.text normal-char-gen 1)
+ #let [part-gen (|> (r.text normal-char-gen sizeP)
+ (r.filter (|>> (&.contains? sep1) not)))]
+ parts (r.list sizeL part-gen)
+ #let [sample1 (&.concat (list.interpose sep1 parts))
+ sample2 (&.concat (list.interpose sep2 parts))
+ (^open "&/.") &.equivalence]]
+ ($_ seq
+ (test "Can split text through a separator."
+ (n/= (list.size parts)
+ (list.size (&.split-all-with sep1 sample1))))
+
+ (test "Can replace occurrences of a piece of text inside a larger text."
+ (&/= sample2
+ (&.replace-all sep1 sep2 sample1)))
+ ))))
+
+(context: "Structures"
+ (let [(^open "&/.") &.order]
+ ($_ seq
+ (test "" (&/< "bcd" "abc"))
+ (test "" (not (&/< "abc" "abc")))
+ (test "" (not (&/< "abc" "bcd")))
+ (test "" (&/<= "bcd" "abc"))
+ (test "" (&/<= "abc" "abc"))
+ (test "" (not (&/<= "abc" "bcd")))
+ (test "" (&/> "abc" "bcd"))
+ (test "" (not (&/> "abc" "abc")))
+ (test "" (not (&/> "bcd" "abc")))
+ (test "" (&/>= "abc" "bcd"))
+ (test "" (&/>= "abc" "abc"))
+ (test "" (not (&/>= "bcd" "abc")))
+ )))
diff --git a/stdlib/source/test/lux/data/text/format.lux b/stdlib/source/test/lux/data/text/format.lux
new file mode 100644
index 000000000..d3bbafe7e
--- /dev/null
+++ b/stdlib/source/test/lux/data/text/format.lux
@@ -0,0 +1,21 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]]
+ [data
+ ["." text
+ format]]]
+ lux/test)
+
+(context: "Formatters"
+ (let [(^open "&/.") text.equivalence]
+ ($_ seq
+ (test "Can format common values simply."
+ (and (&/= "#1" (%b #1))
+ (&/= "123" (%n 123))
+ (&/= "+123" (%i +123))
+ (&/= "+123.456" (%f +123.456))
+ (&/= ".5" (%r .5))
+ (&/= (format text.double-quote "YOLO" text.double-quote) (%t "YOLO"))
+ (&/= "User-id: +123 -- Active: #1" (format "User-id: " (%i +123) " -- Active: " (%b #1)))))
+ )))
diff --git a/stdlib/source/test/lux/data/text/lexer.lux b/stdlib/source/test/lux/data/text/lexer.lux
new file mode 100644
index 000000000..a1e52b64c
--- /dev/null
+++ b/stdlib/source/test/lux/data/text/lexer.lux
@@ -0,0 +1,205 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe
+ ["p" parser]]
+ [data
+ ["." error (#+ Error)]
+ ["." text ("text/." equivalence)
+ format
+ ["&" lexer]]
+ [collection
+ ["." list]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+## [Utils]
+(def: (should-fail input)
+ (All [a] (-> (Error a) Bit))
+ (case input
+ (#.Left _) #1
+ _ #0))
+
+(def: (should-passT test input)
+ (-> Text (Error Text) Bit)
+ (case input
+ (#.Right output)
+ (text/= test output)
+
+ _
+ #0))
+
+(def: (should-passL test input)
+ (-> (List Text) (Error (List Text)) Bit)
+ (let [(^open "list/.") (list.equivalence text.equivalence)]
+ (case input
+ (#.Right output)
+ (list/= test output)
+
+ _
+ #0)))
+
+(def: (should-passE test input)
+ (-> (Either Text Text) (Error (Either Text Text)) Bit)
+ (case input
+ (#.Right output)
+ (case [test output]
+ [(#.Left test) (#.Left output)]
+ (text/= test output)
+
+ [(#.Right test) (#.Right output)]
+ (text/= test output)
+
+ _
+ #0)
+
+ _
+ #0))
+
+## [Tests]
+(context: "End"
+ ($_ seq
+ (test "Can detect the end of the input."
+ (|> (&.run ""
+ &.end)
+ (case> (#.Right _) #1 _ #0)))
+
+ (test "Won't mistake non-empty text for no more input."
+ (|> (&.run "YOLO"
+ &.end)
+ (case> (#.Left _) #1 _ #0)))
+ ))
+
+(context: "Literals"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))
+ sample (r.unicode size)
+ non-sample (|> (r.unicode size)
+ (r.filter (|>> (text/= sample) not)))]
+ ($_ seq
+ (test "Can find literal text fragments."
+ (and (|> (&.run sample
+ (&.this sample))
+ (case> (#.Right []) #1 _ #0))
+ (|> (&.run non-sample
+ (&.this sample))
+ (case> (#.Left _) #1 _ #0))))
+ ))))
+
+(context: "Custom lexers"
+ ($_ seq
+ (test "Can lex anything"
+ (and (should-passT "A" (&.run "A"
+ &.any))
+ (should-fail (&.run ""
+ &.any))))
+
+ (test "Can lex characters ranges."
+ (and (should-passT "Y" (&.run "Y"
+ (&.range (char "X") (char "Z"))))
+ (should-fail (&.run "M"
+ (&.range (char "X") (char "Z"))))))
+
+ (test "Can lex upper-case and lower-case letters."
+ (and (should-passT "Y" (&.run "Y"
+ &.upper))
+ (should-fail (&.run "m"
+ &.upper))
+
+ (should-passT "y" (&.run "y"
+ &.lower))
+ (should-fail (&.run "M"
+ &.lower))))
+
+ (test "Can lex numbers."
+ (and (should-passT "1" (&.run "1"
+ &.decimal))
+ (should-fail (&.run " "
+ &.decimal))
+
+ (should-passT "7" (&.run "7"
+ &.octal))
+ (should-fail (&.run "8"
+ &.octal))
+
+ (should-passT "1" (&.run "1"
+ &.hexadecimal))
+ (should-passT "a" (&.run "a"
+ &.hexadecimal))
+ (should-passT "A" (&.run "A"
+ &.hexadecimal))
+ (should-fail (&.run " "
+ &.hexadecimal))
+ ))
+
+ (test "Can lex alphabetic characters."
+ (and (should-passT "A" (&.run "A"
+ &.alpha))
+ (should-passT "a" (&.run "a"
+ &.alpha))
+ (should-fail (&.run "1"
+ &.alpha))))
+
+ (test "Can lex alphanumeric characters."
+ (and (should-passT "A" (&.run "A"
+ &.alpha-num))
+ (should-passT "a" (&.run "a"
+ &.alpha-num))
+ (should-passT "1" (&.run "1"
+ &.alpha-num))
+ (should-fail (&.run " "
+ &.alpha-num))))
+
+ (test "Can lex white-space."
+ (and (should-passT " " (&.run " "
+ &.space))
+ (should-fail (&.run "8"
+ &.space))))
+ ))
+
+(context: "Combinators"
+ ($_ seq
+ (test "Can combine lexers sequentially."
+ (and (|> (&.run "YO"
+ (p.and &.any &.any))
+ (case> (#.Right ["Y" "O"]) #1
+ _ #0))
+ (should-fail (&.run "Y"
+ (p.and &.any &.any)))))
+
+ (test "Can create the opposite of a lexer."
+ (and (should-passT "a" (&.run "a"
+ (&.not (p.or &.decimal &.upper))))
+ (should-fail (&.run "A"
+ (&.not (p.or &.decimal &.upper))))))
+
+ (test "Can select from among a set of characters."
+ (and (should-passT "C" (&.run "C"
+ (&.one-of "ABC")))
+ (should-fail (&.run "D"
+ (&.one-of "ABC")))))
+
+ (test "Can avoid a set of characters."
+ (and (should-passT "D" (&.run "D"
+ (&.none-of "ABC")))
+ (should-fail (&.run "C"
+ (&.none-of "ABC")))))
+
+ (test "Can lex using arbitrary predicates."
+ (and (should-passT "D" (&.run "D"
+ (&.satisfies (function (_ c) #1))))
+ (should-fail (&.run "C"
+ (&.satisfies (function (_ c) #0))))))
+
+ (test "Can apply a lexer multiple times."
+ (and (should-passT "0123456789ABCDEF" (&.run "0123456789ABCDEF"
+ (&.many &.hexadecimal)))
+ (should-fail (&.run "yolo"
+ (&.many &.hexadecimal)))
+
+ (should-passT "" (&.run ""
+ (&.some &.hexadecimal)))))
+ ))
diff --git a/stdlib/source/test/lux/data/text/regex.lux b/stdlib/source/test/lux/data/text/regex.lux
new file mode 100644
index 000000000..f6bc7d098
--- /dev/null
+++ b/stdlib/source/test/lux/data/text/regex.lux
@@ -0,0 +1,286 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ pipe
+ ["p" parser]]
+ [data
+ [number (#+ hex)]
+ ["." text ("text/." equivalence)
+ format
+ ["." lexer (#+ Lexer)]
+ ["&" regex]]]
+ [math
+ ["r" random]]
+ [macro
+ ["s" syntax (#+ syntax:)]]]
+ lux/test)
+
+## [Utils]
+(def: (should-pass regex input)
+ (-> (Lexer Text) Text Bit)
+ (|> (lexer.run input regex)
+ (case> (#.Right parsed)
+ (text/= parsed input)
+
+ _
+ #0)))
+
+(def: (should-passT test regex input)
+ (-> Text (Lexer Text) Text Bit)
+ (|> (lexer.run input regex)
+ (case> (#.Right parsed)
+ (text/= test parsed)
+
+ _
+ #0)))
+
+(def: (should-fail regex input)
+ (All [a] (-> (Lexer a) Text Bit))
+ (|> (lexer.run input regex)
+ (case> (#.Left _) #1 _ #0)))
+
+(syntax: (should-check pattern regex input)
+ (wrap (list (` (|> (lexer.run (~ input) (~ regex))
+ (case> (^ (#.Right (~ pattern)))
+ #1
+
+ (~' _)
+ #0))))))
+
+## [Tests]
+(context: "Regular Expressions [Basics]"
+ (test "Can parse character literals."
+ (and (should-pass (&.regex "a") "a")
+ (should-fail (&.regex "a") ".")
+ (should-pass (&.regex "\.") ".")
+ (should-fail (&.regex "\.") "a"))))
+
+(context: "Regular Expressions [System character classes]"
+ ($_ seq
+ (test "Can parse anything."
+ (should-pass (&.regex ".") "a"))
+
+ (test "Can parse digits."
+ (and (should-pass (&.regex "\d") "0")
+ (should-fail (&.regex "\d") "m")))
+
+ (test "Can parse non digits."
+ (and (should-pass (&.regex "\D") "m")
+ (should-fail (&.regex "\D") "0")))
+
+ (test "Can parse white-space."
+ (and (should-pass (&.regex "\s") " ")
+ (should-fail (&.regex "\s") "m")))
+
+ (test "Can parse non white-space."
+ (and (should-pass (&.regex "\S") "m")
+ (should-fail (&.regex "\S") " ")))
+
+ (test "Can parse word characters."
+ (and (should-pass (&.regex "\w") "_")
+ (should-fail (&.regex "\w") "^")))
+
+ (test "Can parse non word characters."
+ (and (should-pass (&.regex "\W") ".")
+ (should-fail (&.regex "\W") "a")))
+ ))
+
+(context: "Regular Expressions [Special system character classes : Part 1]"
+ ($_ seq
+ (test "Can parse using special character classes."
+ (and (and (should-pass (&.regex "\p{Lower}") "m")
+ (should-fail (&.regex "\p{Lower}") "M"))
+
+ (and (should-pass (&.regex "\p{Upper}") "M")
+ (should-fail (&.regex "\p{Upper}") "m"))
+
+ (and (should-pass (&.regex "\p{Alpha}") "M")
+ (should-fail (&.regex "\p{Alpha}") "0"))
+
+ (and (should-pass (&.regex "\p{Digit}") "1")
+ (should-fail (&.regex "\p{Digit}") "n"))
+
+ (and (should-pass (&.regex "\p{Alnum}") "1")
+ (should-fail (&.regex "\p{Alnum}") "."))
+
+ (and (should-pass (&.regex "\p{Space}") " ")
+ (should-fail (&.regex "\p{Space}") "."))
+ ))
+ ))
+
+(context: "Regular Expressions [Special system character classes : Part 2]"
+ ($_ seq
+ (test "Can parse using special character classes."
+ (and (and (should-pass (&.regex "\p{HexDigit}") "a")
+ (should-fail (&.regex "\p{HexDigit}") "."))
+
+ (and (should-pass (&.regex "\p{OctDigit}") "6")
+ (should-fail (&.regex "\p{OctDigit}") "."))
+
+ (and (should-pass (&.regex "\p{Blank}") text.tab)
+ (should-fail (&.regex "\p{Blank}") "."))
+
+ (and (should-pass (&.regex "\p{ASCII}") text.tab)
+ (should-fail (&.regex "\p{ASCII}") (text.from-code (hex "1234"))))
+
+ (and (should-pass (&.regex "\p{Contrl}") (text.from-code (hex "12")))
+ (should-fail (&.regex "\p{Contrl}") "a"))
+
+ (and (should-pass (&.regex "\p{Punct}") "@")
+ (should-fail (&.regex "\p{Punct}") "a"))
+
+ (and (should-pass (&.regex "\p{Graph}") "@")
+ (should-fail (&.regex "\p{Graph}") " "))
+
+ (and (should-pass (&.regex "\p{Print}") (text.from-code (hex "20")))
+ (should-fail (&.regex "\p{Print}") (text.from-code (hex "1234"))))
+ ))
+ ))
+
+(context: "Regular Expressions [Custom character classes : Part 1]"
+ ($_ seq
+ (test "Can parse using custom character classes."
+ (and (should-pass (&.regex "[abc]") "a")
+ (should-fail (&.regex "[abc]") "m")))
+
+ (test "Can parse using character ranges."
+ (and (should-pass (&.regex "[a-z]") "a")
+ (should-pass (&.regex "[a-z]") "m")
+ (should-pass (&.regex "[a-z]") "z")))
+
+ (test "Can combine character ranges."
+ (and (should-pass (&.regex "[a-zA-Z]") "a")
+ (should-pass (&.regex "[a-zA-Z]") "m")
+ (should-pass (&.regex "[a-zA-Z]") "z")
+ (should-pass (&.regex "[a-zA-Z]") "A")
+ (should-pass (&.regex "[a-zA-Z]") "M")
+ (should-pass (&.regex "[a-zA-Z]") "Z")))
+ ))
+
+(context: "Regular Expressions [Custom character classes : Part 2]"
+ ($_ seq
+ (test "Can negate custom character classes."
+ (and (should-fail (&.regex "[^abc]") "a")
+ (should-pass (&.regex "[^abc]") "m")))
+
+ (test "Can negate character ranges.."
+ (and (should-fail (&.regex "[^a-z]") "a")
+ (should-pass (&.regex "[^a-z]") "0")))
+
+ (test "Can parse negate combinations of character ranges."
+ (and (should-fail (&.regex "[^a-zA-Z]") "a")
+ (should-pass (&.regex "[^a-zA-Z]") "0")))
+ ))
+
+(context: "Regular Expressions [Custom character classes : Part 3]"
+ ($_ seq
+ (test "Can make custom character classes more specific."
+ (and (let [RE (&.regex "[a-z&&[def]]")]
+ (and (should-fail RE "a")
+ (should-pass RE "d")))
+
+ (let [RE (&.regex "[a-z&&[^bc]]")]
+ (and (should-pass RE "a")
+ (should-fail RE "b")))
+
+ (let [RE (&.regex "[a-z&&[^m-p]]")]
+ (and (should-pass RE "a")
+ (should-fail RE "m")
+ (should-fail RE "p")))))
+ ))
+
+(context: "Regular Expressions [Reference]"
+ (let [number (&.regex "\d+")]
+ (test "Can build complex regexs by combining simpler ones."
+ (should-check ["809-345-6789" "809" "345" "6789"] (&.regex "(\@<number>)-(\@<number>)-(\@<number>)") "809-345-6789"))))
+
+(context: "Regular Expressions [Fuzzy Quantifiers]"
+ ($_ seq
+ (test "Can sequentially combine patterns."
+ (should-passT "aa" (&.regex "aa") "aa"))
+
+ (test "Can match patterns optionally."
+ (and (should-passT "a" (&.regex "a?") "a")
+ (should-passT "" (&.regex "a?") "")))
+
+ (test "Can match a pattern 0 or more times."
+ (and (should-passT "aaa" (&.regex "a*") "aaa")
+ (should-passT "" (&.regex "a*") "")))
+
+ (test "Can match a pattern 1 or more times."
+ (and (should-passT "aaa" (&.regex "a+") "aaa")
+ (should-passT "a" (&.regex "a+") "a")
+ (should-fail (&.regex "a+") "")))
+ ))
+
+(context: "Regular Expressions [Crisp Quantifiers]"
+ ($_ seq
+ (test "Can match a pattern N times."
+ (and (should-passT "aa" (&.regex "a{2}") "aa")
+ (should-passT "a" (&.regex "a{1}") "a")
+ (should-fail (&.regex "a{3}") "aa")))
+
+ (test "Can match a pattern at-least N times."
+ (and (should-passT "aa" (&.regex "a{1,}") "aa")
+ (should-passT "aa" (&.regex "a{2,}") "aa")
+ (should-fail (&.regex "a{3,}") "aa")))
+
+ (test "Can match a pattern at-most N times."
+ (and (should-passT "aa" (&.regex "a{,2}") "aa")
+ (should-passT "aa" (&.regex "a{,3}") "aa")))
+
+ (test "Can match a pattern between N and M times."
+ (and (should-passT "a" (&.regex "a{1,2}") "a")
+ (should-passT "aa" (&.regex "a{1,2}") "aa")))
+ ))
+
+(context: "Regular Expressions [Groups]"
+ ($_ seq
+ (test "Can extract groups of sub-matches specified in a pattern."
+ (and (should-check ["abc" "b"] (&.regex "a(.)c") "abc")
+ (should-check ["abbbbbc" "bbbbb"] (&.regex "a(b+)c") "abbbbbc")
+ (should-check ["809-345-6789" "809" "345" "6789"] (&.regex "(\d{3})-(\d{3})-(\d{4})") "809-345-6789")
+ (should-check ["809-345-6789" "809" "6789"] (&.regex "(\d{3})-(?:\d{3})-(\d{4})") "809-345-6789")
+ (should-check ["809-809-6789" "809" "6789"] (&.regex "(\d{3})-\0-(\d{4})") "809-809-6789")
+ (should-check ["809-809-6789" "809" "6789"] (&.regex "(?<code>\d{3})-\k<code>-(\d{4})") "809-809-6789")
+ (should-check ["809-809-6789-6789" "809" "6789"] (&.regex "(?<code>\d{3})-\k<code>-(\d{4})-\0") "809-809-6789-6789")))
+
+ (test "Can specify groups within groups."
+ (should-check ["809-345-6789" "809" ["345-6789" "345" "6789"]] (&.regex "(\d{3})-((\d{3})-(\d{4}))") "809-345-6789"))
+ ))
+
+(context: "Regular Expressions [Alternation]"
+ ($_ seq
+ (test "Can specify alternative patterns."
+ (and (should-check ["a" (0 [])] (&.regex "a|b") "a")
+ (should-check ["b" (1 [])] (&.regex "a|b") "b")
+ (should-fail (&.regex "a|b") "c")))
+
+ (test "Can have groups within alternations."
+ (and (should-check ["abc" (0 ["b" "c"])] (&.regex "a(.)(.)|b(.)(.)") "abc")
+ (should-check ["bcd" (1 ["c" "d"])] (&.regex "a(.)(.)|b(.)(.)") "bcd")
+ (should-fail (&.regex "a(.)(.)|b(.)(.)") "cde")
+
+ (should-check ["809-345-6789" (0 ["809" "345-6789" "345" "6789"])]
+ (&.regex "(\d{3})-((\d{3})-(\d{4}))|b(.)d")
+ "809-345-6789")))
+ ))
+
+(context: "Pattern-matching"
+ (<| (times 100)
+ (do @
+ [sample1 (r.unicode 3)
+ sample2 (r.unicode 3)
+ sample3 (r.unicode 4)]
+ (case (format sample1 "-" sample2 "-" sample3)
+ (&.^regex "(.{3})-(.{3})-(.{4})"
+ [_ match1 match2 match3])
+ (test "Can pattern-match using regular-expressions."
+ (and (text/= sample1 match1)
+ (text/= sample2 match2)
+ (text/= sample3 match3)))
+
+ _
+ (test "Cannot pattern-match using regular-expressions."
+ #0)))))
diff --git a/stdlib/source/test/lux/host.js.lux b/stdlib/source/test/lux/host.js.lux
new file mode 100644
index 000000000..faf9f6b5f
--- /dev/null
+++ b/stdlib/source/test/lux/host.js.lux
@@ -0,0 +1,28 @@
+(.module:
+ [lux #*
+ ["&" host]
+ [math ["r" random]]]
+ lux/test)
+
+(context: "JavaScript operations"
+ ($_ seq
+ (test "Null equals itself."
+ (is? (&.null) (&.null)))
+
+ (test "Undefined equals itself."
+ (is? (&.undef) (&.undef)))
+
+ (test "Can reference JavaScript objects."
+ (is? (&.ref "Math") (&.ref "Math")))
+
+ (test "Can create objects and access their fields."
+ (|> (&.object "foo" "BAR")
+ (&.get "foo" Text)
+ (is? "BAR")))
+
+ (test "Can call JavaScript functions"
+ (and (is? +124.0
+ (&.call! (&.ref "Math.ceil" &.Function) [+123.45] Frac))
+ (is? +124.0
+ (&.call! (&.ref "Math") "ceil" [+123.45] Frac))))
+ ))
diff --git a/stdlib/source/test/lux/host.jvm.lux b/stdlib/source/test/lux/host.jvm.lux
new file mode 100644
index 000000000..3de5e28d7
--- /dev/null
+++ b/stdlib/source/test/lux/host.jvm.lux
@@ -0,0 +1,134 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]
+ pipe]
+ [data
+ [text ("text/." equivalence)]]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ import: class: interface: object)]})
+
+(import: (java/util/concurrent/Callable a))
+
+(import: java/lang/Exception
+ (new [String]))
+
+(import: java/lang/Object)
+
+(import: (java/lang/Class a)
+ (getName [] String))
+
+(import: java/lang/System
+ (#static out java/io/PrintStream)
+ (#static currentTimeMillis [] #io long)
+ (#static getenv [String] #io #? String))
+
+(class: #final (TestClass A) [Runnable]
+ ## Fields
+ (#private foo boolean)
+ (#private bar A)
+ (#private baz java/lang/Object)
+ ## Methods
+ (#public [] (new {value A}) []
+ (exec (:= ::foo #1)
+ (:= ::bar value)
+ (:= ::baz "")
+ []))
+ (#public (virtual) java/lang/Object
+ "")
+ (#public #static (static) java/lang/Object
+ "")
+ (Runnable [] (run) void
+ []))
+
+(def: test-runnable
+ (object [] [Runnable]
+ []
+ (Runnable [] (run) void
+ [])))
+
+(def: test-callable
+ (object [a] [(Callable a)]
+ []
+ (Callable [] (call) a
+ (undefined))))
+
+(interface: TestInterface
+ ([] foo [boolean String] void #throws [Exception]))
+
+(def: conversions
+ Test
+ (do r.monad
+ [sample r.int]
+ (`` ($_ _.and
+ (~~ (do-template [<to> <from> <message>]
+ [(_.test <message>
+ (or (|> sample <to> <from> (i/= sample))
+ (let [capped-sample (|> sample <to> <from>)]
+ (|> capped-sample <to> <from> (i/= capped-sample)))))]
+
+ [/.long-to-byte /.byte-to-long "Can succesfully convert to/from byte."]
+ [/.long-to-short /.short-to-long "Can succesfully convert to/from short."]
+ [/.long-to-int /.int-to-long "Can succesfully convert to/from int."]
+ [/.long-to-float /.float-to-long "Can succesfully convert to/from float."]
+ [/.long-to-double /.double-to-long "Can succesfully convert to/from double."]
+ [(<| /.int-to-char /.long-to-int) (<| /.int-to-long /.char-to-int) "Can succesfully convert to/from char."]
+ ))
+ ))))
+
+(def: miscellaneous
+ Test
+ (do r.monad
+ [sample (r.ascii 1)]
+ ($_ _.and
+ (_.test "Can check if an object is of a certain class."
+ (and (case (/.check String sample) (#.Some _) true #.None false)
+ (case (/.check Long sample) (#.Some _) false #.None true)
+ (case (/.check Object sample) (#.Some _) true #.None false)
+ (case (/.check Object (/.null)) (#.Some _) false #.None true)))
+
+ (_.test "Can run code in a 'synchronized' block."
+ (/.synchronized sample #1))
+
+ (_.test "Can access Class instances."
+ (text/= "java.lang.Class" (Class::getName (/.class-for java/lang/Class))))
+
+ (_.test "Can check if a value is null."
+ (and (/.null? (/.null))
+ (not (/.null? sample))))
+
+ (_.test "Can safely convert nullable references into Maybe values."
+ (and (|> (: (Maybe Object) (/.??? (/.null)))
+ (case> #.None #1
+ _ #0))
+ (|> (: (Maybe Object) (/.??? sample))
+ (case> (#.Some _) #1
+ _ #0))))
+ )))
+
+(def: arrays
+ Test
+ (do r.monad
+ [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1))))
+ idx (|> r.nat (:: @ map (n/% size)))
+ value r.int]
+ ($_ _.and
+ (_.test "Can create arrays of some length."
+ (n/= size (/.array-length (/.array Long size))))
+
+ (_.test "Can set and get array values."
+ (let [arr (/.array Long size)]
+ (exec (/.array-write idx value arr)
+ (i/= value (/.array-read idx arr))))))))
+
+(def: #export test
+ ($_ _.and
+ (<| (_.context "Conversions.")
+ ..conversions)
+ (<| (_.context "Miscellaneous.")
+ ..miscellaneous)
+ (<| (_.context "Arrays.")
+ ..arrays)))
diff --git a/stdlib/source/test/lux/host/jvm.jvm.lux b/stdlib/source/test/lux/host/jvm.jvm.lux
new file mode 100644
index 000000000..d8224d214
--- /dev/null
+++ b/stdlib/source/test/lux/host/jvm.jvm.lux
@@ -0,0 +1,89 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ [concurrency
+ ["." atom]]
+ [security
+ ["!" capability]]]
+ [data
+ ["." error (#+ Error)]
+ ["." text
+ format]
+ [format
+ ["." binary]]
+ [collection
+ ["." dictionary]
+ ["." row]]]
+ ["." io (#+ IO)]
+ [world
+ ["." file (#+ File)]
+ [binary (#+ Binary)]]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ [/
+ ["/." loader (#+ Library)]
+ ["/." version]
+ ["/." name]
+ ["/." descriptor]
+ ["/." field]
+ ["/." class]
+ [modifier
+ ["/.M" inner]]]})
+
+(def: (write-class! name bytecode)
+ (-> Text Binary (IO Text))
+ (let [file-path (format name ".class")]
+ (do io.monad
+ [outcome (do (error.with-error @)
+ [file (: (IO (Error (File IO)))
+ (file.get-file io.monad file.system file-path))]
+ (!.use (:: file over-write) bytecode))]
+ (wrap (case outcome
+ (#error.Success definition)
+ (format "Wrote: " (%t file-path))
+
+ (#error.Failure error)
+ error)))))
+
+(def: class
+ Test
+ (do r.monad
+ [_ (wrap [])
+ #let [package "my.package"
+ name "MyClass"
+ full-name (format package "." name)
+ input (/class.class /version.v6_0 /class.public
+ (/name.internal "java.lang.Object")
+ (/name.internal full-name)
+ (list (/name.internal "java.io.Serializable")
+ (/name.internal "java.lang.Runnable"))
+ (list (/field.field /field.public "foo" /descriptor.long (row.row))
+ (/field.field /field.public "bar" /descriptor.double (row.row)))
+ (row.row)
+ (row.row))
+ bytecode (binary.write /class.format input)
+ loader (/loader.memory (/loader.new-library []))]]
+ ($_ _.and
+ (_.test "Can read a generated class."
+ (case (binary.read /class.format bytecode)
+ (#error.Success output)
+ (:: /class.equivalence = input output)
+
+ (#error.Failure error)
+ false))
+ (_.test "Can generate a class."
+ (case (/loader.define full-name bytecode loader)
+ (#error.Success definition)
+ true
+
+ (#error.Failure error)
+ false))
+ )))
+
+(def: #export test
+ Test
+ (<| (_.context "Class")
+ ..class))
diff --git a/stdlib/source/test/lux/io.lux b/stdlib/source/test/lux/io.lux
new file mode 100644
index 000000000..a14a240cb
--- /dev/null
+++ b/stdlib/source/test/lux/io.lux
@@ -0,0 +1,39 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ {[0 #test]
+ [/
+ [".T" functor (#+ Injection Comparison)]
+ [".T" apply]
+ [".T" monad]]}]
+ ["." function]
+ [math
+ ["r" random]]
+ ["_" test (#+ Test)]]
+ {1
+ ["." / (#+ IO)]})
+
+(def: injection
+ (Injection IO)
+ (|>> /.io))
+
+(def: comparison
+ (Comparison IO)
+ (function (_ == left right)
+ (== (/.run left) (/.run right))))
+
+(def: #export test
+ Test
+ (do r.monad
+ [sample r.nat
+ exit-code r.int]
+ ($_ _.and
+ (_.test "Can execute computations designated as I/O computations."
+ (n/= sample (/.run (/.io sample))))
+ (_.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))))
diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux
new file mode 100644
index 000000000..02baf04a5
--- /dev/null
+++ b/stdlib/source/test/lux/macro/code.lux
@@ -0,0 +1,36 @@
+(.module:
+ [lux #*
+ [io]
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ [number]
+ ["." text ("text/." equivalence)
+ format]]
+ [math
+ ["r" random]]
+ [macro
+ ["&" code]]]
+ lux/test)
+
+(context: "Code"
+ (with-expansions
+ [<tests> (do-template [<expr> <text>]
+ [(test (format "Can produce Code node: " <text>)
+ (and (text/= <text> (&.to-text <expr>))
+ (:: &.equivalence = <expr> <expr>)))]
+
+ [(&.bit #1) "#1"]
+ [(&.bit #0) "#0"]
+ [(&.int +123) "+123"]
+ [(&.frac +123.0) "+123.0"]
+ [(&.text "1234") (format text.double-quote "1234" text.double-quote)]
+ [(&.tag ["yolo" "lol"]) "#yolo.lol"]
+ [(&.identifier ["yolo" "lol"]) "yolo.lol"]
+ [(&.form (list (&.bit #1) (&.int +123))) "(#1 +123)"]
+ [(&.tuple (list (&.bit #1) (&.int +123))) "[#1 +123]"]
+ [(&.record (list [(&.bit #1) (&.int +123)])) "{#1 +123}"]
+ [(&.local-tag "lol") "#lol"]
+ [(&.local-identifier "lol") "lol"]
+ )]
+ ($_ seq <tests>)))
diff --git a/stdlib/source/test/lux/macro/poly/equivalence.lux b/stdlib/source/test/lux/macro/poly/equivalence.lux
new file mode 100644
index 000000000..3d943f6e6
--- /dev/null
+++ b/stdlib/source/test/lux/macro/poly/equivalence.lux
@@ -0,0 +1,71 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ [equivalence (#+ Equivalence)]]
+ [data
+ ["." bit]
+ ["." maybe]
+ [number ("int/." int-number)]
+ ["." text
+ format]
+ [collection
+ ["." list]]]
+ [math
+ ["r" random]]
+ ["." macro
+ [poly (#+ derived:)
+ ["&" equivalence]]]]
+ lux/test)
+
+(type: Variant
+ (#Case0 Bit)
+ (#Case1 Int)
+ (#Case2 Frac))
+
+(type: #rec Recursive
+ (#Number Frac)
+ (#Addition Frac Recursive))
+
+(type: Record
+ {#bit Bit
+ #int Int
+ #frac Frac
+ #text Text
+ #maybe (Maybe Int)
+ #list (List Int)
+ #variant Variant
+ #tuple [Int Frac Text]
+ #recursive Recursive})
+
+(def: gen-recursive
+ (r.Random Recursive)
+ (r.rec (function (_ gen-recursive)
+ (r.or r.frac
+ (r.and r.frac gen-recursive)))))
+
+(def: gen-record
+ (r.Random Record)
+ (do r.monad
+ [size (:: @ map (n/% 2) r.nat)
+ #let [gen-int (|> r.int (:: @ map (|>> int/abs (i/% +1_000_000))))]]
+ ($_ r.and
+ r.bit
+ gen-int
+ r.frac
+ (r.unicode size)
+ (r.maybe gen-int)
+ (r.list size gen-int)
+ ($_ r.or r.bit gen-int r.frac)
+ ($_ r.and gen-int r.frac (r.unicode size))
+ gen-recursive)))
+
+(derived: (&.Equivalence<?> Record))
+
+(context: "Equivalence polytypism"
+ (<| (times 100)
+ (do @
+ [sample gen-record
+ #let [(^open "&/.") ..equivalence]]
+ (test "Every instance equals itself."
+ (&/= sample sample)))))
diff --git a/stdlib/source/test/lux/macro/poly/functor.lux b/stdlib/source/test/lux/macro/poly/functor.lux
new file mode 100644
index 000000000..873259496
--- /dev/null
+++ b/stdlib/source/test/lux/macro/poly/functor.lux
@@ -0,0 +1,24 @@
+(.module:
+ [lux #*
+ [control
+ ["." state]]
+ [data
+ ["." identity]]
+ [macro
+ [poly (#+ derived:)
+ ["&" functor]]]]
+ lux/test)
+
+## [Utils]
+(derived: (&.Functor<?> .Maybe))
+
+(derived: (&.Functor<?> .List))
+
+(derived: (&.Functor<?> state.State))
+
+(derived: (&.Functor<?> identity.Identity))
+
+## [Tests]
+(context: "Functor polytypism."
+ (test "Can derive functors automatically."
+ #1))
diff --git a/stdlib/source/test/lux/macro/syntax.lux b/stdlib/source/test/lux/macro/syntax.lux
new file mode 100644
index 000000000..ff8c1c433
--- /dev/null
+++ b/stdlib/source/test/lux/macro/syntax.lux
@@ -0,0 +1,155 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]
+ [equivalence (#+ Equivalence)]
+ ["p" parser]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." error (#+ Error)]
+ ["." number]
+ ["." text
+ format]]
+ [math
+ ["r" random]]
+ ["." macro
+ ["." code]
+ ["s" syntax (#+ syntax: Syntax)]]]
+ lux/test)
+
+## [Utils]
+(def: (enforced? parser input)
+ (-> (Syntax []) (List Code) Bit)
+ (case (p.run input parser)
+ (#.Right [_ []])
+ #1
+
+ _
+ #0))
+
+(def: (found? parser input)
+ (-> (Syntax Bit) (List Code) Bit)
+ (case (p.run input parser)
+ (#.Right [_ #1])
+ #1
+
+ _
+ #0))
+
+(def: (equals? Equivalence<a> reference parser input)
+ (All [a] (-> (Equivalence a) a (Syntax a) (List Code) Bit))
+ (case (p.run input parser)
+ (#.Right [_ output])
+ (:: Equivalence<a> = reference output)
+
+ _
+ #0))
+
+(def: (fails? input)
+ (All [a] (-> (Error a) Bit))
+ (case input
+ (#.Left _)
+ #1
+
+ _
+ #0))
+
+(syntax: (match pattern input)
+ (wrap (list (` (case (~ input)
+ (^ (#.Right [(~' _) (~ pattern)]))
+ #1
+
+ (~' _)
+ #0)))))
+
+## [Tests]
+(context: "Simple value syntax."
+ (with-expansions
+ [<simple-tests> (do-template [<assertion> <value> <ctor> <Equivalence> <get>]
+ [(test <assertion>
+ (and (equals? <Equivalence> <value> <get> (list (<ctor> <value>)))
+ (found? (s.this? (<ctor> <value>)) (list (<ctor> <value>)))
+ (enforced? (s.this (<ctor> <value>)) (list (<ctor> <value>)))))]
+
+ ["Can parse Bit syntax." #1 code.bit bit.equivalence s.bit]
+ ["Can parse Nat syntax." 123 code.nat number.equivalence s.nat]
+ ["Can parse Int syntax." +123 code.int number.equivalence s.int]
+ ["Can parse Rev syntax." .123 code.rev number.equivalence s.rev]
+ ["Can parse Frac syntax." +123.0 code.frac number.equivalence s.frac]
+ ["Can parse Text syntax." text.new-line code.text text.equivalence s.text]
+ ["Can parse Identifier syntax." ["yolo" "lol"] code.identifier name.equivalence s.identifier]
+ ["Can parse Tag syntax." ["yolo" "lol"] code.tag name.equivalence s.tag]
+ )]
+ ($_ seq
+ <simple-tests>
+
+ (test "Can parse identifiers belonging to the current namespace."
+ (and (match "yolo"
+ (p.run (list (code.local-identifier "yolo"))
+ s.local-identifier))
+ (fails? (p.run (list (code.identifier ["yolo" "lol"]))
+ s.local-identifier))))
+
+ (test "Can parse tags belonging to the current namespace."
+ (and (match "yolo"
+ (p.run (list (code.local-tag "yolo"))
+ s.local-tag))
+ (fails? (p.run (list (code.tag ["yolo" "lol"]))
+ s.local-tag))))
+ )))
+
+(context: "Complex value syntax."
+ (with-expansions
+ [<group-tests> (do-template [<type> <parser> <ctor>]
+ [(test (format "Can parse " <type> " syntax.")
+ (and (match [#1 +123]
+ (p.run (list (<ctor> (list (code.bit #1) (code.int +123))))
+ (<parser> (p.and s.bit s.int))))
+ (match #1
+ (p.run (list (<ctor> (list (code.bit #1))))
+ (<parser> s.bit)))
+ (fails? (p.run (list (<ctor> (list (code.bit #1) (code.int +123))))
+ (<parser> s.bit)))
+ (match (#.Left #1)
+ (p.run (list (<ctor> (list (code.bit #1))))
+ (<parser> (p.or s.bit s.int))))
+ (match (#.Right +123)
+ (p.run (list (<ctor> (list (code.int +123))))
+ (<parser> (p.or s.bit s.int))))
+ (fails? (p.run (list (<ctor> (list (code.frac +123.0))))
+ (<parser> (p.or s.bit s.int))))))]
+
+ ["form" s.form code.form]
+ ["tuple" s.tuple code.tuple])]
+ ($_ seq
+ <group-tests>
+
+ (test "Can parse record syntax."
+ (match [#1 +123]
+ (p.run (list (code.record (list [(code.bit #1) (code.int +123)])))
+ (s.record (p.and s.bit s.int)))))
+ )))
+
+(context: "Combinators"
+ ($_ seq
+ (test "Can parse any Code."
+ (match [_ (#.Bit #1)]
+ (p.run (list (code.bit #1) (code.int +123))
+ s.any)))
+
+ (test "Can check whether the end has been reached."
+ (and (match #1
+ (p.run (list)
+ s.end?))
+ (match #0
+ (p.run (list (code.bit #1))
+ s.end?))))
+
+ (test "Can ensure the end has been reached."
+ (and (match []
+ (p.run (list)
+ s.end!))
+ (fails? (p.run (list (code.bit #1))
+ s.end!))))
+ ))
diff --git a/stdlib/source/test/lux/math.lux b/stdlib/source/test/lux/math.lux
new file mode 100644
index 000000000..002cdaa41
--- /dev/null
+++ b/stdlib/source/test/lux/math.lux
@@ -0,0 +1,125 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]]
+ [data
+ [bit ("bit/." equivalence)]
+ [number ("frac/." number)]]
+ ["&" math
+ infix
+ ["r" random]]]
+ lux/test)
+
+(def: (within? margin-of-error standard value)
+ (-> Frac Frac Frac Bit)
+ (f/< margin-of-error
+ (frac/abs (f/- standard value))))
+
+(def: margin Frac +0.0000001)
+
+(def: (trigonometric-symmetry forward backward angle)
+ (-> (-> Frac Frac) (-> Frac Frac) Frac Bit)
+ (let [normal (|> angle forward backward)]
+ (|> normal forward backward (within? margin normal))))
+
+(context: "Trigonometry"
+ (<| (times 100)
+ (do @
+ [angle (|> r.frac (:: @ map (f/* &.tau)))]
+ ($_ seq
+ (test "Sine and arc-sine are inverse functions."
+ (trigonometric-symmetry &.sin &.asin angle))
+
+ (test "Cosine and arc-cosine are inverse functions."
+ (trigonometric-symmetry &.cos &.acos angle))
+
+ (test "Tangent and arc-tangent are inverse functions."
+ (trigonometric-symmetry &.tan &.atan angle))
+ ))))
+
+(context: "Rounding"
+ (<| (times 100)
+ (do @
+ [sample (|> r.frac (:: @ map (f/* +1000.0)))]
+ ($_ seq
+ (test "The ceiling will be an integer value, and will be >= the original."
+ (let [ceil'd (&.ceil sample)]
+ (and (|> ceil'd frac-to-int int-to-frac (f/= ceil'd))
+ (f/>= sample ceil'd)
+ (f/<= +1.0 (f/- sample ceil'd)))))
+
+ (test "The floor will be an integer value, and will be <= the original."
+ (let [floor'd (&.floor sample)]
+ (and (|> floor'd frac-to-int int-to-frac (f/= floor'd))
+ (f/<= sample floor'd)
+ (f/<= +1.0 (f/- floor'd sample)))))
+
+ (test "The round will be an integer value, and will be < or > or = the original."
+ (let [round'd (&.round sample)]
+ (and (|> round'd frac-to-int int-to-frac (f/= round'd))
+ (f/<= +1.0 (frac/abs (f/- sample round'd))))))
+ ))))
+
+(context: "Exponentials and logarithms"
+ (<| (times 100)
+ (do @
+ [sample (|> r.frac (:: @ map (f/* +10.0)))]
+ (test "Logarithm is the inverse of exponential."
+ (|> sample &.exp &.log (within? +1.0e-15 sample))))))
+
+(context: "Greatest-Common-Divisor and Least-Common-Multiple"
+ (<| (times 100)
+ (do @
+ [#let [gen-nat (|> r.nat (:: @ map (|>> (n/% 1000) (n/max 1))))]
+ x gen-nat
+ y gen-nat]
+ ($_ seq
+ (test "GCD"
+ (let [gcd (&.n/gcd x y)]
+ (and (n/= 0 (n/% gcd x))
+ (n/= 0 (n/% gcd y))
+ (n/>= 1 gcd))))
+
+ (test "LCM"
+ (let [lcm (&.n/lcm x y)]
+ (and (n/= 0 (n/% x lcm))
+ (n/= 0 (n/% y lcm))
+ (n/<= (n/* x y) lcm))))
+ ))))
+
+(context: "Infix syntax"
+ (<| (times 100)
+ (do @
+ [x r.nat
+ y r.nat
+ z r.nat
+ theta r.frac
+ #let [top (|> x (n/max y) (n/max z))
+ bottom (|> x (n/min y) (n/min z))]]
+ ($_ seq
+ (test "Constant values don't change."
+ (n/= x
+ (infix x)))
+
+ (test "Can call binary functions."
+ (n/= (&.n/gcd y x)
+ (infix [x &.n/gcd y])))
+
+ (test "Can call unary functions."
+ (f/= (&.sin theta)
+ (infix [&.sin theta])))
+
+ (test "Can use regular syntax in the middle of infix code."
+ (n/= (&.n/gcd 450 (n/* 3 9))
+ (infix [(n/* 3 9) &.n/gcd 450])))
+
+ (test "Can use non-numerical functions/macros as operators."
+ (bit/= (and (n/< y x) (n/< z y))
+ (infix [[x n/< y] and [y n/< z]])))
+
+ (test "Can combine bit operations in special ways via special keywords."
+ (and (bit/= (and (n/< y x) (n/< z y))
+ (infix [#and x n/< y n/< z]))
+ (bit/= (and (n/< y x) (n/> z y))
+ (infix [#and x n/< y n/> z]))))
+ ))))
diff --git a/stdlib/source/test/lux/math/logic/continuous.lux b/stdlib/source/test/lux/math/logic/continuous.lux
new file mode 100644
index 000000000..b9db253f6
--- /dev/null
+++ b/stdlib/source/test/lux/math/logic/continuous.lux
@@ -0,0 +1,35 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [math
+ ["r" random]
+ [logic
+ ["&" continuous]]]]
+ lux/test)
+
+(context: "Operations"
+ (<| (times 100)
+ (do @
+ [left r.rev
+ right r.rev]
+ ($_ seq
+ (test "AND is the minimum."
+ (let [result (&.and left right)]
+ (and (r/<= left result)
+ (r/<= right result))))
+
+ (test "OR is the maximum."
+ (let [result (&.or left right)]
+ (and (r/>= left result)
+ (r/>= right result))))
+
+ (test "Double negation results in the original value."
+ (r/= left (&.not (&.not left))))
+
+ (test "Every value is equivalent to itself."
+ (and (r/>= left
+ (&.= left left))
+ (r/>= right
+ (&.= right right))))
+ ))))
diff --git a/stdlib/source/test/lux/math/logic/fuzzy.lux b/stdlib/source/test/lux/math/logic/fuzzy.lux
new file mode 100644
index 000000000..60223e8a3
--- /dev/null
+++ b/stdlib/source/test/lux/math/logic/fuzzy.lux
@@ -0,0 +1,183 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ [bit ("bit/." equivalence)]
+ ["." number]
+ [text
+ format]
+ [collection
+ ["." list]
+ ["." set]]]
+ [math
+ ["r" random]
+ [logic
+ ["&" fuzzy]
+ ["_" continuous]]]]
+ lux/test)
+
+(do-template [<desc> <hash> <gen> <triangle> <lt> <lte> <gt> <gte>]
+ [(context: (format "[" <desc> "] " "Triangles")
+ (<| (times 100)
+ (do @
+ [values (r.set <hash> 3 <gen>)
+ #let [[x y z] (case (set.to-list values)
+ (^ (list x y z))
+ [x y z]
+
+ _
+ (undefined))]
+ sample <gen>
+ #let [[bottom middle top] (case (list.sort <lt> (list x y z))
+ (^ (list bottom middle top))
+ [bottom middle top]
+
+ _
+ (undefined))
+ triangle (<triangle> x y z)]]
+ ($_ seq
+ (test "The middle value will always have maximum membership."
+ (r/= _.true (&.membership middle triangle)))
+
+ (test "Boundary values will always have 0 membership."
+ (and (r/= _.false (&.membership bottom triangle))
+ (r/= _.false (&.membership top triangle))))
+
+ (test "Values within range, will have membership > 0."
+ (bit/= (r/> _.false (&.membership sample triangle))
+ (and (<gt> bottom sample)
+ (<lt> top sample))))
+
+ (test "Values outside of range, will have membership = 0."
+ (bit/= (r/= _.false (&.membership sample triangle))
+ (or (<lte> bottom sample)
+ (<gte> top sample))))
+ ))))]
+
+ ["Rev" number.hash r.rev &.triangle r/< r/<= r/> r/>=]
+ )
+
+(do-template [<desc> <hash> <gen> <trapezoid> <lt> <lte> <gt> <gte>]
+ [(context: (format "[" <desc> "] " "Trapezoids")
+ (<| (times 100)
+ (do @
+ [values (r.set <hash> 4 <gen>)
+ #let [[w x y z] (case (set.to-list values)
+ (^ (list w x y z))
+ [w x y z]
+
+ _
+ (undefined))]
+ sample <gen>
+ #let [[bottom middle-bottom middle-top top] (case (list.sort <lt> (list w x y z))
+ (^ (list bottom middle-bottom middle-top top))
+ [bottom middle-bottom middle-top top]
+
+ _
+ (undefined))
+ trapezoid (<trapezoid> w x y z)]]
+ ($_ seq
+ (test "The middle values will always have maximum membership."
+ (and (r/= _.true (&.membership middle-bottom trapezoid))
+ (r/= _.true (&.membership middle-top trapezoid))))
+
+ (test "Boundary values will always have 0 membership."
+ (and (r/= _.false (&.membership bottom trapezoid))
+ (r/= _.false (&.membership top trapezoid))))
+
+ (test "Values within inner range will have membership = 1"
+ (bit/= (r/= _.true (&.membership sample trapezoid))
+ (and (<gte> middle-bottom sample)
+ (<lte> middle-top sample))))
+
+ (test "Values within range, will have membership > 0."
+ (bit/= (r/> _.false (&.membership sample trapezoid))
+ (and (<gt> bottom sample)
+ (<lt> top sample))))
+
+ (test "Values outside of range, will have membership = 0."
+ (bit/= (r/= _.false (&.membership sample trapezoid))
+ (or (<lte> bottom sample)
+ (<gte> top sample))))
+ ))))]
+
+ ["Rev" number.hash r.rev &.trapezoid r/< r/<= r/> r/>=]
+ )
+
+(def: gen-triangle
+ (r.Random (&.Fuzzy Rev))
+ (do r.monad
+ [x r.rev
+ y r.rev
+ z r.rev]
+ (wrap (&.triangle x y z))))
+
+(context: "Combinators"
+ (<| (times 100)
+ (do @
+ [left gen-triangle
+ right gen-triangle
+ sample r.rev]
+ ($_ seq
+ (test "Union membership as as high as membership in any of its members."
+ (let [combined (&.union left right)
+ combined-membership (&.membership sample combined)]
+ (and (r/>= (&.membership sample left)
+ combined-membership)
+ (r/>= (&.membership sample right)
+ combined-membership))))
+
+ (test "Intersection membership as as low as membership in any of its members."
+ (let [combined (&.intersection left right)
+ combined-membership (&.membership sample combined)]
+ (and (r/<= (&.membership sample left)
+ combined-membership)
+ (r/<= (&.membership sample right)
+ combined-membership))))
+
+ (test "Complement membership is the opposite of normal membership."
+ (r/= (&.membership sample left)
+ (_.not (&.membership sample (&.complement left)))))
+
+ (test "Membership in the difference will never be higher than in the set being subtracted."
+ (bit/= (r/> (&.membership sample right)
+ (&.membership sample left))
+ (r/< (&.membership sample left)
+ (&.membership sample (&.difference left right)))))
+ ))))
+
+(context: "From predicates and sets"
+ (<| (times 100)
+ (do @
+ [#let [set-10 (set.from-list number.hash (list.n/range 0 10))]
+ sample (|> r.nat (:: @ map (n/% 20)))]
+ ($_ seq
+ (test (format "Values that satisfy a predicate have membership = 1."
+ "Values that don't have membership = 0.")
+ (bit/= (r/= _.true (&.membership sample (&.from-predicate n/even?)))
+ (n/even? sample)))
+
+ (test (format "Values that belong to a set have membership = 1."
+ "Values that don't have membership = 0.")
+ (bit/= (r/= _.true (&.membership sample (&.from-set set-10)))
+ (set.member? set-10 sample)))
+ ))))
+
+(context: "Thresholds"
+ (<| (times 100)
+ (do @
+ [fuzzy gen-triangle
+ sample r.rev
+ threshold r.rev
+ #let [vip-fuzzy (&.cut threshold fuzzy)
+ member? (&.to-predicate threshold fuzzy)]]
+ ($_ seq
+ (test "Can increase the threshold of membership of a fuzzy set."
+ (bit/= (r/> _.false (&.membership sample vip-fuzzy))
+ (r/> threshold (&.membership sample fuzzy))))
+
+ (test "Can turn fuzzy sets into predicates through a threshold."
+ (bit/= (member? sample)
+ (r/> threshold (&.membership sample fuzzy))))
+ ))))
diff --git a/stdlib/source/test/lux/math/modular.lux b/stdlib/source/test/lux/math/modular.lux
new file mode 100644
index 000000000..b5ff0e40b
--- /dev/null
+++ b/stdlib/source/test/lux/math/modular.lux
@@ -0,0 +1,150 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ ["." product]
+ [bit ("bit/." equivalence)]
+ ["." error]
+ [text
+ format]]
+ [math
+ ["r" random]
+ ["/" modular]]
+ [type ("type/." equivalence)]]
+ lux/test)
+
+(def: %3 (/.modulus +3))
+(`` (type: Mod3 (~~ (:of %3))))
+
+(def: modulusR
+ (r.Random Int)
+ (|> r.int
+ (:: r.monad map (i/% +1000))
+ (r.filter (|>> (i/= +0) not))))
+
+(def: valueR
+ (r.Random Int)
+ (|> r.int (:: r.monad map (i/% +1000))))
+
+(def: (modR modulus)
+ (All [m] (-> (/.Modulus m) (r.Random [Int (/.Mod m)])))
+ (do r.monad
+ [raw valueR]
+ (wrap [raw (/.mod modulus raw)])))
+
+(def: value
+ (All [m] (-> (/.Mod m) Int))
+ (|>> /.un-mod product.left))
+
+(def: (comparison m/? i/?)
+ (All [m]
+ (-> (-> (/.Mod m) (/.Mod m) Bit)
+ (-> Int Int Bit)
+ (-> (/.Mod m) (/.Mod m) Bit)))
+ (function (_ param subject)
+ (bit/= (m/? param subject)
+ (i/? (value param)
+ (value subject)))))
+
+(def: (arithmetic modulus m/! i/!)
+ (All [m]
+ (-> (/.Modulus m)
+ (-> (/.Mod m) (/.Mod m) (/.Mod m))
+ (-> Int Int Int)
+ (-> (/.Mod m) (/.Mod m) Bit)))
+ (function (_ param subject)
+ (|> (i/! (value param)
+ (value subject))
+ (/.mod modulus)
+ (/.m/= (m/! param subject)))))
+
+(context: "Modular arithmetic."
+ (<| (times 100)
+ (do @
+ [_normalM modulusR
+ _alternativeM (|> modulusR (r.filter (|>> (i/= _normalM) not)))
+ #let [normalM (|> _normalM /.from-int error.assume)
+ alternativeM (|> _alternativeM /.from-int error.assume)]
+ [_param param] (modR normalM)
+ [_subject subject] (modR normalM)
+ #let [copyM (|> normalM /.to-int /.from-int error.assume)]]
+ ($_ seq
+ (test "Every modulus has a unique type, even if the numeric value is the same as another."
+ (and (type/= (:of normalM)
+ (:of normalM))
+ (not (type/= (:of normalM)
+ (:of alternativeM)))
+ (not (type/= (:of normalM)
+ (:of copyM)))))
+
+ (test "Can extract the original integer from the modulus."
+ (i/= _normalM
+ (/.to-int normalM)))
+
+ (test "Can compare mod'ed values."
+ (and (/.m/= subject subject)
+ ((comparison /.m/= i/=) param subject)
+ ((comparison /.m/< i/<) param subject)
+ ((comparison /.m/<= i/<=) param subject)
+ ((comparison /.m/> i/>) param subject)
+ ((comparison /.m/>= i/>=) param subject)))
+
+ (test "Mod'ed values are ordered."
+ (and (bit/= (/.m/< param subject)
+ (not (/.m/>= param subject)))
+ (bit/= (/.m/> param subject)
+ (not (/.m/<= param subject)))
+ (bit/= (/.m/= param subject)
+ (not (or (/.m/< param subject)
+ (/.m/> param subject))))))
+
+ (test "Can do arithmetic."
+ (and ((arithmetic normalM /.m/+ i/+) param subject)
+ ((arithmetic normalM /.m/- i/-) param subject)
+ ((arithmetic normalM /.m/* i/*) param subject)))
+
+ (test "Can sometimes find multiplicative inverse."
+ (case (/.inverse subject)
+ (#.Some subject^-1)
+ (|> subject
+ (/.m/* subject^-1)
+ (/.m/= (/.mod normalM +1)))
+
+ #.None
+ #1))
+
+ (test "Can encode/decode to text."
+ (let [(^open "mod/.") (/.codec normalM)]
+ (case (|> subject mod/encode mod/decode)
+ (#error.Success output)
+ (/.m/= subject output)
+
+ (#error.Failure error)
+ #0)))
+
+ (test "Can equalize 2 moduli if they are equal."
+ (case (/.equalize (/.mod normalM _subject)
+ (/.mod copyM _param))
+ (#error.Success paramC)
+ (/.m/= param paramC)
+
+ (#error.Failure error)
+ #0))
+
+ (test "Cannot equalize 2 moduli if they are the different."
+ (case (/.equalize (/.mod normalM _subject)
+ (/.mod alternativeM _param))
+ (#error.Success paramA)
+ #0
+
+ (#error.Failure error)
+ #1))
+
+ (test "All numbers are congruent to themselves."
+ (/.congruent? normalM _subject _subject))
+
+ (test "If 2 numbers are congruent under a modulus, then they must also be equal under the same modulus."
+ (bit/= (/.congruent? normalM _param _subject)
+ (/.m/= param subject)))
+ ))))
diff --git a/stdlib/source/test/lux/math/random.lux b/stdlib/source/test/lux/math/random.lux
new file mode 100644
index 000000000..acc161cc4
--- /dev/null
+++ b/stdlib/source/test/lux/math/random.lux
@@ -0,0 +1,49 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["." number]
+ [collection
+ ["." list]
+ ["." row]
+ ["." array]
+ ["." queue]
+ ["." stack]
+ ["." set]
+ ["dict" dictionary]]]
+ [math
+ ["r" random]]]
+ lux/test)
+
+(context: "Random."
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))
+ _list (r.list size r.nat)
+ _row (r.row size r.nat)
+ _array (r.array size r.nat)
+ _queue (r.queue size r.nat)
+ _stack (r.stack size r.nat)
+ _set (r.set number.hash size r.nat)
+ _dict (r.dictionary number.hash size r.nat r.nat)
+ top r.nat
+ filtered (|> r.nat (r.filter (n/<= top)))]
+ ($_ seq
+ (test "Can produce lists."
+ (n/= size (list.size _list)))
+ (test "Can produce rows."
+ (n/= size (row.size _row)))
+ (test "Can produce arrays."
+ (n/= size (array.size _array)))
+ (test "Can produce queues."
+ (n/= size (queue.size _queue)))
+ (test "Can produce stacks."
+ (n/= size (stack.size _stack)))
+ (test "Can produce sets."
+ (n/= size (set.size _set)))
+ (test "Can produce dicts."
+ (n/= size (dict.size _dict)))
+ (test "Can filter values."
+ (n/<= top filtered))
+ ))))
diff --git a/stdlib/source/test/lux/time/date.lux b/stdlib/source/test/lux/time/date.lux
new file mode 100644
index 000000000..d89ccccc8
--- /dev/null
+++ b/stdlib/source/test/lux/time/date.lux
@@ -0,0 +1,147 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ Monad do)]
+ pipe]
+ [data
+ ["." error]]
+ [math
+ ["r" random ("random/." monad)]]
+ [time
+ ["@." instant]
+ ["@" date]]]
+ lux/test
+ [//
+ ["_." instant]])
+
+(def: month
+ (r.Random @.Month)
+ (r.either (r.either (r.either (random/wrap #@.January)
+ (r.either (random/wrap #@.February)
+ (random/wrap #@.March)))
+ (r.either (random/wrap #@.April)
+ (r.either (random/wrap #@.May)
+ (random/wrap #@.June))))
+ (r.either (r.either (random/wrap #@.July)
+ (r.either (random/wrap #@.August)
+ (random/wrap #@.September)))
+ (r.either (random/wrap #@.October)
+ (r.either (random/wrap #@.November)
+ (random/wrap #@.December))))))
+
+(context: "(Month) Equivalence."
+ (<| (times 100)
+ (do @
+ [sample month
+ #let [(^open "@/.") @.equivalence]]
+ (test "Every value equals itself."
+ (@/= sample sample)))))
+
+(context: "(Month) Order."
+ (<| (times 100)
+ (do @
+ [reference month
+ sample month
+ #let [(^open "@/.") @.order]]
+ (test "Valid Order."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))))
+
+(context: "(Month) Enum."
+ (<| (times 100)
+ (do @
+ [sample month
+ #let [(^open "@/.") @.enum]]
+ (test "Valid Enum."
+ (and (not (@/= (@/succ sample)
+ sample))
+ (not (@/= (@/pred sample)
+ sample))
+ (|> sample @/succ @/pred (@/= sample))
+ (|> sample @/pred @/succ (@/= sample)))))))
+
+(def: day
+ (r.Random @.Day)
+ (r.either (r.either (r.either (random/wrap #@.Sunday)
+ (random/wrap #@.Monday))
+ (r.either (random/wrap #@.Tuesday)
+ (random/wrap #@.Wednesday)))
+ (r.either (r.either (random/wrap #@.Thursday)
+ (random/wrap #@.Friday))
+ (random/wrap #@.Saturday))))
+
+(context: "(Day) Equivalence."
+ (<| (times 100)
+ (do @
+ [sample day
+ #let [(^open "@/.") @.equivalence]]
+ (test "Every value equals itself."
+ (@/= sample sample)))))
+
+(context: "(Day) Order."
+ (<| (times 100)
+ (do @
+ [reference day
+ sample day
+ #let [(^open "@/.") @.order]]
+ (test "Valid Order."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))))
+
+(context: "(Day) Enum."
+ (<| (times 100)
+ (do @
+ [sample day
+ #let [(^open "@/.") @.enum]]
+ (test "Valid Enum."
+ (and (not (@/= (@/succ sample)
+ sample))
+ (not (@/= (@/pred sample)
+ sample))
+ (|> sample @/succ @/pred (@/= sample))
+ (|> sample @/pred @/succ (@/= sample)))))))
+
+(def: #export date
+ (r.Random @.Date)
+ (|> _instant.instant (:: r.monad map @instant.date)))
+
+(context: "(Date) Equivalence."
+ (<| (times 100)
+ (do @
+ [sample date
+ #let [(^open "@/.") @.equivalence]]
+ (test "Every value equals itself."
+ (@/= sample sample)))))
+
+(context: "(Date) Order."
+ (<| (times 100)
+ (do @
+ [reference date
+ sample date
+ #let [(^open "@/.") @.order]]
+ (test "Valid Order."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))))
+
+(context: "(Date) Codec"
+ (<| (seed 6623983470548808292)
+ ## (times 100)
+ (do @
+ [sample date
+ #let [(^open "@/.") @.equivalence
+ (^open "@/.") @.codec]]
+ (test "Can encode/decode dates."
+ (|> sample
+ @/encode
+ @/decode
+ (case> (#error.Success decoded)
+ (@/= sample decoded)
+
+ (#error.Failure error)
+ #0))))))
diff --git a/stdlib/source/test/lux/time/duration.lux b/stdlib/source/test/lux/time/duration.lux
new file mode 100644
index 000000000..3aba23203
--- /dev/null
+++ b/stdlib/source/test/lux/time/duration.lux
@@ -0,0 +1,60 @@
+(.module:
+ [lux #*
+ [io]
+ [control
+ [monad (#+ do Monad)]]
+ [data
+ ["E" error]]
+ [math
+ ["r" random]]
+ [time
+ ["@" duration]]]
+ lux/test)
+
+(def: #export duration
+ (r.Random @.Duration)
+ (|> r.int (:: r.monad map @.from-millis)))
+
+(context: "Conversion."
+ (<| (times 100)
+ (do @
+ [millis r.int]
+ (test "Can convert from/to milliseconds."
+ (|> millis @.from-millis @.to-millis (i/= millis))))))
+
+(context: "Equivalence."
+ (<| (times 100)
+ (do @
+ [sample duration
+ #let [(^open "@/.") @.equivalence]]
+ (test "Every duration equals itself."
+ (@/= sample sample)))))
+
+(context: "Order."
+ (<| (times 100)
+ (do @
+ [reference duration
+ sample duration
+ #let [(^open "@/.") @.order]]
+ (test "Can compare times."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))))
+
+(context: "Arithmetic."
+ (<| (times 100)
+ (do @
+ [sample (|> duration (:: @ map (@.frame @.day)))
+ frame duration
+ factor (|> r.int (:: @ map (|>> (i/% +10) (i/max +1))))
+ #let [(^open "@/.") @.order]]
+ ($_ seq
+ (test "Can scale a duration."
+ (|> sample (@.scale-up factor) (@.query sample) (i/= factor)))
+ (test "Scaling a duration by one does not change it."
+ (|> sample (@.scale-up +1) (@/= sample)))
+ (test "Merging with the empty duration changes nothing."
+ (|> sample (@.merge @.empty) (@/= sample)))
+ (test "Merging a duration with it's opposite yields an empty duration."
+ (|> sample (@.merge (@.scale-up -1 sample)) (@/= @.empty)))))))
diff --git a/stdlib/source/test/lux/time/instant.lux b/stdlib/source/test/lux/time/instant.lux
new file mode 100644
index 000000000..c9d7aad55
--- /dev/null
+++ b/stdlib/source/test/lux/time/instant.lux
@@ -0,0 +1,99 @@
+(.module:
+ [lux #*
+ [io]
+ [control
+ [monad (#+ do Monad)]
+ pipe]
+ [data
+ ["." text
+ format]
+ [error]]
+ [math
+ ["r" random]]
+ [time
+ ["@" instant]
+ ["@d" duration]
+ ["@date" date]]]
+ lux/test
+ [//
+ ["_." duration]])
+
+(def: boundary Int +99_999_999_999_999)
+
+(def: #export instant
+ (r.Random @.Instant)
+ (|> r.int (:: r.monad map (|>> (i/% boundary) @.from-millis))))
+
+(context: "Conversion."
+ (<| (times 100)
+ (do @
+ [millis r.int]
+ (test "Can convert from/to milliseconds."
+ (|> millis @.from-millis @.to-millis (i/= millis))))))
+
+(context: "Equivalence."
+ (<| (times 100)
+ (do @
+ [sample instant
+ #let [(^open "@/.") @.equivalence]]
+ (test "Every instant equals itself."
+ (@/= sample sample)))))
+
+(context: "Order"
+ (<| (times 100)
+ (do @
+ [reference instant
+ sample instant
+ #let [(^open "@/.") @.order]]
+ (test "Can compare instants."
+ (and (or (@/< reference sample)
+ (@/>= reference sample))
+ (or (@/> reference sample)
+ (@/<= reference sample)))))))
+
+(context: "Enum"
+ (<| (times 100)
+ (do @
+ [sample instant
+ #let [(^open "@/.") @.enum]]
+ (test "Valid Enum."
+ (and (not (@/= (@/succ sample)
+ sample))
+ (not (@/= (@/pred sample)
+ sample))
+ (|> sample @/succ @/pred (@/= sample))
+ (|> sample @/pred @/succ (@/= sample)))))))
+
+(context: "Arithmetic"
+ (<| (times 100)
+ (do @
+ [sample instant
+ span _duration.duration
+ #let [(^open "@/.") @.equivalence
+ (^open "@d/.") @d.equivalence]]
+ ($_ seq
+ (test "The span of a instant and itself has an empty duration."
+ (|> sample (@.span sample) (@d/= @d.empty)))
+ (test "Can shift a instant by a duration."
+ (|> sample (@.shift span) (@.span sample) (@d/= span)))
+ (test "Can obtain the time-span between the epoch and an instant."
+ (|> sample @.relative @.absolute (@/= sample)))
+ (test "All instants are relative to the epoch."
+ (|> @.epoch (@.shift (@.relative sample)) (@/= sample)))))))
+
+## (context: "Codec"
+## (<| (seed 9863552679229274604)
+## ## (times 100)
+## (do @
+## [sample instant
+## #let [(^open "@/.") @.equivalence
+## (^open "@/.") @.codec]]
+## (test "Can encode/decode instants."
+## (|> sample
+## @/encode
+## @/decode
+## (case> (#error.Success decoded)
+## (@/= sample decoded)
+
+## (#error.Failure error)
+## #0))))))
diff --git a/stdlib/source/test/lux/type.lux b/stdlib/source/test/lux/type.lux
new file mode 100644
index 000000000..b4796911a
--- /dev/null
+++ b/stdlib/source/test/lux/type.lux
@@ -0,0 +1,168 @@
+(.module:
+ [lux #*
+ [control
+ ["M" monad (#+ do Monad)]
+ pipe]
+ [data
+ ["." maybe]
+ [text
+ format]
+ [collection
+ ["." list]]]
+ [math
+ ["r" random]]
+ ["&" type]]
+ lux/test)
+
+## [Utils]
+(def: #export gen-short
+ (r.Random Text)
+ (do r.monad
+ [size (|> r.nat (:: @ map (n/% 10)))]
+ (r.unicode size)))
+
+(def: #export gen-name
+ (r.Random Name)
+ (r.and gen-short gen-short))
+
+(def: #export gen-type
+ (r.Random Type)
+ (let [(^open "R/.") r.monad]
+ (r.rec (function (_ gen-type)
+ (let [pairG (r.and gen-type gen-type)
+ idG r.nat
+ quantifiedG (r.and (R/wrap (list)) gen-type)]
+ ($_ r.or
+ (r.and gen-short (R/wrap (list)))
+ pairG
+ pairG
+ pairG
+ idG
+ idG
+ idG
+ quantifiedG
+ quantifiedG
+ pairG
+ (r.and gen-name gen-type)
+ ))))))
+
+## [Tests]
+(context: "Types"
+ (<| (times 100)
+ (do @
+ [sample gen-type]
+ (test "Every type is equal to itself."
+ (:: &.equivalence = sample sample)))))
+
+(context: "Type application"
+ (test "Can apply quantified types (universal and existential quantification)."
+ (and (maybe.default #0
+ (do maybe.monad
+ [partial (&.apply (list Bit) Ann)
+ full (&.apply (list Int) partial)]
+ (wrap (:: &.equivalence = full (#.Product Bit Int)))))
+ (|> (&.apply (list Bit) Text)
+ (case> #.None #1 _ #0)))))
+
+(context: "Naming"
+ (let [base (#.Named ["" "a"] (#.Product Bit Int))
+ aliased (#.Named ["" "c"]
+ (#.Named ["" "b"]
+ base))]
+ ($_ seq
+ (test "Can remove aliases from an already-named type."
+ (:: &.equivalence =
+ base
+ (&.un-alias aliased)))
+
+ (test "Can remove all names from a type."
+ (and (not (:: &.equivalence =
+ base
+ (&.un-name aliased)))
+ (:: &.equivalence =
+ (&.un-name base)
+ (&.un-name aliased)))))))
+
+(context: "Type construction [structs]"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (n/% 3)))
+ members (|> gen-type
+ (r.filter (function (_ type)
+ (case type
+ (^or (#.Sum _) (#.Product _))
+ #0
+
+ _
+ #1)))
+ (list.repeat size)
+ (M.seq @))
+ #let [(^open "&/.") &.equivalence
+ (^open "L/.") (list.equivalence &.equivalence)]]
+ (with-expansions
+ [<struct-tests> (do-template [<desc> <ctor> <dtor> <unit>]
+ [(test (format "Can build and tear-down " <desc> " types.")
+ (let [flat (|> members <ctor> <dtor>)]
+ (or (L/= members flat)
+ (and (L/= (list) members)
+ (L/= (list <unit>) flat)))))]
+
+ ["variant" &.variant &.flatten-variant Nothing]
+ ["tuple" &.tuple &.flatten-tuple Any]
+ )]
+ ($_ seq
+ <struct-tests>
+ )))))
+
+(context: "Type construction [parameterized]"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (n/% 3)))
+ members (M.seq @ (list.repeat size gen-type))
+ extra (|> gen-type
+ (r.filter (function (_ type)
+ (case type
+ (^or (#.Function _) (#.Apply _))
+ #0
+
+ _
+ #1))))
+ #let [(^open "&/.") &.equivalence
+ (^open "L/.") (list.equivalence &.equivalence)]]
+ ($_ seq
+ (test "Can build and tear-down function types."
+ (let [[inputs output] (|> (&.function members extra) &.flatten-function)]
+ (and (L/= members inputs)
+ (&/= extra output))))
+
+ (test "Can build and tear-down application types."
+ (let [[tfunc tparams] (|> extra (&.application members) &.flatten-application)]
+ (n/= (list.size members) (list.size tparams))))
+ ))))
+
+(context: "Type construction [higher order]"
+ (<| (times 100)
+ (do @
+ [size (|> r.nat (:: @ map (n/% 3)))
+ extra (|> gen-type
+ (r.filter (function (_ type)
+ (case type
+ (^or (#.UnivQ _) (#.ExQ _))
+ #0
+
+ _
+ #1))))
+ #let [(^open "&/.") &.equivalence]]
+ (with-expansions
+ [<quant-tests> (do-template [<desc> <ctor> <dtor>]
+ [(test (format "Can build and tear-down " <desc> " types.")
+ (let [[flat-size flat-body] (|> extra (<ctor> size) <dtor>)]
+ (and (n/= size flat-size)
+ (&/= extra flat-body))))]
+
+ ["universally-quantified" &.univ-q &.flatten-univ-q]
+ ["existentially-quantified" &.ex-q &.flatten-ex-q]
+ )]
+ ($_ seq
+ <quant-tests>
+ )))))
diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux
new file mode 100644
index 000000000..426127fb6
--- /dev/null
+++ b/stdlib/source/test/lux/type/check.lux
@@ -0,0 +1,237 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do Monad)]
+ [pipe (#+ case>)]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." number]
+ [text ("text/." equivalence)]
+ [collection
+ ["." list ("list/." functor)]
+ ["." set]]]
+ [math
+ ["r" random]]
+ ["." type ("type/." equivalence)
+ ["@" check]]]
+ lux/test
+ ["." //])
+
+## [Utils]
+(def: (valid-type? type)
+ (-> Type Bit)
+ (case type
+ (#.Primitive name params)
+ (list.every? valid-type? params)
+
+ (#.Ex id)
+ #1
+
+ (^template [<tag>]
+ (<tag> left right)
+ (and (valid-type? left) (valid-type? right)))
+ ([#.Sum] [#.Product] [#.Function])
+
+ (#.Named name type')
+ (valid-type? type')
+
+ _
+ #0))
+
+(def: (type-checks? input)
+ (-> (@.Check []) Bit)
+ (case (@.run @.fresh-context input)
+ (#.Right [])
+ #1
+
+ (#.Left error)
+ #0))
+
+## [Tests]
+(context: "Any and Nothing."
+ (<| (times 100)
+ (do @
+ [sample (|> //.gen-type (r.filter valid-type?))]
+ ($_ seq
+ (test "Any is the super-type of everything."
+ (@.checks? Any sample))
+
+ (test "Nothing is the sub-type of everything."
+ (@.checks? sample Nothing))
+ ))))
+
+(context: "Simple type-checking."
+ ($_ seq
+ (test "Any and Nothing match themselves."
+ (and (@.checks? Nothing Nothing)
+ (@.checks? Any Any)))
+
+ (test "Existential types only match with themselves."
+ (and (type-checks? (do @.monad
+ [[_ exT] @.existential]
+ (@.check exT exT)))
+ (not (type-checks? (do @.monad
+ [[_ exTL] @.existential
+ [_ exTR] @.existential]
+ (@.check exTL exTR))))))
+
+ (test "Names do not affect type-checking."
+ (and (type-checks? (do @.monad
+ [[_ exT] @.existential]
+ (@.check (#.Named ["module" "name"] exT)
+ exT)))
+ (type-checks? (do @.monad
+ [[_ exT] @.existential]
+ (@.check exT
+ (#.Named ["module" "name"] exT))))
+ (type-checks? (do @.monad
+ [[_ exT] @.existential]
+ (@.check (#.Named ["module" "name"] exT)
+ (#.Named ["module" "name"] exT))))))
+
+ (test "Functions are covariant on inputs and contravariant on outputs."
+ (and (@.checks? (#.Function Nothing Any)
+ (#.Function Any Nothing))
+ (not (@.checks? (#.Function Any Nothing)
+ (#.Function Nothing Any)))))
+ ))
+
+(context: "Type application."
+ (<| (times 100)
+ (do @
+ [meta //.gen-type
+ data //.gen-type]
+ (test "Can type-check type application."
+ (and (@.checks? (|> Ann (#.Apply meta) (#.Apply data))
+ (type.tuple (list meta data)))
+ (@.checks? (type.tuple (list meta data))
+ (|> Ann (#.Apply meta) (#.Apply data))))))))
+
+(context: "Primitive types."
+ (<| (times 100)
+ (do @
+ [nameL //.gen-short
+ nameR (|> //.gen-short (r.filter (|>> (text/= nameL) not)))
+ paramL //.gen-type
+ paramR (|> //.gen-type (r.filter (|>> (@.checks? paramL) not)))]
+ ($_ seq
+ (test "Primitive types match when they have the same name and the same parameters."
+ (@.checks? (#.Primitive nameL (list paramL))
+ (#.Primitive nameL (list paramL))))
+
+ (test "Names matter to primitive types."
+ (not (@.checks? (#.Primitive nameL (list paramL))
+ (#.Primitive nameR (list paramL)))))
+
+ (test "Parameters matter to primitive types."
+ (not (@.checks? (#.Primitive nameL (list paramL))
+ (#.Primitive nameL (list paramR)))))
+ ))))
+
+(context: "Type variables."
+ ($_ seq
+ (test "Type-vars check against themselves."
+ (type-checks? (do @.monad
+ [[id var] @.var]
+ (@.check var var))))
+
+ (test "Can bind unbound type-vars by type-checking against them."
+ (and (type-checks? (do @.monad
+ [[id var] @.var]
+ (@.check var .Any)))
+ (type-checks? (do @.monad
+ [[id var] @.var]
+ (@.check .Any var)))))
+
+ (test "Cannot rebind already bound type-vars."
+ (not (type-checks? (do @.monad
+ [[id var] @.var
+ _ (@.check var .Bit)]
+ (@.check var .Nat)))))
+
+ (test "If the type bound to a var is a super-type to another, then the var is also a super-type."
+ (type-checks? (do @.monad
+ [[id var] @.var
+ _ (@.check var Any)]
+ (@.check var .Bit))))
+
+ (test "If the type bound to a var is a sub-type of another, then the var is also a sub-type."
+ (type-checks? (do @.monad
+ [[id var] @.var
+ _ (@.check var Nothing)]
+ (@.check .Bit var))))
+ ))
+
+(def: (build-ring num-connections)
+ (-> Nat (@.Check [[Nat Type] (List [Nat Type]) [Nat Type]]))
+ (do @.monad
+ [[head-id head-type] @.var
+ ids+types (monad.seq @ (list.repeat num-connections @.var))
+ [tail-id tail-type] (monad.fold @ (function (_ [tail-id tail-type] [_head-id _head-type])
+ (do @
+ [_ (@.check head-type tail-type)]
+ (wrap [tail-id tail-type])))
+ [head-id head-type]
+ ids+types)]
+ (wrap [[head-id head-type] ids+types [tail-id tail-type]])))
+
+(context: "Rings of type variables."
+ (<| (times 100)
+ (do @
+ [num-connections (|> r.nat (:: @ map (n/% 100)))
+ boundT (|> //.gen-type (r.filter (|>> (case> (#.Var _) #0 _ #1))))
+ pick-pcg (r.and r.nat r.nat)]
+ ($_ seq
+ (test "Can create rings of variables."
+ (type-checks? (do @.monad
+ [[[head-id head-type] ids+types [tail-id tail-type]] (build-ring num-connections)
+ #let [ids (list/map product.left ids+types)]
+ headR (@.ring head-id)
+ tailR (@.ring tail-id)]
+ (@.assert ""
+ (let [same-rings? (:: set.equivalence = headR tailR)
+ expected-size? (n/= (inc num-connections) (set.size headR))
+ same-vars? (|> (set.to-list headR)
+ (list.sort n/<)
+ (:: (list.equivalence number.equivalence) = (list.sort n/< (#.Cons head-id ids))))]
+ (and same-rings?
+ expected-size?
+ same-vars?))))))
+ (test "When a var in a ring is bound, all the ring is bound."
+ (type-checks? (do @.monad
+ [[[head-id headT] ids+types tailT] (build-ring num-connections)
+ #let [ids (list/map product.left ids+types)]
+ _ (@.check headT boundT)
+ head-bound (@.read head-id)
+ tail-bound (monad.map @ @.read ids)
+ headR (@.ring head-id)
+ tailR+ (monad.map @ @.ring ids)]
+ (let [rings-were-erased? (and (set.empty? headR)
+ (list.every? set.empty? tailR+))
+ same-types? (list.every? (type/= boundT) (list& (maybe.default headT head-bound)
+ (list/map (function (_ [tail-id ?tailT])
+ (maybe.default (#.Var tail-id) ?tailT))
+ (list.zip2 ids tail-bound))))]
+ (@.assert ""
+ (and rings-were-erased?
+ same-types?))))))
+ (test "Can merge multiple rings of variables."
+ (type-checks? (do @.monad
+ [[[head-idL headTL] ids+typesL [tail-idL tailTL]] (build-ring num-connections)
+ [[head-idR headTR] ids+typesR [tail-idR tailTR]] (build-ring num-connections)
+ headRL-pre (@.ring head-idL)
+ headRR-pre (@.ring head-idR)
+ _ (@.check headTL headTR)
+ headRL-post (@.ring head-idL)
+ headRR-post (@.ring head-idR)]
+ (@.assert ""
+ (let [same-rings? (:: set.equivalence = headRL-post headRR-post)
+ expected-size? (n/= (n/* 2 (inc num-connections))
+ (set.size headRL-post))
+ union? (:: set.equivalence = headRL-post (set.union headRL-pre headRR-pre))]
+ (and same-rings?
+ expected-size?
+ union?))))))
+ ))
+ ))
diff --git a/stdlib/source/test/lux/type/dynamic.lux b/stdlib/source/test/lux/type/dynamic.lux
new file mode 100644
index 000000000..70e26f743
--- /dev/null
+++ b/stdlib/source/test/lux/type/dynamic.lux
@@ -0,0 +1,31 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ ["." error]]
+ [math
+ ["r" random]]
+ [type
+ ["/" dynamic (#+ Dynamic :dynamic :check)]]]
+ lux/test)
+
+(context: "Dynamic typing."
+ (do @
+ [expected r.nat
+ #let [value (:dynamic expected)]]
+ ($_ seq
+ (test "Can check dynamic values."
+ (case (:check Nat value)
+ (#error.Success actual)
+ (n/= expected actual)
+
+ (#error.Failure error)
+ false))
+ (test "Cannot confuse types."
+ (case (:check Text value)
+ (#error.Success actual)
+ false
+
+ (#error.Failure error)
+ true)))))
diff --git a/stdlib/source/test/lux/type/implicit.lux b/stdlib/source/test/lux/type/implicit.lux
new file mode 100644
index 000000000..98b647bf1
--- /dev/null
+++ b/stdlib/source/test/lux/type/implicit.lux
@@ -0,0 +1,40 @@
+(.module:
+ [lux #*
+ [io]
+ [control
+ [equivalence]
+ [functor]
+ [monad (#+ Monad do)]]
+ [data
+ [bit ("bit/." equivalence)]
+ [number]
+ [collection [list]]]
+ [math
+ ["r" random]]
+ [type implicit]]
+ lux/test)
+
+(context: "Automatic structure selection"
+ (<| (times 100)
+ (do @
+ [x r.nat
+ y r.nat]
+ ($_ seq
+ (test "Can automatically select first-order structures."
+ (let [(^open "list/.") (list.equivalence number.equivalence)]
+ (and (bit/= (:: number.equivalence = x y)
+ (::: = x y))
+ (list/= (list.n/range 1 10)
+ (::: map inc (list.n/range 0 9)))
+ )))
+
+ (test "Can automatically select second-order structures."
+ (::: =
+ (list.n/range 1 10)
+ (list.n/range 1 10)))
+
+ (test "Can automatically select third-order structures."
+ (let [lln (::: map (list.n/range 1)
+ (list.n/range 1 10))]
+ (::: = lln lln)))
+ ))))
diff --git a/stdlib/source/test/lux/type/resource.lux b/stdlib/source/test/lux/type/resource.lux
new file mode 100644
index 000000000..b04321cc2
--- /dev/null
+++ b/stdlib/source/test/lux/type/resource.lux
@@ -0,0 +1,48 @@
+(.module:
+ [lux #*
+ [control
+ [monad
+ [indexed (#+ do)]]]
+ [type
+ ["." resource (#+ Res)]]
+ ["." io]]
+ lux/test)
+
+(context: "Sub-structural typing."
+ ($_ seq
+ (test "Can produce and consume keys in an ordered manner."
+ (<| (n/= (n/+ 123 456))
+ io.run
+ resource.run-sync
+ (do resource.sync
+ [res|left (resource.ordered-sync 123)
+ res|right (resource.ordered-sync 456)
+ right (resource.read-sync res|right)
+ left (resource.read-sync res|left)]
+ (wrap (n/+ left right)))))
+
+ (test "Can exchange commutative keys."
+ (<| (n/= (n/+ 123 456))
+ io.run
+ resource.run-sync
+ (do resource.sync
+ [res|left (resource.commutative-sync 123)
+ res|right (resource.commutative-sync 456)
+ _ (resource.exchange-sync [1 0])
+ left (resource.read-sync res|left)
+ right (resource.read-sync res|right)]
+ (wrap (n/+ left right)))))
+
+ (test "Can group and un-group keys."
+ (<| (n/= (n/+ 123 456))
+ io.run
+ resource.run-sync
+ (do resource.sync
+ [res|left (resource.commutative-sync 123)
+ res|right (resource.commutative-sync 456)
+ _ (resource.group-sync 2)
+ _ (resource.un-group-sync 2)
+ right (resource.read-sync res|right)
+ left (resource.read-sync res|left)]
+ (wrap (n/+ left right)))))
+ ))
diff --git a/stdlib/source/test/lux/world/binary.lux b/stdlib/source/test/lux/world/binary.lux
new file mode 100644
index 000000000..ec4da0d11
--- /dev/null
+++ b/stdlib/source/test/lux/world/binary.lux
@@ -0,0 +1,88 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do)]]
+ [data
+ ["." error (#+ Error)]
+ ["." number
+ ["." i64]]
+ [collection
+ ["." list]]]
+ [world
+ ["/" binary]]
+ [math
+ ["r" random]]]
+ lux/test
+ [test
+ [lux
+ [control
+ ["_eq" equivalence]]]])
+
+(def: (succeed result)
+ (-> (Error Bit) Bit)
+ (case result
+ (#error.Failure _)
+ #0
+
+ (#error.Success output)
+ output))
+
+(def: #export (binary size)
+ (-> Nat (r.Random /.Binary))
+ (let [output (/.create size)]
+ (loop [idx 0]
+ (if (n/< size idx)
+ (do r.monad
+ [byte r.nat]
+ (exec (error.assume (/.write/8 idx byte output))
+ (recur (inc idx))))
+ (:: r.monad wrap output)))))
+
+(def: (bits-io bytes read write value)
+ (-> Nat (-> Nat /.Binary (Error Nat)) (-> Nat Nat /.Binary (Error Any)) Nat Bit)
+ (let [binary (/.create 8)
+ bits (n/* 8 bytes)
+ capped-value (|> 1 (i64.left-shift bits) dec (i64.and value))]
+ (succeed
+ (do error.monad
+ [_ (write 0 value binary)
+ output (read 0 binary)]
+ (wrap (n/= capped-value output))))))
+
+(context: "Binary."
+ (<| (times 100)
+ (do @
+ [#let [gen-size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 8))))]
+ binary-size gen-size
+ random-binary (binary binary-size)
+ value r.nat
+ #let [gen-idx (|> r.nat (:: @ map (n/% binary-size)))]
+ [from to] (r.and gen-idx gen-idx)
+ #let [[from to] [(n/min from to) (n/max from to)]]]
+ ($_ seq
+ ## TODO: De-comment...
+ ## (_eq.spec /.equivalence (:: @ map binary gen-size))
+ (test "Can get size of binary."
+ (|> random-binary /.size (n/= binary-size)))
+ (test "Can read/write 8-bit values."
+ (bits-io 1 /.read/8 /.write/8 value))
+ (test "Can read/write 16-bit values."
+ (bits-io 2 /.read/16 /.write/16 value))
+ (test "Can read/write 32-bit values."
+ (bits-io 4 /.read/32 /.write/32 value))
+ (test "Can read/write 64-bit values."
+ (bits-io 8 /.read/64 /.write/64 value))
+ (test "Can slice binaries."
+ (let [slice-size (|> to (n/- from) inc)
+ random-slice (error.assume (/.slice from to random-binary))
+ idxs (list.n/range 0 (dec slice-size))
+ reader (function (_ binary idx) (/.read/8 idx binary))]
+ (and (n/= slice-size (/.size random-slice))
+ (case [(monad.map error.monad (reader random-slice) idxs)
+ (monad.map error.monad (|>> (n/+ from) (reader random-binary)) idxs)]
+ [(#error.Success slice-vals) (#error.Success binary-vals)]
+ (:: (list.equivalence number.nat-equivalence) = slice-vals binary-vals)
+
+ _
+ #0))))
+ ))))
diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux
new file mode 100644
index 000000000..b3693f207
--- /dev/null
+++ b/stdlib/source/test/lux/world/file.lux
@@ -0,0 +1,195 @@
+(.module:
+ [lux #*
+ ["." io (#+ IO)]
+ [control
+ [monad (#+ do)]
+ [security
+ ["." integrity (#+ Dirty)]]]
+ [concurrency
+ ["." promise]]
+ [data
+ ["." error (#+ Error)]
+ ["." number]
+ ["." text
+ format]
+ [collection
+ ["." list]]]
+ [time
+ ["." instant]
+ ["." duration]]
+ [world
+ ["@" file (#+ Path File)]
+ ["." binary (#+ Binary)]]
+ [math
+ ["r" random ("r/." monad)]]]
+ lux/test
+ [//
+ ["_." binary]])
+
+(def: truncate-millis
+ (|>> (i// +1_000) (i/* +1_000)))
+
+(def: (creation-and-deletion number)
+ (-> Nat Test)
+ (r/wrap (do promise.monad
+ [#let [path (format "temp_file_" (%n number))]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [#let [check-existence! (: (IO (Error Bit))
+ (io.from-io (@.exists? io.monad @.system path)))]
+ pre! check-existence!
+ file (:: @.system create-file path)
+ post! check-existence!
+ _ (:: file delete [])
+ remains? check-existence!]
+ (wrap (and (not pre!)
+ post!
+ (not remains?)))))]
+ (assert "Can create/delete files."
+ (error.default #0 result)))))
+
+(def: (read-and-write number data)
+ (-> Nat Binary Test)
+ (r/wrap (do promise.monad
+ [#let [path (format "temp_file_" (%n number))]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [file (:: @.system create-file path)
+ _ (:: file over-write data)
+ content (:: file content [])
+ _ (:: file delete [])]
+ (wrap (:: binary.equivalence = data (integrity.trust content)))))]
+ (assert "Can write/read files."
+ (error.default #0 result)))))
+
+(context: "File system."
+ (do @
+ [file-size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))
+ dataL (_binary.binary file-size)
+ dataR (_binary.binary file-size)
+ new-modified (|> r.int (:: @ map (|>> (:: number.number abs)
+ truncate-millis
+ duration.from-millis
+ instant.absolute)))]
+ ($_ seq
+ (creation-and-deletion 0)
+ (read-and-write 1 dataL)
+ (wrap (do promise.monad
+ [#let [path "temp_file_2"]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [file (:: @.system create-file path)
+ _ (:: file over-write dataL)
+ read-size (:: file size [])
+ _ (:: file delete [])]
+ (wrap (n/= file-size read-size))))]
+ (assert "Can read file size."
+ (error.default #0 result))))
+ (wrap (do promise.monad
+ [#let [path "temp_file_3"]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [file (:: @.system create-file path)
+ _ (:: file over-write dataL)
+ _ (:: file append dataR)
+ content (:: file content [])
+ read-size (:: file size [])
+ _ (:: file delete [])]
+ (wrap (and (n/= (n/* 2 file-size) read-size)
+ (:: binary.equivalence =
+ dataL
+ (error.assume (binary.slice 0 (dec file-size)
+ (integrity.trust content))))
+ (:: binary.equivalence =
+ dataR
+ (error.assume (binary.slice file-size (dec read-size)
+ (integrity.trust content))))))))]
+ (assert "Can append to files."
+ (error.default #0 result))))
+ (wrap (do promise.monad
+ [#let [path "temp_dir_4"]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [#let [check-existence! (: (IO (Error Bit))
+ (io.from-io (@.exists? io.monad @.system path)))]
+ pre! check-existence!
+ dir (:: @.system create-directory path)
+ post! check-existence!
+ _ (:: dir discard [])
+ remains? check-existence!]
+ (wrap (and (not pre!)
+ post!
+ (not remains?)))))]
+ (assert "Can create/delete directories."
+ (error.default #0 result))))
+ (wrap (do promise.monad
+ [#let [file-path "temp_file_5"
+ dir-path "temp_dir_5"]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [dir (:: @.system create-directory dir-path)
+ file (:: @.system create-file (format dir-path "/" file-path))
+ _ (:: file over-write dataL)
+ read-size (:: file size [])
+ _ (:: file delete [])
+ _ (:: dir discard [])]
+ (wrap (n/= file-size read-size))))]
+ (assert "Can create files inside of directories."
+ (error.default #0 result))))
+ (wrap (do promise.monad
+ [#let [file-path "temp_file_6"
+ dir-path "temp_dir_6"
+ inner-dir-path "inner_temp_dir_6"]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [dir (:: @.system create-directory dir-path)
+ pre-files (:: dir files [])
+ pre-directories (:: dir directories [])
+
+ file (:: @.system create-file (format dir-path "/" file-path))
+ inner-dir (:: @.system create-directory (format dir-path "/" inner-dir-path))
+ post-files (:: dir files [])
+ post-directories (:: dir directories [])
+
+ _ (:: file delete [])
+ _ (:: inner-dir discard [])
+ _ (:: dir discard [])]
+ (wrap (and (and (n/= 0 (list.size pre-files))
+ (n/= 0 (list.size pre-directories)))
+ (and (n/= 1 (list.size post-files))
+ (n/= 1 (list.size post-directories)))))))]
+ (assert "Can list files/directories inside a directory."
+ (error.default #0 result))))
+ (wrap (do promise.monad
+ [#let [path "temp_file_7"]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [file (:: @.system create-file path)
+ _ (:: file over-write dataL)
+ _ (:: file modify new-modified)
+ old-modified (:: file last-modified [])
+ _ (:: file delete [])]
+ (wrap (:: instant.equivalence = new-modified old-modified))))]
+ (assert "Can change the time of last modification."
+ (error.default #0 result))))
+ (wrap (do promise.monad
+ [#let [path0 (format "temp_file_8+0")
+ path1 (format "temp_file_8+1")]
+ result (promise.future
+ (do (error.ErrorT io.monad)
+ [#let [check-existence! (: (-> Path (IO (Error Bit)))
+ (|>> (@.exists? io.monad @.system) io.from-io))]
+ file0 (:: @.system create-file path0)
+ _ (:: file0 over-write dataL)
+ pre! (check-existence! path0)
+ file1 (: (IO (Error (File IO))) ## TODO: Remove :
+ (:: file0 move path1))
+ post! (check-existence! path0)
+ confirmed? (check-existence! path1)
+ _ (:: file1 delete [])]
+ (wrap (and pre!
+ (not post!)
+ confirmed?))))]
+ (assert "Can move a file from one path to another."
+ (error.default #0 result))))
+ )))
diff --git a/stdlib/source/test/lux/world/net/tcp.lux b/stdlib/source/test/lux/world/net/tcp.lux
new file mode 100644
index 000000000..fae5ac05d
--- /dev/null
+++ b/stdlib/source/test/lux/world/net/tcp.lux
@@ -0,0 +1,71 @@
+(.module:
+ [lux #*
+ ["." io]
+ [control
+ [monad (#+ do)]
+ ["ex" exception (#+ exception:)]
+ [security
+ ["." taint]]]
+ [concurrency
+ ["." promise (#+ Promise promise)]
+ [frp ("frp/." functor)]]
+ [data
+ ["." error]
+ ["." text
+ format]]
+ [world
+ ["." binary]
+ ["." net
+ ["@" tcp]]]
+ [math
+ ["r" random]]]
+ lux/test
+ [///
+ ["_." binary]])
+
+(def: localhost net.Address "127.0.0.1")
+
+(def: port
+ (r.Random net.Port)
+ (|> r.nat
+ (:: r.monad map
+ (|>> (n/% 1000)
+ (n/+ 8000)))))
+
+(context: "TCP networking."
+ (do @
+ [port ..port
+ size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))
+ from (_binary.binary size)
+ to (_binary.binary size)]
+ ($_ seq
+ (wrap (do promise.monad
+ [#let [from-worked? (: (Promise Bit)
+ (promise #.Nil))]
+ result (promise.future
+ (do io.monad
+ [[server-close server] (@.server port)
+ #let [_ (frp/map (function (_ client)
+ (promise.future
+ (do @
+ [[trasmission-size transmission] (:: client read size)
+ #let [_ (io.run (promise.resolve (and (n/= size trasmission-size)
+ (:: binary.equivalence = from (taint.trust transmission)))
+ from-worked?))]]
+ (:: client write to))))
+ server)]
+ client (@.client localhost port)
+ _ (:: client write from)
+ ####################
+ [trasmission-size transmission] (:: client read size)
+ #let [to-worked? (and (n/= size trasmission-size)
+ (:: binary.equivalence = to (taint.trust transmission)))]
+ ####################
+ _ (:: client close [])
+ _ (io.from-io (promise.resolve [] server-close))]
+ (wrap to-worked?)))
+ from-worked? from-worked?]
+ (assert "Can communicate between client and server."
+ (and from-worked?
+ (error.default #0 result)))))
+ )))
diff --git a/stdlib/source/test/lux/world/net/udp.lux b/stdlib/source/test/lux/world/net/udp.lux
new file mode 100644
index 000000000..2b85958fa
--- /dev/null
+++ b/stdlib/source/test/lux/world/net/udp.lux
@@ -0,0 +1,64 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ [security
+ ["." integrity]]]
+ [concurrency
+ ["." promise]]
+ [data
+ ["." error]
+ ["." text
+ format]]
+ ["." io]
+ [world
+ ["." binary]
+ ["." net
+ ["@" udp]]]
+ [math
+ ["r" random]]]
+ lux/test
+ [///
+ ["_." binary]])
+
+(def: localhost net.Address "127.0.0.1")
+(def: port
+ (r.Random net.Port)
+ (|> r.nat
+ (:: r.monad map
+ (|>> (n/% 1000)
+ (n/+ 8000)))))
+
+(context: "UDP networking."
+ (do @
+ [port ..port
+ size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10))))
+ from (_binary.binary size)
+ to (_binary.binary size)]
+ ($_ seq
+ (wrap (do promise.monad
+ [result (promise.future
+ (do io.monad
+ [server (@.server port)
+ client @.client
+ ####################
+ _ (:: client write [[localhost port] from])
+ [bytes-from [from-address from-port] temp] (:: server read size)
+ #let [from-worked? (and (n/= size bytes-from)
+ (:: binary.equivalence = from (integrity.trust temp)))]
+ ####################
+ _ (:: server write [[from-address from-port] to])
+ [bytes-to [to-address to-port] temp] (:: client read size)
+ #let [to-worked? (and (n/= size bytes-to)
+ (:: binary.equivalence = to (integrity.trust temp))
+ (n/= port to-port))]
+ ####################
+ _ (:: client close [])
+ _ (:: server close [])]
+ ## (wrap false)
+ (wrap (and from-worked?
+ to-worked?))
+ ))]
+ (assert "Can communicate between client and server."
+ (error.default #0 result))))
+ )))