diff options
| -rw-r--r-- | stdlib/source/lux/data/error.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/lux/data/lazy.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/test/lux.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/codec.lux | 27 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/concurrency/atom.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/reader.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data.lux | 24 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/bit.lux | 61 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/color.lux | 117 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/error.lux | 107 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/identity.lux | 70 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/lazy.lux | 89 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/maybe.lux | 128 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/name.lux | 106 |
14 files changed, 428 insertions, 352 deletions
diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux index 938fca3b9..9f84c2707 100644 --- a/stdlib/source/lux/data/error.lux +++ b/stdlib/source/lux/data/error.lux @@ -3,7 +3,8 @@ [control ["." functor (#+ Functor)] [apply (#+ Apply)] - ["." monad (#+ Monad do)]]]) + ["." monad (#+ Monad do)] + [equivalence (#+ Equivalence)]]]) (type: #export (Error a) (#Failure Text) @@ -71,6 +72,16 @@ (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) (monad.lift monad (:: ..monad wrap))) +(structure: #export (equivalence (^open "_@.")) + (All [a] (-> (Equivalence a) (Equivalence (Error a)))) + (def: (= reference sample) + (case [reference sample] + [(#Success reference) (#Success sample)] + (_@= reference sample) + + _ + false))) + (def: #export (succeed value) (All [a] (-> a (Error a))) (#Success value)) diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index c8f5746b1..dc889675a 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -4,9 +4,10 @@ [control [functor (#+ Functor)] [apply (#+ Apply)] - [monad (#+ Monad do)]] - [concurrency - ["." atom]] + [monad (#+ Monad do)] + [equivalence (#+ Equivalence)] + [concurrency + ["." atom]]] [macro (#+ with-gensyms) ["s" syntax (#+ syntax:)]] [type @@ -36,6 +37,11 @@ (with-gensyms [g!_] (wrap (list (` ((~! freeze') (function ((~ g!_) (~ g!_)) (~ expr)))))))) +(structure: #export (equivalence (^open "_@.")) + (All [a] (-> (Equivalence a) (Equivalence (Lazy a)))) + (def: (= left right) + (_@= (..thaw left) (..thaw right)))) + (structure: #export functor (Functor Lazy) (def: (map f fa) (freeze (f (thaw fa))))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index d6d667d72..bf1011080 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -108,23 +108,15 @@ ["." / #_ ["#." cli] ["#." io] + ["#." control] + ["#." data] ["#." host - ["#/." jvm]] - ["#." control]] + ["#/." jvm]]] ## [control ## [concurrency - ## [promise (#+)] - ## [stm (#+)] ## ## [semaphore (#+)] ## ]] ## [data - ## [bit (#+)] - ## [color (#+)] - ## [error (#+)] - ## [name (#+)] - ## [identity (#+)] - ## [lazy (#+)] - ## [maybe (#+)] ## [product (#+)] ## [sum (#+)] ## [number (#+) ## TODO: FIX Specially troublesome... @@ -416,13 +408,15 @@ /cli.test) (<| (_.context "/io I/O (input/output)") /io.test) + (<| (_.context "/control") + /control.test) + (<| (_.context "/data") + /data.test) (<| (_.context "/host Host-platform interoperation") ($_ _.and /host.test (<| (_.context "/jvm JVM (Java Virtual Machine)") /host/jvm.test))) - (<| (_.context "/control") - /control.test) )) (program: args diff --git a/stdlib/source/test/lux/control/codec.lux b/stdlib/source/test/lux/control/codec.lux new file mode 100644 index 000000000..22c161616 --- /dev/null +++ b/stdlib/source/test/lux/control/codec.lux @@ -0,0 +1,27 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [control + [monad (#+ do)]] + [data + text/format + ["." error]] + [math + ["r" random (#+ Random)]]] + {1 + ["." / (#+ Codec) + [// + [equivalence (#+ Equivalence)]]]}) + +(def: #export (test (^open "/@.") (^open "/@.") generator) + (All [m a] (-> (Codec m a) (Equivalence a) (Random a) Test)) + (do r.monad + [expected generator] + (<| (_.context (%name (name-of /.Codec))) + (_.test "Reflexivity." + (case (|> expected /@encode /@decode) + (#error.Success actual) + (/@= expected actual) + + (#error.Failure error) + false))))) diff --git a/stdlib/source/test/lux/control/concurrency/atom.lux b/stdlib/source/test/lux/control/concurrency/atom.lux index a314e7193..29cc28ad4 100644 --- a/stdlib/source/test/lux/control/concurrency/atom.lux +++ b/stdlib/source/test/lux/control/concurrency/atom.lux @@ -3,7 +3,7 @@ ["_" test (#+ Test)] ["." io] [control - [monad (#+ Monad do)]] + [monad (#+ do)]] data/text/format [math ["r" random]]] diff --git a/stdlib/source/test/lux/control/reader.lux b/stdlib/source/test/lux/control/reader.lux index 7cdd022bb..4e57131f5 100644 --- a/stdlib/source/test/lux/control/reader.lux +++ b/stdlib/source/test/lux/control/reader.lux @@ -44,11 +44,11 @@ (applyT.laws ..injection ..comparison /.apply) (monadT.laws ..injection ..comparison /.monad) - (let [(^open "io;.") io.monad] + (let [(^open "io@.") io.monad] (_.test "Can add reader functionality to any monad." (|> (: (/.Reader Any (IO Nat)) (do (/.with io.monad) - [a (/.lift (io;wrap sample)) + [a (/.lift (io@wrap sample)) b (wrap factor)] (wrap (n/* b a)))) (/.run []) diff --git a/stdlib/source/test/lux/data.lux b/stdlib/source/test/lux/data.lux new file mode 100644 index 000000000..ec1cdf702 --- /dev/null +++ b/stdlib/source/test/lux/data.lux @@ -0,0 +1,24 @@ +(.module: + [lux #* + ["_" test (#+ Test)]] + ["." / #_ + ["#." bit] + ["#." color] + ["#." error] + ["#." identity] + ["#." lazy] + ["#." maybe] + ["#." name] + ]) + +(def: #export test + Test + ($_ _.and + /bit.test + /color.test + /error.test + /identity.test + /lazy.test + /maybe.test + /name.test + )) diff --git a/stdlib/source/test/lux/data/bit.lux b/stdlib/source/test/lux/data/bit.lux index d064a736b..48643c29b 100644 --- a/stdlib/source/test/lux/data/bit.lux +++ b/stdlib/source/test/lux/data/bit.lux @@ -1,37 +1,38 @@ (.module: [lux #* + ["_" test (#+ Test)] + ["." function] [control - ["M" monad (#+ Monad do)]] - [data - bit] + [monad (#+ do)] + {[0 #test] + [/ + ["." equivalence] + ["." codec]]}] + data/text/format [math ["r" random]]] - lux/test) + {1 + ["." /]}) -(context: "Bit operations." - (<| (times 100) - (do @ +(def: #export test + Test + (<| (_.context (%name (name-of .Bit))) + (do r.monad [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) - ))))) + ($_ _.and + (_.test "A value cannot be true and false at the same time." + (not (and value (not value)))) + (_.test "A value must be either true or false at any time." + (or value (not value))) + (_.test "Can create the complement of a predicate." + (and (not (:: /.equivalence = value ((/.complement function.identity) value))) + (:: /.equivalence = value ((/.complement not) value)))) + (equivalence.test /.equivalence r.bit) + (codec.test /.codec /.equivalence r.bit) + (_.test "Or/disjunction monoid." + (and (not (:: /.or-monoid identity)) + (:: /.or-monoid compose value (not value)))) + (_.test "And/conjunction monoid." + (and (:: /.and-monoid identity) + (not (:: /.and-monoid compose value (not value))))) + )))) diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux index 5546a9d90..af16ef76e 100644 --- a/stdlib/source/test/lux/data/color.lux +++ b/stdlib/source/test/lux/data/color.lux @@ -1,19 +1,24 @@ (.module: [lux #* + ["_" test (#+ Test)] [control - [monad (#+ do)]] + [monad (#+ do)] + {[0 #test] + [/ + ["." equivalence]]}] [data - ["@" color] + text/format [number - ["." frac ("#;." number)]]] + ["." frac ("#@." number)]]] ["." math ["r" random]]] - lux/test) + {1 + ["." /]}) (def: color - (r.Random @.Color) + (r.Random /.Color) (|> ($_ r.and r.nat r.nat r.nat) - (:: r.monad map @.from-rgb))) + (:: r.monad map /.from-rgb))) (def: scale (-> Nat Frac) @@ -22,9 +27,9 @@ (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)] + (-> /.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) @@ -32,23 +37,24 @@ (def: error-margin Frac +1.8) -(def: black (@.from-rgb [0 0 0])) -(def: white (@.from-rgb [255 255 255])) +(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)] + (-> /.Color Frac) + (let [[hue saturation luminance] (/.to-hsl color)] <field>))] [saturation] [luminance] ) -(context: "Color." - (<| (times 100) - (do @ - [any color +(def: #export test + Test + (<| (_.context (%name (name-of /.Color))) + (do r.monad + [any ..color colorful (|> color (r.filter (function (_ color) (|> (distance color black) (f/>= +100.0)))) (r.filter (function (_ color) (|> (distance color white) (f/>= +100.0))))) @@ -58,43 +64,42 @@ (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))))) + ($_ _.and + (equivalence.test /.equivalence ..color) + (_.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 index 78e63338e..1dbe1969e 100644 --- a/stdlib/source/test/lux/data/error.lux +++ b/stdlib/source/test/lux/data/error.lux @@ -1,61 +1,64 @@ (.module: [lux #* + ["_" test (#+ Test)] ["." io] [control + pipe [monad (#+ do Monad)] - pipe] + {[0 #test] + [/ + [".T" functor (#+ Injection Comparison)] + [".T" apply] + [".T" monad] + [".T" equivalence]]}] [data - ["/" error (#+ Error)]]] - lux/test) + text/format + [number + ["." nat]]] + [math + ["r" random (#+ Random)]]] + {1 + ["." / (#+ Error)]}) -(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)) +(def: injection + (Injection Error) + (|>> #/.Success)) - (|> (: (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)) - )) - ))) +(def: comparison + (Comparison Error) + (function (_ ==) + (:: (/.equivalence ==) =))) -(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))))) +(def: #export (error element) + (All [a] (-> (Random a) (Random (Error a)))) + ($_ r.or + (r.ascii 10) + element)) + +(def: #export test + Test + (<| (_.context (%name (name-of /.Error))) + ($_ _.and + (equivalenceT.test (/.equivalence nat.equivalence) (..error r.nat)) + (functorT.laws ..injection ..comparison /.functor) + (applyT.laws ..injection ..comparison /.apply) + (monadT.laws ..injection ..comparison /.monad) + (do r.monad + [left r.nat + right r.nat + #let [expected (n/+ left right) + (^open "io@.") io.monad]] + (let [] + (_.test "Can add error functionality to any monad." + (let [lift (/.lift io.monad)] + (|> (do (/.with io.monad) + [a (lift (io@wrap left)) + b (wrap right)] + (wrap (n/+ a b))) + io.run + (case> (#/.Success actual) + (n/= expected actual) + + _ + #0)))))) + ))) diff --git a/stdlib/source/test/lux/data/identity.lux b/stdlib/source/test/lux/data/identity.lux index 293f5d075..aced82f84 100644 --- a/stdlib/source/test/lux/data/identity.lux +++ b/stdlib/source/test/lux/data/identity.lux @@ -1,37 +1,43 @@ (.module: [lux #* + ["_" test (#+ Test)] [control - ["M" monad (#+ Monad do)] - comonad] + comonad + [monad (#+ do)] + {[0 #test] + [/ + [".T" functor (#+ Injection Comparison)] + [".T" apply] + [".T" monad] + [".T" equivalence]]}] [data - ["&" identity] - ["." text ("#;." monoid equivalence)]]] - lux/test) + ["." text ("#@." monoid equivalence) + format]]] + {1 + ["." / (#+ Identity)]}) -(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))))) - ))) +(def: injection + (Injection Identity) + (|>>)) + +(def: comparison + (Comparison Identity) + (function (_ ==) + ==)) + +(def: #export test + Test + (<| (_.context (%name (name-of /.Identity))) + ($_ _.and + (functorT.laws ..injection ..comparison /.functor) + (applyT.laws ..injection ..comparison /.apply) + (monadT.laws ..injection ..comparison /.monad) + (let [(^open "/@.") /.comonad] + (_.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 index 5fe6464ff..957ce0c34 100644 --- a/stdlib/source/test/lux/data/lazy.lux +++ b/stdlib/source/test/lux/data/lazy.lux @@ -1,54 +1,55 @@ (.module: [lux #* + ["_" test (#+ Test)] [control - [monad (#+ do Monad)]] + [monad (#+ do)] + {[0 #test] + [/ + [".T" functor (#+ Injection Comparison)] + [".T" apply] + [".T" monad] + [".T" equivalence]]}] [data - ["&" lazy]] + text/format + [number + ["." nat]]] [math - ["r" random]]] - lux/test) + ["r" random (#+ Random)]]] + {1 + ["." / (#+ Lazy)]}) -(context: "Lazy." - (<| (times 100) - (do @ +(def: injection + (Injection Lazy) + (|>> /.freeze)) + +(def: comparison + (Comparison Lazy) + (function (_ ==) + (:: (/.equivalence ==) =))) + +(def: #export lazy + (All [a] (-> (Random a) (Random (Lazy a)))) + (:: r.functor map (|>> /.freeze))) + +(def: #export test + Test + (<| (_.context (%name (name-of /.Lazy))) + (do r.monad [left r.nat right r.nat - #let [lazy (&.freeze (n/* left right)) + #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))))) + ($_ _.and + (_.test "Freezing 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)))) + (equivalenceT.test (/.equivalence nat.equivalence) (..lazy r.nat)) + (functorT.laws ..injection ..comparison /.functor) + (applyT.laws ..injection ..comparison /.apply) + (monadT.laws ..injection ..comparison /.monad) )))) diff --git a/stdlib/source/test/lux/data/maybe.lux b/stdlib/source/test/lux/data/maybe.lux index f42be25bf..e2c0ce3fa 100644 --- a/stdlib/source/test/lux/data/maybe.lux +++ b/stdlib/source/test/lux/data/maybe.lux @@ -1,69 +1,77 @@ (.module: [lux #* + ["_" test (#+ Test)] [control - ["M" monad (#+ Monad do)] - pipe] + pipe + [monad (#+ do)] + {[0 #test] + [/ + [".T" functor (#+ Injection Comparison)] + [".T" apply] + [".T" monad] + [".T" equivalence]]}] [data - ["&" maybe ("#;." monoid)] - ["." text ("#;." monoid)]] - ["." io ("#;." monad)]] - lux/test) + ["." text + format] + [number + ["." nat]]] + ["." io ("#@." monad)] + [math + ["r" random (#+ Random)]]] + {1 + ["." / ("#@." monoid)]}) -(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)))) +(def: injection + (Injection Maybe) + (|>> #.Some)) - (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))))) +(def: comparison + (Comparison Maybe) + (function (_ ==) + (:: (/.equivalence ==) =))) - (do r.monad - [default r.nat - maybe r.nat] - (_.test "Can have defaults for Maybe values." - (and (is? default (maybe.default default - #.None)) +(def: #export maybe + (All [a] (-> (Random a) (Random (Maybe a)))) + (:: r.functor map (|>> #.Some))) - (is? maybe (maybe.default default - (#.Some maybe)))))) - ))) +(def: #export test + Test + (<| (_.context (%name (name-of .Maybe))) + ($_ _.and + (equivalenceT.test (/.equivalence nat.equivalence) (..maybe r.nat)) + (functorT.laws ..injection ..comparison /.functor) + (applyT.laws ..injection ..comparison /.apply) + (monadT.laws ..injection ..comparison /.monad) + (do r.monad + [left r.nat + right r.nat + #let [expected (n/+ left right)]] + (let [lift (/.lift io.monad)] + (_.test "Can add maybe functionality to any monad." + (|> (io.run (do (/.with io.monad) + [a (lift (io@wrap left)) + b (wrap right)] + (wrap (n/+ a b)))) + (case> (#.Some actual) + (n/= expected actual) -(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))))) + _ + false))))) + (let [(^open "/@.") (/.equivalence text.equivalence) + (^open "/@.") /.monoid] + (_.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)))))) + (do r.monad + [default r.nat + value r.nat] + (_.test "Can have defaults for Maybe values." + (and (is? default (/.default default + #.None)) + + (is? value (/.default default + (#.Some value)))))) + ))) diff --git a/stdlib/source/test/lux/data/name.lux b/stdlib/source/test/lux/data/name.lux index 32744ad5f..6582e68ff 100644 --- a/stdlib/source/test/lux/data/name.lux +++ b/stdlib/source/test/lux/data/name.lux @@ -1,73 +1,63 @@ (.module: [lux #* + ["_" test (#+ Test)] [control - [monad (#+ do Monad)] - pipe] + pipe + [monad (#+ do)] + {[0 #test] + [/ + [".T" equivalence] + [".T" codec]]}] [data - ["&" name] - ["." text ("#;." equivalence) + ["." text ("#@." equivalence) format]] [math - ["r" random]]] - lux/test) + ["r" random (#+ Random)]]] + {1 + ["." /]}) -(def: (gen-part size) +(def: (part size) (-> Nat (r.Random Text)) (|> (r.unicode size) (r.filter (|>> (text.contains? ".") not)))) -(context: "Names" - (<| (times 100) - (do @ +(def: #export (name module-size short-size) + (-> Nat Nat (Random Name)) + (r.and (..part module-size) + (..part short-size))) + +(def: #export test + Test + (<| (_.context (%name (name-of .Name))) + (do r.monad [## 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]] + sizeS1 (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) + (^@ name1 [module1 short1]) (..name sizeM1 sizeS1) ## 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)) + sizeS2 (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) + (^@ name2 [module2 short2]) (..name sizeM2 sizeS2)] + ($_ _.and + (equivalenceT.test /.equivalence (..name sizeM1 sizeS1)) + (codecT.test /.codec /.equivalence (..name sizeM1 sizeS1)) + (_.test "Can get the module / short parts of an name." + (and (is? module1 (/.module name1)) + (is? short1 (/.short name1)))) + (let [(^open "/@.") /.codec] + (_.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))) + (let [(^open "/@.") /.equivalence] + ($_ _.and + (_.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)))))) )))) - -(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))))))) |