From a869f51e0ea3fe0c224de1188ad5bbd5db080f47 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 28 Mar 2019 20:15:40 -0400 Subject: Fixed some tests. --- stdlib/source/test/lux/control/order.lux | 14 +-- .../source/test/lux/data/collection/tree/rose.lux | 16 ++- .../test/lux/data/collection/tree/rose/zipper.lux | 119 ++++++++++----------- stdlib/source/test/lux/macro/code.lux | 56 ++++++---- stdlib/source/test/lux/macro/syntax.lux | 3 +- stdlib/source/test/lux/math/modular.lux | 10 +- stdlib/source/test/lux/time/date.lux | 17 ++- stdlib/source/test/lux/time/day.lux | 11 +- stdlib/source/test/lux/time/duration.lux | 47 ++++---- stdlib/source/test/lux/time/instant.lux | 51 ++++----- stdlib/source/test/lux/time/month.lux | 11 +- stdlib/source/test/lux/world/binary.lux | 8 +- 12 files changed, 196 insertions(+), 167 deletions(-) (limited to 'stdlib/source/test') diff --git a/stdlib/source/test/lux/control/order.lux b/stdlib/source/test/lux/control/order.lux index b57489b0f..f18d110c2 100644 --- a/stdlib/source/test/lux/control/order.lux +++ b/stdlib/source/test/lux/control/order.lux @@ -11,7 +11,7 @@ {1 ["." / (#+ Order)]}) -(def: #export (spec (^open "_@.") generator) +(def: #export (spec (^open ",@.") generator) (All [a] (-> (Order a) (Random a) Test)) (do r.monad [left generator @@ -19,9 +19,9 @@ (<| (_.context (%name (name-of /.Order))) ($_ _.and (_.test "Values are either ordered, or they are equal. All options are mutually exclusive." - (if (_@= left right) - (not (or (_@< left right) - (_@> left right))) - (if (_@< left right) - (not (_@> left right)) - (_@> left right)))))))) + (if (,@= left right) + (not (or (,@< left right) + (,@> left right))) + (if (,@< left right) + (not (,@> left right)) + (,@> left right)))))))) diff --git a/stdlib/source/test/lux/data/collection/tree/rose.lux b/stdlib/source/test/lux/data/collection/tree/rose.lux index 383e250b5..987a72f45 100644 --- a/stdlib/source/test/lux/data/collection/tree/rose.lux +++ b/stdlib/source/test/lux/data/collection/tree/rose.lux @@ -28,20 +28,28 @@ 1 singleton + + 2 + (do r.monad + [value gen-value + single (tree 1 gen-value)] + (wrap (/.branch value (list single)))) _ (do r.monad [value gen-value - children (r.list (n/+ 2 (n/% 2 size)) - (tree (n// 2 size) gen-value))] - (wrap (/.branch value children))) + #let [size (dec size)] + left (tree (n// 2 size) gen-value) + right (tree (n/+ (n/% 2 size) (n// 2 size)) + gen-value)] + (wrap (/.branch value (list left right)))) ))) (def: #export test Test (<| (_.context (%name (name-of /.Tree))) (do r.monad - [size (:: @ map (|>> (n/% 100) (n/max 10)) r.nat)] + [size (:: @ map (|>> (n/% 100) (n/+ 1)) r.nat)] ($_ _.and ($equivalence.spec (/.equivalence nat.equivalence) (..tree size r.nat)) ($fold.spec /.leaf /.equivalence /.fold) diff --git a/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux index 379b17c16..3a3bd296c 100644 --- a/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux +++ b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux @@ -21,19 +21,13 @@ ["." / (#+ Zipper)]} ) -(def: (to-end zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (loop [zipper zipper] - (if (/.end? zipper) - zipper - (recur (/.next zipper))))) - (def: #export test Test (<| (_.context (%name (name-of /.Zipper))) (do r.monad - [size (:: @ map (|>> (n/% 100) (n/max 10)) r.nat) + [size (:: @ map (|>> (n/% 90) (n/+ 10)) r.nat) sample (//.tree size r.nat) + mid-val r.nat new-val r.nat pre-val r.nat post-val r.nat @@ -44,74 +38,79 @@ (|> sample /.zip /.unzip (tree@= sample))) - (_.test "Creating a zipper gives you a root node." - (|> sample /.zip /.root?)) + (_.test "Creating a zipper gives you a start node." + (|> sample /.zip /.start?)) (_.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))) + (|> child /.start (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)))) - true))) - (_.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 _) false - #.None true)) - (|> zipper (/.insert-right post-val) (case> (#.Some _) false - #.None true)))))) + (do @ + [branch-value r.nat + #let [zipper (|> (/.zip (rose.branch branch-value (list (rose.leaf mid-val)))) + (/.prepend-child pre-val) + (/.append-child post-val))]] + (_.test "Can prepend and append children." + (and (and (|> zipper /.down /.value (is? pre-val)) + (|> zipper /.down /.right /.left /.value (is? pre-val)) + (|> zipper /.down /.rightmost /.leftmost /.value (is? pre-val))) + (|> zipper /.down /.right /.value (is? mid-val)) + (and (|> zipper /.down /.right /.right /.value (is? post-val)) + (|> zipper /.down /.rightmost /.value (is? post-val)))))) + (do @ + [branch-value r.nat + #let [zipper (/.zip (rose.branch branch-value (list (rose.leaf mid-val))))]] + (_.test "Can insert children around a node (unless it's start)." + (and (let [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 _) false + #.None true)) + (|> zipper + (/.insert-right post-val) + (case> (#.Some _) false + #.None true)))))) (_.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))))))) + (let [root (/.zip sample)] + (list@= (rose.flatten sample) + (loop [zipper (/.start root)] + (let [zipper' (/.next zipper)] + (#.Cons (/.value zipper) + (if (:: (/.equivalence nat.equivalence) = root zipper') + (list) + (recur 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)) + (let [root (/.zip sample)] + (list@= (list.reverse (rose.flatten sample)) + (loop [zipper (/.end root)] (#.Cons (/.value zipper) - (recur (/.prev zipper))))))) - (_.test "Can remove nodes (except root nodes)." + (if (:: (/.equivalence nat.equivalence) = root zipper) + (list) + (recur (/.prev zipper)))))))) + (_.test "Can remove nodes (except start nodes)." (let [zipper (/.zip sample)] (if (/.branch? zipper) - (and (|> zipper /.down /.root? not) + (and (|> zipper /.down /.start? not) (|> zipper /.down /.remove (case> #.None false - (#.Some node) (/.root? node)))) + (#.Some node) (/.start? node)))) (|> zipper /.remove (case> #.None true (#.Some _) false))))) )))) diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux index 3dc7ec7d4..5ec12e6e2 100644 --- a/stdlib/source/test/lux/macro/code.lux +++ b/stdlib/source/test/lux/macro/code.lux @@ -11,23 +11,41 @@ (def: #export test Test - (`` ($_ _.and - (~~ (do-template [ ] - [(_.test (format "Can produce Code node: " ) - (and (text@= (/.to-text )) - (:: /.equivalence = )))] + (<| (_.context (%name (name-of /._))) + (do r.monad + [bit r.bit + nat r.nat + int r.int + rev r.rev + above (:: @ map (i/% +100) r.int) + below (:: @ map (i/% +100) r.int) + #let [frac (|> below + (i// +100) + .int-to-frac + (f/+ (.int-to-frac above)) + (f/* -1.0))] + text (r.ascii 10) + short (r.ascii/alpha 10) + module (r.ascii/alpha 10) + #let [name [module short]]] + (`` ($_ _.and + (~~ (do-template [ ] + [(let [code ] + (_.test (format "Can produce " " code node.") + (and (text@= (/.to-text code)) + (:: /.equivalence = code code))))] - [(/.bit #1) "#1"] - [(/.bit #0) "#0"] - [(/.nat 123) "123"] - [(/.int +123) "+123"] - [(/.frac +123.0) "+123.0"] - [(/.text "1234") (format text.double-quote "1234" text.double-quote)] - [(/.local-tag "lol") "#lol"] - [(/.tag ["yolo" "lol"]) "#yolo.lol"] - [(/.local-identifier "lol") "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}"] - ))))) + ["bit" (/.bit bit) (%b bit)] + ["nat" (/.nat nat) (%n nat)] + ["int" (/.int int) (%i int)] + ["rev" (/.rev rev) (%r rev)] + ["frac" (/.frac frac) (%f frac)] + ["text" (/.text text) (%t text)] + ["local-ltag" (/.local-tag short) (format "#" short)] + ["lag" (/.tag [module short]) (format "#" (%name name))] + ["local-identifier" (/.local-identifier short) short] + ["identifier" (/.identifier [module short]) (%name name)] + ["form" (/.form (list (/.bit bit) (/.int int))) (format "(" (%b bit) " " (%i int) ")")] + ["tuple" (/.tuple (list (/.bit bit) (/.int int))) (format "[" (%b bit) " " (%i int) "]")] + ["record" (/.record (list [(/.bit bit) (/.int int)])) (format "{" (%b bit) " " (%i int) "}")] + ))))))) diff --git a/stdlib/source/test/lux/macro/syntax.lux b/stdlib/source/test/lux/macro/syntax.lux index afe5f208e..e9f0428a1 100644 --- a/stdlib/source/test/lux/macro/syntax.lux +++ b/stdlib/source/test/lux/macro/syntax.lux @@ -152,5 +152,4 @@ /.end!)) (fails? (p.run (list (code.bit #1)) /.end!)))) - ) - ))) + )))) diff --git a/stdlib/source/test/lux/math/modular.lux b/stdlib/source/test/lux/math/modular.lux index 242b08503..97655ee9b 100644 --- a/stdlib/source/test/lux/math/modular.lux +++ b/stdlib/source/test/lux/math/modular.lux @@ -106,7 +106,7 @@ (/.m/= (/.mod normalM +1))) #.None - #1)) + true)) (_.test "Can encode/decode to text." (let [(^open "mod/.") (/.codec normalM)] (case (|> subject mod/encode mod/decode) @@ -114,7 +114,7 @@ (/.m/= subject output) (#error.Failure error) - #0))) + false))) (_.test "Can equalize 2 moduli if they are equal." (case (/.equalize (/.mod normalM _subject) (/.mod copyM _param)) @@ -122,15 +122,15 @@ (/.m/= param paramC) (#error.Failure error) - #0)) + false)) (_.test "Cannot equalize 2 moduli if they are the different." (case (/.equalize (/.mod normalM _subject) (/.mod alternativeM _param)) (#error.Success paramA) - #0 + false (#error.Failure error) - #1)) + true)) (_.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." diff --git a/stdlib/source/test/lux/time/date.lux b/stdlib/source/test/lux/time/date.lux index 935e59c51..ffd055e35 100644 --- a/stdlib/source/test/lux/time/date.lux +++ b/stdlib/source/test/lux/time/date.lux @@ -1,15 +1,14 @@ (.module: [lux #* data/text/format + ["r" math/random (#+ Random)] ["_" test (#+ Test)] - [control + [control ["." monad (#+ do)] {[0 #test] [/ ["$." equivalence] ["$." order] ["$." codec]]}] - [math - ["r" random (#+ Random)]] [time ["@." instant]]] [// @@ -23,9 +22,9 @@ (def: #export test Test - ($_ _.and - ($equivalence.spec /.equivalence ..date) - ($order.spec /.order ..date) - (<| (_.seed 6623983470548808292) - ($codec.spec /.equivalence /.codec ..date)) - )) + (<| (_.context (%name (name-of /._))) + ($_ _.and + ($equivalence.spec /.equivalence ..date) + ($order.spec /.order ..date) + ($codec.spec /.equivalence /.codec ..date) + ))) diff --git a/stdlib/source/test/lux/time/day.lux b/stdlib/source/test/lux/time/day.lux index e0142d1b4..84d404a21 100644 --- a/stdlib/source/test/lux/time/day.lux +++ b/stdlib/source/test/lux/time/day.lux @@ -25,8 +25,9 @@ (def: #export test Test - ($_ _.and - ($equivalence.spec /.equivalence ..day) - ($order.spec /.order ..day) - ($enum.spec /.enum ..day) - )) + (<| (_.context (%name (name-of /._))) + ($_ _.and + ($equivalence.spec /.equivalence ..day) + ($order.spec /.order ..day) + ($enum.spec /.enum ..day) + ))) diff --git a/stdlib/source/test/lux/time/duration.lux b/stdlib/source/test/lux/time/duration.lux index ba0e35cf1..a7265f62f 100644 --- a/stdlib/source/test/lux/time/duration.lux +++ b/stdlib/source/test/lux/time/duration.lux @@ -23,27 +23,28 @@ (def: #export test Test - ($_ _.and - ($equivalence.spec /.equivalence ..duration) - ($order.spec /.order ..duration) - ($monoid.spec /.equivalence /.monoid ..duration) - ## TODO; Uncomment ASAP - ## ($codec.spec /.equivalence /.codec ..duration) + (<| (_.context (%name (name-of /._))) + ($_ _.and + ($equivalence.spec /.equivalence ..duration) + ($order.spec /.order ..duration) + ($monoid.spec /.equivalence /.monoid ..duration) + ## TODO; Uncomment ASAP + ## ($codec.spec /.equivalence /.codec ..duration) - (do r.monad - [millis r.int] - (_.test "Can convert from/to milliseconds." - (|> millis /.from-millis /.to-millis (i/= millis)))) - (do r.monad - [sample (|> duration (:: @ map (/.frame /.day))) - frame duration - factor (|> r.nat (:: @ map (|>> (n/% 10) (n/max 1)))) - #let [(^open "/@.") /.order]] - ($_ _.and - (_.test "Can scale a duration." - (|> sample (/.scale-up factor) (/.query sample) (i/= (.int factor)))) - (_.test "Scaling a duration by one does not change it." - (|> sample (/.scale-up 1) (/@= sample))) - (_.test "Merging a duration with it's opposite yields an empty duration." - (|> sample (/.merge (/.inverse sample)) (/@= /.empty))))) - )) + (do r.monad + [millis r.int] + (_.test "Can convert from/to milliseconds." + (|> millis /.from-millis /.to-millis (i/= millis)))) + (do r.monad + [sample (|> duration (:: @ map (/.frame /.day))) + frame duration + factor (|> r.nat (:: @ map (|>> (n/% 10) (n/max 1)))) + #let [(^open "/@.") /.order]] + ($_ _.and + (_.test "Can scale a duration." + (|> sample (/.scale-up factor) (/.query sample) (i/= (.int factor)))) + (_.test "Scaling a duration by one does not change it." + (|> sample (/.scale-up 1) (/@= sample))) + (_.test "Merging a duration with it's opposite yields an empty duration." + (|> sample (/.merge (/.inverse sample)) (/@= /.empty))))) + ))) diff --git a/stdlib/source/test/lux/time/instant.lux b/stdlib/source/test/lux/time/instant.lux index ec4a9456c..9b903d993 100644 --- a/stdlib/source/test/lux/time/instant.lux +++ b/stdlib/source/test/lux/time/instant.lux @@ -31,29 +31,30 @@ (def: #export test Test - ($_ _.and - ($equivalence.spec /.equivalence ..instant) - ($order.spec /.order ..instant) - ($enum.spec /.enum ..instant) - ## TODO; Uncomment ASAP - ## ($codec.spec /.equivalence /.codec ..instant) + (<| (_.context (%name (name-of /._))) + ($_ _.and + ($equivalence.spec /.equivalence ..instant) + ($order.spec /.order ..instant) + ($enum.spec /.enum ..instant) + ## TODO; Uncomment ASAP + ## ($codec.spec /.equivalence /.codec ..instant) - (do r.monad - [millis r.int] - (_.test "Can convert from/to milliseconds." - (|> millis /.from-millis /.to-millis (i/= millis)))) - (do r.monad - [sample instant - span _duration.duration - #let [(^open "@/.") /.equivalence - (^open "@d/.") @d.equivalence]] - ($_ _.and - (_.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))))) - )) + (do r.monad + [millis r.int] + (_.test "Can convert from/to milliseconds." + (|> millis /.from-millis /.to-millis (i/= millis)))) + (do r.monad + [sample instant + span _duration.duration + #let [(^open "@/.") /.equivalence + (^open "@d/.") @d.equivalence]] + ($_ _.and + (_.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))))) + ))) diff --git a/stdlib/source/test/lux/time/month.lux b/stdlib/source/test/lux/time/month.lux index 4c9365bb6..f0722af0b 100644 --- a/stdlib/source/test/lux/time/month.lux +++ b/stdlib/source/test/lux/time/month.lux @@ -30,8 +30,9 @@ (def: #export test Test - ($_ _.and - ($equivalence.spec /.equivalence ..month) - ($order.spec /.order ..month) - ($enum.spec /.enum ..month) - )) + (<| (_.context (%name (name-of /._))) + ($_ _.and + ($equivalence.spec /.equivalence ..month) + ($order.spec /.order ..month) + ($enum.spec /.enum ..month) + ))) diff --git a/stdlib/source/test/lux/world/binary.lux b/stdlib/source/test/lux/world/binary.lux index 2f347c50d..2e463ea4b 100644 --- a/stdlib/source/test/lux/world/binary.lux +++ b/stdlib/source/test/lux/world/binary.lux @@ -39,9 +39,11 @@ (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))] + (let [binary (/.create bytes) + cap (case bytes + 8 (dec 0) + _ (|> 1 (i64.left-shift (n/* 8 bytes)) dec)) + capped-value (i64.and cap value)] (succeed (do error.monad [_ (write 0 value binary) -- cgit v1.2.3