aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/collection/tree/rose.lux10
-rw-r--r--stdlib/source/lux/data/collection/tree/rose/zipper.lux147
-rw-r--r--stdlib/source/lux/data/number/frac.lux8
-rw-r--r--stdlib/source/lux/data/number/rev.lux2
-rw-r--r--stdlib/source/lux/math/modular.lux23
-rw-r--r--stdlib/source/lux/time/date.lux39
-rw-r--r--stdlib/source/test/lux/control/order.lux14
-rw-r--r--stdlib/source/test/lux/data/collection/tree/rose.lux16
-rw-r--r--stdlib/source/test/lux/data/collection/tree/rose/zipper.lux119
-rw-r--r--stdlib/source/test/lux/macro/code.lux56
-rw-r--r--stdlib/source/test/lux/macro/syntax.lux3
-rw-r--r--stdlib/source/test/lux/math/modular.lux10
-rw-r--r--stdlib/source/test/lux/time/date.lux17
-rw-r--r--stdlib/source/test/lux/time/day.lux11
-rw-r--r--stdlib/source/test/lux/time/duration.lux47
-rw-r--r--stdlib/source/test/lux/time/instant.lux51
-rw-r--r--stdlib/source/test/lux/time/month.lux11
-rw-r--r--stdlib/source/test/lux/world/binary.lux8
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)