diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/collection/tree/rose.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/tree/rose/zipper.lux | 147 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number/frac.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number/rev.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/math/modular.lux | 23 | ||||
| -rw-r--r-- | stdlib/source/lux/time/date.lux | 39 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/order.lux | 14 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/collection/tree/rose.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/collection/tree/rose/zipper.lux | 119 | ||||
| -rw-r--r-- | stdlib/source/test/lux/macro/code.lux | 56 | ||||
| -rw-r--r-- | stdlib/source/test/lux/macro/syntax.lux | 3 | ||||
| -rw-r--r-- | stdlib/source/test/lux/math/modular.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/test/lux/time/date.lux | 17 | ||||
| -rw-r--r-- | stdlib/source/test/lux/time/day.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/test/lux/time/duration.lux | 47 | ||||
| -rw-r--r-- | stdlib/source/test/lux/time/instant.lux | 51 | ||||
| -rw-r--r-- | stdlib/source/test/lux/time/month.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/test/lux/world/binary.lux | 8 |
18 files changed, 337 insertions, 255 deletions
diff --git a/stdlib/source/lux/data/collection/tree/rose.lux b/stdlib/source/lux/data/collection/tree/rose.lux index 209b6af40..97cb840fb 100644 --- a/stdlib/source/lux/data/collection/tree/rose.lux +++ b/stdlib/source/lux/data/collection/tree/rose.lux @@ -8,7 +8,7 @@ fold] [data [collection - ["." list ("#;." monad fold)]]] + ["." list ("#@." monad fold)]]] ["." macro ["." code] ["s" syntax (#+ syntax: Syntax)]]]) @@ -20,7 +20,7 @@ (def: #export (flatten tree) (All [a] (-> (Tree a) (List a))) (#.Cons (get@ #value tree) - (list;join (list;map flatten (get@ #children tree))))) + (list@join (list@map flatten (get@ #children tree))))) (def: #export (leaf value) (All [a] (-> a (Tree a))) @@ -51,7 +51,7 @@ +40 {}}]))} (wrap (list (` (~ (loop [[value children] root] (` {#value (~ value) - #children (list (~+ (list;map recur children)))}))))))) + #children (list (~+ (list@map recur children)))}))))))) (structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) (def: (= tx ty) @@ -61,12 +61,12 @@ (structure: #export functor (Functor Tree) (def: (map f fa) {#value (f (get@ #value fa)) - #children (list;map (map f) + #children (list@map (map f) (get@ #children fa))})) (structure: #export fold (Fold Tree) (def: (fold f init tree) - (list;fold (function (_ tree' init') (fold f init' tree')) + (list@fold (function (_ tree' init') (fold f init' tree')) (f (get@ #value tree) init) (get@ #children tree)))) diff --git a/stdlib/source/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/lux/data/collection/tree/rose/zipper.lux index 61de6d585..9472d7d26 100644 --- a/stdlib/source/lux/data/collection/tree/rose/zipper.lux +++ b/stdlib/source/lux/data/collection/tree/rose/zipper.lux @@ -2,20 +2,18 @@ [lux #* [control functor - comonad] + comonad + [equivalence (#+ Equivalence)]] [data - ["." maybe ("#;." monad)] + ["." maybe ("#@." monad)] [collection - ["." list ("#;." functor fold monoid)] + ["." list ("#@." functor fold monoid)] ["." stack (#+ Stack)]]] ["." macro ["." code] ["s" syntax (#+ Syntax syntax:)]]] - ["." // (#+ Tree) ("#;." functor)]) + ["." // (#+ Tree) ("#@." functor)]) -## Adapted from the clojure.zip namespace in the Clojure standard library. - -## [Types] (type: #export (Zipper a) {#.doc "Tree zippers, for easy navigation and editing over trees."} {#parent (Maybe (Zipper a)) @@ -23,7 +21,25 @@ #rights (Stack (Tree a)) #node (Tree a)}) -## [Values] +(structure: #export (equivalence ,equivalence) + (All [a] + (-> (Equivalence a) + (Equivalence (Zipper a)))) + (def: (= reference sample) + (and (:: (//.equivalence ,equivalence) = + (get@ #node reference) + (get@ #node sample)) + (:: (stack.equivalence (//.equivalence ,equivalence)) = + (get@ #lefts reference) + (get@ #lefts sample)) + (:: (stack.equivalence (//.equivalence ,equivalence)) = + (get@ #rights reference) + (get@ #rights sample)) + (:: (maybe.equivalence (equivalence ,equivalence)) = + (get@ #parent reference) + (get@ #parent sample)) + ))) + (def: #export (zip tree) (All [a] (-> (Tree a) (Zipper a))) {#parent #.None @@ -51,12 +67,7 @@ (All [a] (-> (Zipper a) Bit)) (|> zipper branch? not)) -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bit)) - (and (list.empty? (get@ #rights zipper)) - (list.empty? (children zipper)))) - -(def: #export (root? zipper) +(def: #export (start? zipper) (All [a] (-> (Zipper a) Bit)) (case (get@ #parent zipper) #.None @@ -71,11 +82,11 @@ #.Nil zipper - (#.Cons chead ctail) + (#.Cons head tail) {#parent (#.Some zipper) #lefts stack.empty - #rights ctail - #node chead})) + #rights tail + #node head})) (def: #export (up zipper) (All [a] (-> (Zipper a) (Zipper a))) @@ -88,26 +99,26 @@ ## TODO: Remove once new-luxc becomes the standard compiler. (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) (function (_ node) - (set@ #//.children (list;compose (list.reverse (get@ #lefts zipper)) + (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) (#.Cons (get@ #node zipper) (get@ #rights zipper))) node)))) ## (update@ #node (function (_ node) - ## (set@ #//.children (list;compose (list.reverse (get@ #lefts zipper)) + ## (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) ## (#.Cons (get@ #node zipper) ## (get@ #rights zipper))) ## node))) ))) -(def: #export (root zipper) +(def: #export (start zipper) (All [a] (-> (Zipper a) (Zipper a))) - (loop [zipper zipper] - (case (get@ #parent zipper) - #.None zipper - (#.Some _) (recur (up zipper))))) + (let [ancestor (..up zipper)] + (if (is? zipper ancestor) + zipper + (start ancestor)))) -(do-template [<one-name> <all-name> <side> <op-side>] - [(def: #export (<one-name> zipper) +(do-template [<one> <all> <side> <op-side>] + [(def: #export (<one> zipper) (All [a] (-> (Zipper a) (Zipper a))) (case (get@ <side> zipper) #.Nil @@ -120,27 +131,63 @@ (set@ <side> side') (set@ #node next)))) - (def: #export (<all-name> zipper) + (def: #export (<all> zipper) (All [a] (-> (Zipper a) (Zipper a))) - (list;fold (function (_ _) <one-name>) zipper (get@ <side> zipper)))] + (case (list.reverse (get@ <side> zipper)) + #.Nil + zipper + + (#.Cons last prevs) + (|> zipper + (set@ <side> #.Nil) + (set@ <op-side> (|> (get@ <op-side> zipper) + (#.Cons (get@ #node zipper)) + (list@compose prevs))) + (set@ #node last))))] [right rightmost #rights #lefts] [left leftmost #lefts #rights] ) -(do-template [<name> <h-side> <h-op> <v-op>] - [(def: #export (<name> zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ <h-side> zipper) - #.Nil - (<v-op> zipper) - - _ - (<h-op> zipper)))] - - [next #rights right down] - [prev #lefts left up] - ) +(def: #export (next zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [forward (..down zipper)] + (if (is? zipper forward) + (loop [zipper zipper] + (let [jump (..right zipper)] + (if (is? zipper jump) + (let [backward (..up zipper)] + (if (is? zipper backward) + zipper + (recur backward))) + jump))) + forward))) + +(def: #export (end zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #rights zipper) + #.Nil + (case (get@ [#node #//.children] zipper) + #.Nil + zipper + + (#.Cons _) + (end (..down zipper))) + + (#.Cons _) + (end (..rightmost zipper)))) + +(def: #export (prev zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (let [forward (..left zipper)] + (if (is? zipper forward) + (..up zipper) + (case (get@ [#node #//.children] forward) + #.Nil + forward + + (#.Cons _) + (..end (..down forward)))))) (def: #export (set value zipper) (All [a] (-> a (Zipper a) (Zipper a))) @@ -167,7 +214,7 @@ (All [a] (-> a (Zipper a) (Zipper a))) (update@ [#node #//.children] (function (_ children) - (list;compose children + (list@compose children ## TODO: Remove once new-luxc becomes the standard compiler. (list (: (Tree ($ 0)) (//.tree [value {}]))) @@ -216,10 +263,10 @@ (structure: #export functor (Functor Zipper) (def: (map f fa) - {#parent (|> fa (get@ #parent) (maybe;map (map f))) - #lefts (|> fa (get@ #lefts) (list;map (//;map f))) - #rights (|> fa (get@ #rights) (list;map (//;map f))) - #node (//;map f (get@ #node fa))})) + {#parent (|> fa (get@ #parent) (maybe@map (map f))) + #lefts (|> fa (get@ #lefts) (list@map (//@map f))) + #rights (|> fa (get@ #rights) (list@map (//@map f))) + #node (//@map f (get@ #node fa))})) ## TODO: Add again once new-luxc becomes the standard compiler. ## (structure: #export comonad (CoMonad Zipper) @@ -230,9 +277,9 @@ ## (def: (split wa) ## (let [tree-splitter (function (tree-splitter tree) ## {#//.value (zip tree) -## #//.children (list;map tree-splitter +## #//.children (list@map tree-splitter ## (get@ #//.children tree))})] -## {#parent (|> wa (get@ #parent) (maybe;map split)) -## #lefts (|> wa (get@ #lefts) (list;map tree-splitter)) -## #rights (|> wa (get@ #rights) (list;map tree-splitter)) +## {#parent (|> wa (get@ #parent) (maybe@map split)) +## #lefts (|> wa (get@ #lefts) (list@map tree-splitter)) +## #rights (|> wa (get@ #rights) (list@map tree-splitter)) ## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux index 6847d4a59..d67d582f6 100644 --- a/stdlib/source/lux/data/number/frac.lux +++ b/stdlib/source/lux/data/number/frac.lux @@ -92,7 +92,9 @@ (structure: #export decimal (Codec Text Frac) (def: (encode x) - ("lux frac encode" [x])) + (if (f/< +0.0 x) + ("lux frac encode" x) + ("lux text concat" "+" ("lux frac encode" x)))) (def: (decode input) (case ("lux frac decode" [input]) @@ -354,7 +356,7 @@ ["FFF0000000000000" negative-infinity-bits] ["0000000000000000" positive-zero-bits] ["8000000000000000" negative-zero-bits] - ["7FF" special-exponent-bits] + ["7FF" special-exponent-bits] ) (def: #export (frac-to-bits input) @@ -403,7 +405,7 @@ [mantissa mantissa-mask mantissa-size 0] [exponent exponent-mask exponent-size mantissa-size] - [sign sign-mask 1 (n/+ exponent-size mantissa-size)] + [sign sign-mask 1 (n/+ exponent-size mantissa-size)] ) (def: #export (bits-to-frac input) diff --git a/stdlib/source/lux/data/number/rev.lux b/stdlib/source/lux/data/number/rev.lux index eb2286e65..798844ba7 100644 --- a/stdlib/source/lux/data/number/rev.lux +++ b/stdlib/source/lux/data/number/rev.lux @@ -168,7 +168,7 @@ (recur (dec idx) #0 ("lux text concat" - (:: //int.decimal encode (.int digit)) + (:: //nat.decimal encode digit) output)))) (if all-zeroes? "0" diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux index 313255d82..2d2c6dee7 100644 --- a/stdlib/source/lux/math/modular.lux +++ b/stdlib/source/lux/math/modular.lux @@ -8,8 +8,8 @@ [data ["." error (#+ Error)] [number - ["." int ("#;." decimal)]] - ["." text ("#;." monoid) + ["." int ("#@." decimal)]] + ["." text ("#@." monoid) ["l" lexer (#+ Lexer)]]] [type abstract] @@ -38,13 +38,13 @@ (exception: #export [m] (incorrect-modulus {modulus (Modulus m)} {parsed Int}) - (ex.report ["Expected" (int;encode (to-int modulus))] - ["Actual" (int;encode parsed)])) + (ex.report ["Expected" (int@encode (to-int modulus))] + ["Actual" (int@encode parsed)])) (exception: #export [rm sm] (cannot-equalize-moduli {reference (Modulus rm)} {sample (Modulus sm)}) - (ex.report ["Reference" (int;encode (to-int reference))] - ["Sample" (int;encode (to-int sample))])) + (ex.report ["Reference" (int@encode (to-int reference))] + ["Sample" (int@encode (to-int sample))])) (def: #export (congruent? modulus reference sample) (All [m] (-> (Modulus m) Int Int Bit)) @@ -64,8 +64,7 @@ (def: intL (Lexer Int) (p.codec int.decimal - (p.either (l.and (l.one-of "-") (l.many l.decimal)) - (l.many l.decimal)))) + (l.and (l.one-of "-+") (l.many l.decimal)))) (abstract: #export (Mod m) {#.doc "A number under a modulus."} @@ -83,17 +82,17 @@ (All [m] (-> (Mod m) [Int (Modulus m)])) (:representation modular)) - (def: separator Text " mod ") + (def: separator " mod ") (structure: #export (codec modulus) (All [m] (-> (Modulus m) (Codec Text (Mod m)))) (def: (encode modular) (let [[remainder modulus] (:representation modular)] - ($_ text;compose - (int;encode remainder) + ($_ text@compose + (int@encode remainder) separator - (int;encode (to-int modulus))))) + (int@encode (to-int modulus))))) (def: (decode text) (<| (l.run text) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 0eb5c7e88..9ca3b8939 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -5,15 +5,15 @@ [order (#+ Order)] [enum (#+ Enum)] codec - ["p" parser ("#;." functor)] + ["p" parser ("#@." functor)] [monad (#+ do)]] [data ["." error (#+ Error)] ["." maybe] [number - ["." nat ("#;." decimal)] - ["." int ("#;." decimal)]] - ["." text ("#;." monoid) + ["." nat ("#@." decimal)] + ["." int ("#@." decimal)]] + ["." text ("#@." monoid) ["l" lexer]] [collection ["." row (#+ Row row)]]]] @@ -41,11 +41,16 @@ (-> Date Date Bit) (or (i/< (get@ #year reference) (get@ #year sample)) - (:: //month.order < - (get@ #month reference) - (get@ #month sample)) - (n/< (get@ #day reference) - (get@ #day sample)))) + (and (i/= (get@ #year reference) + (get@ #year sample)) + (or (:: //month.order < + (get@ #month reference) + (get@ #month sample)) + (and (:: //month.order = + (get@ #month reference) + (get@ #month sample)) + (n/< (get@ #day reference) + (get@ #day sample))))))) (structure: #export order (Order Date) (def: &equivalence ..equivalence) @@ -62,20 +67,20 @@ ## Based on this: https://stackoverflow.com/a/42936293/6823464 (def: (pad value) (-> Int Text) - (let [digits (nat;encode (.nat value))] + (let [digits (nat@encode (.nat value))] (if (i/< +10 value) - (text;compose "0" digits) + (text@compose "0" digits) digits))) (def: (encode [year month day]) (-> Date Text) - ($_ text;compose + ($_ text@compose (if (i/< +0 year) - (int;encode year) - (nat;encode (.nat year))) + (int@encode year) + (nat@encode (.nat year))) "-" (pad (|> month //month.number inc .int)) "-" - (pad (|> day .int)))) + (pad (|> day .inc .int)))) (def: lex-year (l.Lexer Int) @@ -92,7 +97,7 @@ (def: lex-section (l.Lexer Int) - (p;map .int (p.codec nat.decimal (l.exactly 2 l.decimal)))) + (p@map .int (p.codec nat.decimal (l.exactly 2 l.decimal)))) (def: (leap-years year) (-> Int Int) @@ -155,7 +160,7 @@ (i/<= (.int month-days) utc-day)))] (wrap {#year utc-year #month month - #day (.nat utc-day)}))) + #day (.nat (.dec utc-day))}))) (def: (decode input) (-> Text (Error Date)) 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 [<expr> <text>] - [(_.test (format "Can produce Code node: " <text>) - (and (text@= <text> (/.to-text <expr>)) - (:: /.equivalence = <expr> <expr>)))] + (<| (_.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 [<desc> <code> <text>] + [(let [code <code>] + (_.test (format "Can produce " <desc> " code node.") + (and (text@= <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) |