diff options
Diffstat (limited to 'stdlib/source/test')
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)))) + ))) |