aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/test
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/test/lux/control/parser/tree.lux92
-rw-r--r--stdlib/source/test/lux/data/collection/tree/zipper.lux335
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux24
-rw-r--r--stdlib/source/test/lux/type/check.lux4
4 files changed, 301 insertions, 154 deletions
diff --git a/stdlib/source/test/lux/control/parser/tree.lux b/stdlib/source/test/lux/control/parser/tree.lux
index efea74853..93fec1175 100644
--- a/stdlib/source/test/lux/control/parser/tree.lux
+++ b/stdlib/source/test/lux/control/parser/tree.lux
@@ -36,7 +36,7 @@
(!expect (^multi (#try.Success actual)
(n.= expected actual)))))))
-(template: (!cover2 <coverage> <parser> <sample0> <sample1>)
+(template: (!cover/2 <coverage> <parser> <sample0> <sample1>)
(do {! random.monad}
[dummy random.nat
expected (|> random.nat (random.filter (|>> (n.= dummy) not)))]
@@ -112,50 +112,50 @@
(list (tree.leaf expected)
(tree.leaf dummy)
(tree.leaf dummy))))
- (!cover2 [/.next]
- (do //.monad
- [_ /.next
- _ /.next]
- /.value)
- (tree.branch dummy
- (list (tree.branch dummy
- (list (tree.leaf expected)))))
- (tree.branch dummy
- (list (tree.leaf dummy)
- (tree.leaf expected))))
- (!cover2 [/.prev]
- (do //.monad
- [_ /.next
- _ /.next
- _ /.prev]
- /.value)
- (tree.branch dummy
- (list (tree.branch expected
- (list (tree.leaf dummy)))))
- (tree.branch dummy
- (list (tree.leaf expected)
- (tree.leaf dummy))))
- (!cover2 [/.end]
- (do //.monad
- [_ /.end]
- /.value)
- (tree.branch dummy
- (list (tree.branch dummy
- (list (tree.leaf expected)))))
- (tree.branch dummy
- (list (tree.leaf dummy)
- (tree.leaf expected))))
- (!cover2 [/.start]
- (do //.monad
- [_ /.end
- _ /.start]
- /.value)
- (tree.branch expected
- (list (tree.branch dummy
- (list (tree.leaf dummy)))))
- (tree.branch expected
- (list (tree.leaf dummy)
- (tree.leaf dummy))))
+ (!cover/2 [/.next]
+ (do //.monad
+ [_ /.next
+ _ /.next]
+ /.value)
+ (tree.branch dummy
+ (list (tree.branch dummy
+ (list (tree.leaf expected)))))
+ (tree.branch dummy
+ (list (tree.leaf dummy)
+ (tree.leaf expected))))
+ (!cover/2 [/.previous]
+ (do //.monad
+ [_ /.next
+ _ /.next
+ _ /.previous]
+ /.value)
+ (tree.branch dummy
+ (list (tree.branch expected
+ (list (tree.leaf dummy)))))
+ (tree.branch dummy
+ (list (tree.leaf expected)
+ (tree.leaf dummy))))
+ (!cover/2 [/.end]
+ (do //.monad
+ [_ /.end]
+ /.value)
+ (tree.branch dummy
+ (list (tree.branch dummy
+ (list (tree.leaf expected)))))
+ (tree.branch dummy
+ (list (tree.leaf dummy)
+ (tree.leaf expected))))
+ (!cover/2 [/.start]
+ (do //.monad
+ [_ /.end
+ _ /.start]
+ /.value)
+ (tree.branch expected
+ (list (tree.branch dummy
+ (list (tree.leaf dummy)))))
+ (tree.branch expected
+ (list (tree.leaf dummy)
+ (tree.leaf dummy))))
(do {! random.monad}
[dummy random.nat]
(_.cover [/.cannot-move-further]
@@ -167,6 +167,6 @@
[/.down] [/.up]
[/.right] [/.left]
- [/.next] [/.prev]
+ [/.next] [/.previous]
))))))
)))
diff --git a/stdlib/source/test/lux/data/collection/tree/zipper.lux b/stdlib/source/test/lux/data/collection/tree/zipper.lux
index 6d0ab8a6c..f934879ee 100644
--- a/stdlib/source/test/lux/data/collection/tree/zipper.lux
+++ b/stdlib/source/test/lux/data/collection/tree/zipper.lux
@@ -1,114 +1,261 @@
(.module:
[lux #*
- ["%" data/text/format (#+ format)]
["_" test (#+ Test)]
- [abstract/monad (#+ do Monad)]
+ [abstract
+ [monad (#+ do)]
+ {[0 #spec]
+ [/
+ ["$." equivalence]
+ ["$." functor]
+ ["$." comonad]]}]
[control
pipe]
[data
- ["." maybe]
+ ["." product]
+ ["." maybe ("#\." functor)]
["." text]
[number
["n" nat]]
[collection
["." list]]]
[math
- ["r" random]]]
+ ["." random]]]
["." //]
{1
["." / (#+ Zipper)
- ["tree" //]]}
- )
+ ["tree" //]]})
+
+(def: move
+ Test
+ (do random.monad
+ [expected random.nat
+ dummy (random.filter (|>> (n.= expected) not) random.nat)]
+ ($_ _.and
+ (_.cover [/.down]
+ (|> (tree.branch dummy (list (tree.leaf expected)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.up]
+ (|> (tree.branch expected (list (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [/.up]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.right]
+ (|> (tree.branch dummy (list (tree.leaf dummy) (tree.leaf expected)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [/.right]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.rightmost]
+ (|> (tree.branch dummy
+ (list (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf expected)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [/.rightmost]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.left]
+ (|> (tree.branch dummy (list (tree.leaf expected) (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [/.right]
+ [/.left]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.leftmost]
+ (|> (tree.branch dummy
+ (list (tree.leaf expected)
+ (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [/.rightmost]
+ [/.leftmost]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.next]
+ (and (|> (tree.branch dummy
+ (list (tree.leaf expected)
+ (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.next]
+ [/.value (n.= expected) wrap])
+ (maybe.default false))
+ (|> (tree.branch dummy
+ (list (tree.leaf dummy)
+ (tree.leaf expected)))
+ /.zip
+ (do> maybe.monad
+ [/.next]
+ [/.next]
+ [/.value (n.= expected) wrap])
+ (maybe.default false))))
+ (_.cover [/.end]
+ (|> (tree.branch dummy
+ (list (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf expected)))
+ /.zip
+ (do> maybe.monad
+ [/.end]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.start]
+ (|> (tree.branch expected
+ (list (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf dummy)
+ (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.end]
+ [/.start]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.previous]
+ (and (|> (tree.branch expected
+ (list (tree.leaf dummy)
+ (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.next]
+ [/.previous]
+ [/.value (n.= expected) wrap])
+ (maybe.default false))
+ (|> (tree.branch dummy
+ (list (tree.leaf expected)
+ (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.next]
+ [/.next]
+ [/.previous]
+ [/.value (n.= expected) wrap])
+ (maybe.default false))))
+ )))
(def: #export test
Test
- (<| (_.context (%.name (name-of /.Zipper)))
- (do {! r.monad}
- [[size sample] (//.tree r.nat)
- mid-val r.nat
- new-val r.nat
- pre-val r.nat
- post-val r.nat
- #let [(^open "tree@.") (tree.equivalence n.equivalence)
- (^open "list@.") (list.equivalence n.equivalence)]]
+ (<| (_.covering /._)
+ (_.with-cover [/.Zipper])
+ (do {! random.monad}
+ [[size sample] (//.tree random.nat)
+ expected random.nat
+ dummy (random.filter (|>> (n.= expected) not) random.nat)
+ #let [(^open "tree\.") (tree.equivalence n.equivalence)
+ (^open "list\.") (list.equivalence n.equivalence)]]
($_ _.and
- (_.test "Trees can be converted to/from zippers."
- (|> sample
- /.zip /.unzip
- (tree@= sample)))
- (_.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 /.start (is? zipper) not)))
- (and (/.leaf? zipper)
- (|> zipper (/.prepend-child new-val) /.branch?)))))
- (do !
- [branch-value r.nat
- #let [zipper (|> (/.zip (tree.branch branch-value (list (tree.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 (tree.branch branch-value (list (tree.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."
- (let [root (/.zip sample)]
- (list@= (tree.flatten sample)
- (loop [zipper (/.start root)]
- (let [zipper' (/.next zipper)]
- (#.Cons (/.value zipper)
- (if (:: (/.equivalence n.equivalence) = root zipper')
- (list)
- (recur zipper'))))))))
- (_.test "Backwards zipper traversal yield reverse tree flatten."
- (let [root (/.zip sample)]
- (list@= (list.reverse (tree.flatten sample))
- (loop [zipper (/.end root)]
- (#.Cons (/.value zipper)
- (if (:: (/.equivalence n.equivalence) = root zipper)
- (list)
- (recur (/.prev zipper))))))))
- (_.test "Can remove nodes (except start nodes)."
- (let [zipper (/.zip sample)]
- (if (/.branch? zipper)
- (and (|> zipper /.down /.start? not)
- (|> zipper /.down /.remove (case> #.None false
- (#.Some node) (/.start? node))))
- (|> zipper /.remove (case> #.None true
- (#.Some _) false)))))
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec (/.equivalence n.equivalence) (:: ! map (|>> product.right /.zip) (//.tree random.nat))))
+ (_.with-cover [/.functor]
+ ($functor.spec (|>> tree.leaf /.zip) /.equivalence /.functor))
+ (_.with-cover [/.comonad]
+ ($comonad.spec (|>> tree.leaf /.zip) /.equivalence /.comonad))
+
+ (_.cover [/.zip /.unzip]
+ (|> sample /.zip /.unzip (tree\= sample)))
+ (_.cover [/.start?]
+ (|> sample /.zip /.start?))
+ (_.cover [/.leaf?]
+ (/.leaf? (/.zip (tree.leaf expected))))
+ (_.cover [/.branch?]
+ (and (/.branch? (/.zip (tree.branch expected (list (tree.leaf expected)))))
+ (not (/.branch? (/.zip (tree.branch expected (list)))))))
+ (_.cover [/.value]
+ (and (n.= expected (/.value (/.zip (tree.leaf expected))))
+ (n.= expected (/.value (/.zip (tree.branch expected (list (tree.leaf expected))))))))
+ (_.cover [/.set]
+ (|> (/.zip (tree.leaf dummy))
+ (/.set expected)
+ /.value
+ (n.= expected)))
+ (_.cover [/.update]
+ (|> (/.zip (tree.leaf expected))
+ (/.update inc)
+ /.value
+ (n.= (inc expected))))
+ ..move
+ (_.cover [/.end?]
+ (or (/.end? (/.zip sample))
+ (|> sample
+ /.zip
+ /.end
+ (maybe\map /.end?)
+ (maybe.default false))))
+ (_.cover [/.interpose]
+ (let [cursor (|> (tree.branch dummy (list (tree.leaf dummy)))
+ /.zip
+ (/.interpose expected))]
+ (and (n.= dummy (/.value cursor))
+ (|> cursor
+ (do> maybe.monad
+ [/.down]
+ [/.value (n.= expected) wrap])
+ (maybe.default false))
+ (|> cursor
+ (do> maybe.monad
+ [/.down]
+ [/.down]
+ [/.value (n.= dummy) wrap])
+ (maybe.default false)))))
+ (_.cover [/.adopt]
+ (let [cursor (|> (tree.branch dummy (list (tree.leaf dummy)))
+ /.zip
+ (/.adopt expected))]
+ (and (n.= dummy (/.value cursor))
+ (|> cursor
+ (do> maybe.monad
+ [/.down]
+ [/.value (n.= expected) wrap])
+ (maybe.default false))
+ (|> cursor
+ (do> maybe.monad
+ [/.down]
+ [/.right]
+ [/.value (n.= dummy) wrap])
+ (maybe.default false)))))
+ (_.cover [/.insert-left]
+ (|> (tree.branch dummy (list (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [(/.insert-left expected)]
+ [/.left]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.insert-right]
+ (|> (tree.branch dummy (list (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [(/.insert-right expected)]
+ [/.right]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
+ (_.cover [/.remove]
+ (|> (tree.branch dummy (list (tree.leaf dummy)))
+ /.zip
+ (do> maybe.monad
+ [/.down]
+ [(/.insert-left expected)]
+ [/.remove]
+ [/.value (n.= expected) wrap])
+ (maybe.default false)))
))))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux
index faa3fa85f..2f3e7e8ba 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux
@@ -59,19 +59,19 @@
(r@wrap (list (' #0) (' #1)))
(^template [<tag> <gen> <wrapper>]
- [_ (<tag> _)]
- (if allow-literals?
- (do {! r.monad}
- [?sample (r.maybe <gen>)]
- (case ?sample
- (#.Some sample)
- (do !
- [else (exhaustive-branches allow-literals? variantTC inputC)]
- (wrap (list& (<wrapper> sample) else)))
+ [[_ (<tag> _)]
+ (if allow-literals?
+ (do {! r.monad}
+ [?sample (r.maybe <gen>)]
+ (case ?sample
+ (#.Some sample)
+ (do !
+ [else (exhaustive-branches allow-literals? variantTC inputC)]
+ (wrap (list& (<wrapper> sample) else)))
- #.None
- (wrap (list (' _)))))
- (r@wrap (list (' _)))))
+ #.None
+ (wrap (list (' _)))))
+ (r@wrap (list (' _))))])
([#.Nat r.nat code.nat]
[#.Int r.int code.int]
[#.Rev r.rev code.rev]
diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux
index 3936c7a65..4846f5e7d 100644
--- a/stdlib/source/test/lux/type/check.lux
+++ b/stdlib/source/test/lux/type/check.lux
@@ -71,8 +71,8 @@
#1
(^template [<tag>]
- (<tag> left right)
- (and (valid-type? left) (valid-type? right)))
+ [(<tag> left right)
+ (and (valid-type? left) (valid-type? right))])
([#.Sum] [#.Product] [#.Function])
(#.Named name type')