diff options
Diffstat (limited to 'stdlib/source/test/lux/data')
33 files changed, 3395 insertions, 0 deletions
diff --git a/stdlib/source/test/lux/data/bit.lux b/stdlib/source/test/lux/data/bit.lux new file mode 100644 index 000000000..d064a736b --- /dev/null +++ b/stdlib/source/test/lux/data/bit.lux @@ -0,0 +1,37 @@ +(.module: + [lux #* + [control + ["M" monad (#+ Monad do)]] + [data + bit] + [math + ["r" random]]] + lux/test) + +(context: "Bit operations." + (<| (times 100) + (do @ + [value r.bit] + (test "" (and (not (and value (not value))) + (or value (not value)) + + (not (:: disjunction identity)) + (:: disjunction compose value (not value)) + (:: conjunction identity) + (not (:: conjunction compose value (not value))) + + (:: equivalence = value (not (not value))) + (not (:: equivalence = value (not value))) + + (not (:: equivalence = value ((complement id) value))) + (:: equivalence = value ((complement not) value)) + + (case (|> value + (:: codec encode) + (:: codec decode)) + (#.Right dec-value) + (:: equivalence = value dec-value) + + (#.Left _) + #0) + ))))) diff --git a/stdlib/source/test/lux/data/collection/array.lux b/stdlib/source/test/lux/data/collection/array.lux new file mode 100644 index 000000000..47c384cb7 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/array.lux @@ -0,0 +1,143 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe] + [data + ["." number] + ["." maybe] + [collection + ["@" array (#+ Array)] + ["." list]]] + [math + ["r" random]]] + lux/test) + +(def: bounded-size + (r.Random Nat) + (|> r.nat + (:: r.monad map (|>> (n/% 100) (n/+ 1))))) + +(context: "Arrays and their copies" + (<| (times 100) + (do @ + [size bounded-size + original (r.array size r.nat) + #let [clone (@.clone original) + copy (: (Array Nat) + (@.new size)) + manual-copy (: (Array Nat) + (@.new size))]] + ($_ seq + (test "Size function must correctly return size of array." + (n/= size (@.size original))) + (test "Cloning an array should yield and identical array, but not the same one." + (and (:: (@.equivalence number.equivalence) = original clone) + (not (is? original clone)))) + (test "Full-range manual copies should give the same result as cloning." + (exec (@.copy size 0 original 0 copy) + (and (:: (@.equivalence number.equivalence) = original copy) + (not (is? original copy))))) + (test "Array folding should go over all values." + (exec (:: @.fold fold + (function (_ x idx) + (exec (@.write idx x manual-copy) + (inc idx))) + 0 + original) + (:: (@.equivalence number.equivalence) = original manual-copy))) + (test "Transformations between (full) arrays and lists shouldn't cause lose or change any values." + (|> original + @.to-list @.from-list + (:: (@.equivalence number.equivalence) = original))) + )))) + +(context: "Array mutation" + (<| (times 100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + array (|> (r.array size r.nat) + (r.filter (|>> @.to-list (list.any? n/odd?)))) + #let [value (maybe.assume (@.read idx array))]] + ($_ seq + (test "Shouldn't be able to find a value in an unoccupied cell." + (case (@.read idx (@.delete idx array)) + (#.Some _) #0 + #.None #1)) + (test "You should be able to access values put into the array." + (case (@.read idx (@.write idx value array)) + (#.Some value') (n/= value' value) + #.None #0)) + (test "All cells should be occupied on a full array." + (and (n/= size (@.occupied array)) + (n/= 0 (@.vacant array)))) + (test "Filtering mutates the array to remove invalid values." + (exec (@.filter! n/even? array) + (and (n/< size (@.occupied array)) + (n/> 0 (@.vacant array)) + (n/= size (n/+ (@.occupied array) + (@.vacant array)))))) + )))) + +(context: "Finding values." + (<| (times 100) + (do @ + [size bounded-size + array (|> (r.array size r.nat) + (r.filter (|>> @.to-list (list.any? n/even?))))] + ($_ seq + (test "Can find values inside arrays." + (|> (@.find n/even? array) + (case> (#.Some _) #1 + #.None #0))) + (test "Can find values inside arrays (with access to indices)." + (|> (@.find+ (function (_ idx n) + (and (n/even? n) + (n/< size idx))) + array) + (case> (#.Some _) #1 + #.None #0))))))) + +(context: "Functor" + (<| (times 100) + (do @ + [size bounded-size + array (r.array size r.nat)] + (let [(^open ".") @.functor + (^open ".") (@.equivalence number.equivalence)] + ($_ seq + (test "Functor shouldn't alter original array." + (let [copy (map id array)] + (and (= array copy) + (not (is? array copy))))) + (test "Functor should go over all available array elements." + (let [there (map inc array) + back-again (map dec there)] + (and (not (= array there)) + (= array back-again))))))))) + +(context: "Monoid" + (<| (times 100) + (do @ + [sizeL bounded-size + sizeR bounded-size + left (r.array sizeL r.nat) + right (r.array sizeR r.nat) + #let [(^open ".") @.monoid + (^open ".") (@.equivalence number.equivalence) + fusion (compose left right)]] + ($_ seq + (test "Appending two arrays should produce a new one twice as large." + (n/= (n/+ sizeL sizeR) (@.size fusion))) + (test "First elements of fused array should equal the first array." + (|> (: (Array Nat) + (@.new sizeL)) + (@.copy sizeL 0 fusion 0) + (= left))) + (test "Last elements of fused array should equal the second array." + (|> (: (Array Nat) + (@.new sizeR)) + (@.copy sizeR sizeL fusion 0) + (= right))) + )))) diff --git a/stdlib/source/test/lux/data/collection/bits.lux b/stdlib/source/test/lux/data/collection/bits.lux new file mode 100644 index 000000000..aeeac1429 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/bits.lux @@ -0,0 +1,87 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["." predicate]] + [data + [collection + ["/" bits]]] + [math + ["r" random]]] + lux/test + [test + [lux + [control + ["_eq" equivalence]]]]) + +(def: (size min max) + (-> Nat Nat (r.Random Nat)) + (|> r.nat + (:: r.monad map (|>> (n/% max) (n/max min))))) + +(def: bits + (r.Random /.Bits) + (do r.monad + [size (size 1 1_000) + idx (|> r.nat (:: @ map (n/% size)))] + (wrap (|> /.empty (/.set idx))))) + +(context: "Bits." + (<| (times 100) + (do @ + [size (size 1 1_000) + idx (|> r.nat (:: @ map (n/% size))) + sample bits] + ($_ seq + (test "Can set individual bits." + (and (|> /.empty (/.get idx) not) + (|> /.empty (/.set idx) (/.get idx)))) + (test "Can clear individual bits." + (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not)) + (test "Can flip individual bits." + (and (|> /.empty (/.flip idx) (/.get idx)) + (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not))) + + (test "Bits (only) grow when (and as much as) necessary." + (and (n/= 0 (/.capacity /.empty)) + (|> /.empty (/.set idx) /.capacity + (n/- idx) + (predicate.union (n/>= 0) + (n/< /.chunk-size))))) + (test "Bits (must) shrink when (and as much as) possible." + (let [grown (/.flip idx /.empty)] + (and (n/> 0 (/.capacity grown)) + (is? /.empty (/.flip idx grown))))) + + (test "Intersection can be detected when there are set bits in common." + (and (not (/.intersects? /.empty + /.empty)) + (/.intersects? (/.set idx /.empty) + (/.set idx /.empty)) + (not (/.intersects? (/.set (inc idx) /.empty) + (/.set idx /.empty))))) + (test "Cannot intersect with one's opposite." + (not (/.intersects? sample (/.not sample)))) + + (test "'and' with oneself changes nothing" + (:: /.equivalence = sample (/.and sample sample))) + (test "'and' with one's opposite yields the empty bit-set." + (is? /.empty (/.and sample (/.not sample)))) + + (test "'or' with one's opposite fully saturates a bit-set." + (n/= (/.size (/.or sample (/.not sample))) + (/.capacity sample))) + + (test "'xor' with oneself yields the empty bit-set." + (is? /.empty (/.xor sample sample))) + (test "'xor' with one's opposite fully saturates a bit-set." + (n/= (/.size (/.xor sample (/.not sample))) + (/.capacity sample))) + + (test "Double negation results in original bit-set." + (:: /.equivalence = sample (/.not (/.not sample)))) + (test "Negation does not affect the empty bit-set." + (is? /.empty (/.not /.empty))) + + (_eq.spec /.equivalence ..bits) + )))) diff --git a/stdlib/source/test/lux/data/collection/dictionary.lux b/stdlib/source/test/lux/data/collection/dictionary.lux new file mode 100644 index 000000000..3ad45704e --- /dev/null +++ b/stdlib/source/test/lux/data/collection/dictionary.lux @@ -0,0 +1,129 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + ["eq" equivalence]] + [data + ["." number] + ["." maybe] + [collection + ["&" dictionary] + ["." list ("list/." fold functor)]]] + [math + ["r" random]]] + lux/test) + +(context: "Dictionaries." + (<| (times 100) + (do @ + [#let [capped-nat (:: r.monad map (n/% 100) r.nat)] + size capped-nat + dict (r.dictionary number.hash size r.nat capped-nat) + non-key (|> r.nat (r.filter (function (_ key) (not (&.contains? key dict))))) + test-val (|> r.nat (r.filter (function (_ val) (not (list.member? number.equivalence (&.values dict) val)))))] + ($_ seq + (test "Size function should correctly represent Dictionary size." + (n/= size (&.size dict))) + + (test "Dictionaries of size 0 should be considered empty." + (if (n/= 0 size) + (&.empty? dict) + (not (&.empty? dict)))) + + (test "The functions 'entries', 'keys' and 'values' should be synchronized." + (:: (list.equivalence (eq.product number.equivalence number.equivalence)) = + (&.entries dict) + (list.zip2 (&.keys dict) + (&.values dict)))) + + (test "Dictionary should be able to recognize it's own keys." + (list.every? (function (_ key) (&.contains? key dict)) + (&.keys dict))) + + (test "Should be able to get every key." + (list.every? (function (_ key) (case (&.get key dict) + (#.Some _) #1 + _ #0)) + (&.keys dict))) + + (test "Shouldn't be able to access non-existant keys." + (case (&.get non-key dict) + (#.Some _) #0 + _ #1)) + + (test "Should be able to put and then get a value." + (case (&.get non-key (&.put non-key test-val dict)) + (#.Some v) (n/= test-val v) + _ #1)) + + (test "Should be able to put~ and then get a value." + (case (&.get non-key (&.put~ non-key test-val dict)) + (#.Some v) (n/= test-val v) + _ #1)) + + (test "Shouldn't be able to put~ an existing key." + (or (n/= 0 size) + (let [first-key (|> dict &.keys list.head maybe.assume)] + (case (&.get first-key (&.put~ first-key test-val dict)) + (#.Some v) (not (n/= test-val v)) + _ #1)))) + + (test "Removing a key should make it's value inaccessible." + (let [base (&.put non-key test-val dict)] + (and (&.contains? non-key base) + (not (&.contains? non-key (&.remove non-key base)))))) + + (test "Should be possible to update values via their keys." + (let [base (&.put non-key test-val dict) + updt (&.update non-key inc base)] + (case [(&.get non-key base) (&.get non-key updt)] + [(#.Some x) (#.Some y)] + (n/= (inc x) y) + + _ + #0))) + + (test "Additions and removals to a Dictionary should affect its size." + (let [plus (&.put non-key test-val dict) + base (&.remove non-key plus)] + (and (n/= (inc (&.size dict)) (&.size plus)) + (n/= (dec (&.size plus)) (&.size base))))) + + (test "A Dictionary should equal itself & going to<->from lists shouldn't change that." + (let [(^open ".") (&.equivalence number.equivalence)] + (and (= dict dict) + (|> dict &.entries (&.from-list number.hash) (= dict))))) + + (test "Merging a Dictionary to itself changes nothing." + (let [(^open ".") (&.equivalence number.equivalence)] + (= dict (&.merge dict dict)))) + + (test "If you merge, and the second dict has overlapping keys, it should overwrite yours." + (let [dict' (|> dict &.entries + (list/map (function (_ [k v]) [k (inc v)])) + (&.from-list number.hash)) + (^open ".") (&.equivalence number.equivalence)] + (= dict' (&.merge dict' dict)))) + + (test "Can merge values in such a way that they become combined." + (list.every? (function (_ [x x*2]) (n/= (n/* 2 x) x*2)) + (list.zip2 (&.values dict) + (&.values (&.merge-with n/+ dict dict))))) + + (test "Should be able to select subset of keys from dict." + (|> dict + (&.put non-key test-val) + (&.select (list non-key)) + &.size + (n/= 1))) + + (test "Should be able to re-bind existing values to different keys." + (or (n/= 0 size) + (let [first-key (|> dict &.keys list.head maybe.assume) + rebound (&.re-bind first-key non-key dict)] + (and (n/= (&.size dict) (&.size rebound)) + (&.contains? non-key rebound) + (not (&.contains? first-key rebound)) + (n/= (maybe.assume (&.get first-key dict)) + (maybe.assume (&.get non-key rebound))))))) + )))) diff --git a/stdlib/source/test/lux/data/collection/dictionary/ordered.lux b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux new file mode 100644 index 000000000..6b1f131cb --- /dev/null +++ b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux @@ -0,0 +1,91 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." number] + [collection + ["s" set] + ["dict" dictionary + ["&" ordered]] + ["." list ("list/." functor)]]] + [math + ["r" random]]] + lux/test) + +(context: "Dictionary" + (<| (times 100) + (do @ + [size (|> r.nat (:: @ map (n/% 100))) + keys (r.set number.nat-hash size r.nat) + values (r.set number.nat-hash size r.nat) + extra-key (|> r.nat (r.filter (|>> (s.member? keys) not))) + extra-value r.nat + #let [pairs (list.zip2 (s.to-list keys) + (s.to-list values)) + sample (&.from-list number.nat-order pairs) + sorted-pairs (list.sort (function (_ [left _] [right _]) + (n/< left right)) + pairs) + sorted-values (list/map product.right sorted-pairs) + (^open "&/.") (&.equivalence number.nat-equivalence)]] + ($_ seq + (test "Can query the size of a dictionary." + (n/= size (&.size sample))) + + (test "Can query value for minimum key." + (case [(&.min sample) (list.head sorted-values)] + [#.None #.None] + #1 + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + #0)) + + (test "Can query value for maximum key." + (case [(&.max sample) (list.last sorted-values)] + [#.None #.None] + #1 + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + #0)) + + (test "Converting dictionaries to/from lists cannot change their values." + (|> sample + &.entries (&.from-list number.nat-order) + (&/= sample))) + + (test "Order is preserved." + (let [(^open "list/.") (list.equivalence (: (Equivalence [Nat Nat]) + (function (_ [kr vr] [ks vs]) + (and (n/= kr ks) + (n/= vr vs)))))] + (list/= (&.entries sample) + sorted-pairs))) + + (test "Every key in a dictionary must be identifiable." + (list.every? (function (_ key) (&.contains? key sample)) + (&.keys sample))) + + (test "Can add and remove elements in a dictionary." + (and (not (&.contains? extra-key sample)) + (let [sample' (&.put extra-key extra-value sample) + sample'' (&.remove extra-key sample')] + (and (&.contains? extra-key sample') + (not (&.contains? extra-key sample'')) + (case [(&.get extra-key sample') + (&.get extra-key sample'')] + [(#.Some found) #.None] + (n/= extra-value found) + + _ + #0))) + )) + )))) diff --git a/stdlib/source/test/lux/data/collection/list.lux b/stdlib/source/test/lux/data/collection/list.lux new file mode 100644 index 000000000..9919f3dd1 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/list.lux @@ -0,0 +1,239 @@ +(.module: + [lux #* + ["." io] + [control + [monad (#+ do Monad)] + pipe] + [data + ["." number] + ["." bit] + ["." product] + ["." maybe] + [collection + ["&" list]]] + [math + ["r" random]]] + lux/test) + +(def: bounded-size + (r.Random Nat) + (|> r.nat + (:: r.monad map (|>> (n/% 100) (n/+ 10))))) + +(context: "Lists: Part 1" + (<| (times 100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.list size r.nat) + other-size bounded-size + other-sample (r.list other-size r.nat) + separator r.nat + #let [(^open ".") (&.equivalence number.equivalence) + (^open "&/.") &.functor]] + ($_ seq + (test "The size function should correctly portray the size of the list." + (n/= size (&.size sample))) + + (test "The repeat function should produce as many elements as asked of it." + (n/= size (&.size (&.repeat size [])))) + + (test "Reversing a list does not change it's size." + (n/= (&.size sample) + (&.size (&.reverse sample)))) + + (test "Reversing a list twice results in the original list." + (= sample + (&.reverse (&.reverse sample)))) + + (test "Filtering by a predicate and its complement should result in a number of elements equal to the original list." + (and (n/= (&.size sample) + (n/+ (&.size (&.filter n/even? sample)) + (&.size (&.filter (bit.complement n/even?) sample)))) + (let [[plus minus] (&.partition n/even? sample)] + (n/= (&.size sample) + (n/+ (&.size plus) + (&.size minus)))))) + + (test "If every element in a list satisfies a predicate, there can't be any that satisfy its complement." + (if (&.every? n/even? sample) + (and (not (&.any? (bit.complement n/even?) sample)) + (&.empty? (&.filter (bit.complement n/even?) sample))) + (&.any? (bit.complement n/even?) sample))) + + (test "Any element of the list can be considered its member." + (let [elem (maybe.assume (&.nth idx sample))] + (&.member? number.equivalence sample elem))) + )))) + +(context: "Lists: Part 2" + (<| (times 100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.list size r.nat) + other-size bounded-size + other-sample (r.list other-size r.nat) + separator r.nat + #let [(^open ".") (&.equivalence number.equivalence) + (^open "&/.") &.functor]] + ($_ seq + (test "Appending the head and the tail should yield the original list." + (let [head (maybe.assume (&.head sample)) + tail (maybe.assume (&.tail sample))] + (= sample + (#.Cons head tail)))) + + (test "Appending the inits and the last should yield the original list." + (let [(^open ".") &.monoid + inits (maybe.assume (&.inits sample)) + last (maybe.assume (&.last sample))] + (= sample + (compose inits (list last))))) + + (test "Functor should go over every element of the list." + (let [(^open ".") &.functor + there (map inc sample) + back-again (map dec there)] + (and (not (= sample there)) + (= sample back-again)))) + + (test "Splitting a list into chunks and re-appending them should yield the original list." + (let [(^open ".") &.monoid + [left right] (&.split idx sample) + [left' right'] (&.split-with n/even? sample)] + (and (= sample + (compose left right)) + (= sample + (compose left' right')) + (= sample + (compose (&.take idx sample) + (&.drop idx sample))) + (= sample + (compose (&.take-while n/even? sample) + (&.drop-while n/even? sample))) + ))) + + (test "Segmenting the list in pairs should yield as many elements as N/2." + (n/= (n// 2 size) + (&.size (&.as-pairs sample)))) + + (test "Sorting a list shouldn't change it's size." + (n/= (&.size sample) + (&.size (&.sort n/< sample)))) + + (test "Sorting a list with one order should yield the reverse of sorting it with the opposite order." + (= (&.sort n/< sample) + (&.reverse (&.sort n/> sample)))) + )))) + +(context: "Lists: Part 3" + (<| (times 100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.list size r.nat) + other-size bounded-size + other-sample (r.list other-size r.nat) + separator r.nat + from (|> r.nat (:: @ map (n/% 10))) + to (|> r.nat (:: @ map (n/% 10))) + #let [(^open ".") (&.equivalence number.equivalence) + (^open "&/.") &.functor]] + ($_ seq + (test "If you zip 2 lists, the result's size will be that of the smaller list." + (n/= (&.size (&.zip2 sample other-sample)) + (n/min (&.size sample) (&.size other-sample)))) + + (test "I can pair-up elements of a list in order." + (let [(^open ".") &.functor + zipped (&.zip2 sample other-sample) + num-zipper (&.size zipped)] + (and (|> zipped (map product.left) (= (&.take num-zipper sample))) + (|> zipped (map product.right) (= (&.take num-zipper other-sample)))))) + + (test "You can generate indices for any size, and they will be in ascending order." + (let [(^open ".") &.functor + indices (&.indices size)] + (and (n/= size (&.size indices)) + (= indices + (&.sort n/< indices)) + (&.every? (n/= (dec size)) + (&.zip2-with n/+ + indices + (&.sort n/> indices))) + ))) + + (test "The 'interpose' function places a value between every member of a list." + (let [(^open ".") &.functor + sample+ (&.interpose separator sample)] + (and (n/= (|> size (n/* 2) dec) + (&.size sample+)) + (|> sample+ &.as-pairs (map product.right) (&.every? (n/= separator)))))) + + (test "List append is a monoid." + (let [(^open ".") &.monoid] + (and (= sample (compose identity sample)) + (= sample (compose sample identity)) + (let [[left right] (&.split size (compose sample other-sample))] + (and (= sample left) + (= other-sample right)))))) + + (test "Apply allows you to create singleton lists, and apply lists of functions to lists of values." + (let [(^open ".") &.monad + (^open ".") &.apply] + (and (= (list separator) (wrap separator)) + (= (map inc sample) + (apply (wrap inc) sample))))) + + (test "List concatenation is a monad." + (let [(^open ".") &.monad + (^open ".") &.monoid] + (= (compose sample other-sample) + (join (list sample other-sample))))) + + (test "You can find any value that satisfies some criterium, if such values exist in the list." + (case (&.find n/even? sample) + (#.Some found) + (and (n/even? found) + (&.any? n/even? sample) + (not (&.every? (bit.complement n/even?) sample))) + + #.None + (and (not (&.any? n/even? sample)) + (&.every? (bit.complement n/even?) sample)))) + + (test "You can iteratively construct a list, generating values until you're done." + (= (&.n/range 0 (dec size)) + (&.iterate (function (_ n) (if (n/< size n) (#.Some (inc n)) #.None)) + 0))) + + (test "Can enumerate all elements in a list." + (let [enum-sample (&.enumerate sample)] + (and (= (&.indices (&.size enum-sample)) + (&/map product.left enum-sample)) + (= sample + (&/map product.right enum-sample))))) + + (test "Ranges can be constructed forward and backwards." + (and (let [(^open "list/.") (&.equivalence number.equivalence)] + (list/= (&.n/range from to) + (&.reverse (&.n/range to from)))) + (let [(^open "list/.") (&.equivalence number.equivalence) + from (.int from) + to (.int to)] + (list/= (&.i/range from to) + (&.reverse (&.i/range to from)))))) + )))) + +## TODO: Add again once new-luxc becomes the standard compiler. +(context: "Monad transformer" + (let [lift (&.lift io.monad) + (^open "io/.") io.monad] + (test "Can add list functionality to any monad." + (|> (io.run (do (&.ListT io.monad) + [a (lift (io/wrap +123)) + b (wrap +456)] + (wrap (i/+ a b)))) + (case> (^ (list +579)) #1 + _ #0))))) diff --git a/stdlib/source/test/lux/data/collection/queue.lux b/stdlib/source/test/lux/data/collection/queue.lux new file mode 100644 index 000000000..4f4f12ef0 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/queue.lux @@ -0,0 +1,54 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)]] + [data + ["." number] + [collection + ["&" queue]]] + [math + ["r" random]]] + lux/test) + +(context: "Queues" + (<| (times 100) + (do @ + [size (:: @ map (n/% 100) r.nat) + sample (r.queue size r.nat) + non-member (|> r.nat + (r.filter (|>> (&.member? number.equivalence sample) not)))] + ($_ seq + (test "I can query the size of a queue (and empty queues have size 0)." + (if (n/= 0 size) + (&.empty? sample) + (n/= size (&.size sample)))) + + (test "Enqueueing and dequeing affects the size of queues." + (and (n/= (inc size) (&.size (&.push non-member sample))) + (or (&.empty? sample) + (n/= (dec size) (&.size (&.pop sample)))) + (n/= size (&.size (&.pop (&.push non-member sample)))))) + + (test "Transforming to/from list can't change the queue." + (let [(^open "&/.") (&.equivalence number.equivalence)] + (|> sample + &.to-list &.from-list + (&/= sample)))) + + (test "I can always peek at a non-empty queue." + (case (&.peek sample) + #.None (&.empty? sample) + (#.Some _) #1)) + + (test "I can query whether an element belongs to a queue." + (and (not (&.member? number.equivalence sample non-member)) + (&.member? number.equivalence (&.push non-member sample) + non-member) + (case (&.peek sample) + #.None + (&.empty? sample) + + (#.Some first) + (and (&.member? number.equivalence sample first) + (not (&.member? number.equivalence (&.pop sample) first)))))) + )))) diff --git a/stdlib/source/test/lux/data/collection/queue/priority.lux b/stdlib/source/test/lux/data/collection/queue/priority.lux new file mode 100644 index 000000000..3868a01a8 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/queue/priority.lux @@ -0,0 +1,57 @@ +(.module: + [lux #* + [control + ["." monad (#+ do Monad)]] + [data + [number + ["." nat]] + ["." maybe] + [collection + [queue + ["&" priority]]]] + [math + ["r" random]]] + lux/test) + +(def: (gen-queue size) + (-> Nat (r.Random (&.Queue Nat))) + (do r.monad + [inputs (r.list size r.nat)] + (monad.fold @ (function (_ head tail) + (do @ + [priority r.nat] + (wrap (&.push priority head tail)))) + &.empty + inputs))) + +(context: "Queues" + (<| (times 100) + (do @ + [size (|> r.nat (:: @ map (n/% 100))) + sample (gen-queue size) + non-member-priority r.nat + non-member (|> r.nat (r.filter (|>> (&.member? nat.equivalence sample) not)))] + ($_ seq + (test "I can query the size of a queue (and empty queues have size 0)." + (n/= size (&.size sample))) + + (test "Enqueueing and dequeing affects the size of queues." + (and (n/= (inc size) + (&.size (&.push non-member-priority non-member sample))) + (or (n/= 0 (&.size sample)) + (n/= (dec size) + (&.size (&.pop sample)))))) + + (test "I can query whether an element belongs to a queue." + (and (and (not (&.member? nat.equivalence sample non-member)) + (&.member? nat.equivalence + (&.push non-member-priority non-member sample) + non-member)) + (or (n/= 0 (&.size sample)) + (and (&.member? nat.equivalence + sample + (maybe.assume (&.peek sample))) + (not (&.member? nat.equivalence + (&.pop sample) + (maybe.assume (&.peek sample)))))))) + )))) diff --git a/stdlib/source/test/lux/data/collection/row.lux b/stdlib/source/test/lux/data/collection/row.lux new file mode 100644 index 000000000..2eb342e6e --- /dev/null +++ b/stdlib/source/test/lux/data/collection/row.lux @@ -0,0 +1,82 @@ +(.module: + [lux #* + [control + [monad (#+ Monad do)]] + [data + ["." number] + ["." maybe] + [collection + ["&" row] + [list ("list/." fold)]]] + [math + ["r" random]]] + lux/test) + +(context: "Rows" + (<| (times 100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) + idx (|> r.nat (:: @ map (n/% size))) + sample (r.row size r.nat) + other-sample (r.row size r.nat) + non-member (|> r.nat (r.filter (|>> (&.member? number.equivalence sample) not))) + #let [(^open "&/.") (&.equivalence number.equivalence) + (^open "&/.") &.apply + (^open "&/.") &.monad + (^open "&/.") &.fold + (^open "&/.") &.monoid]] + ($_ seq + (test "Can query size of row." + (if (&.empty? sample) + (and (n/= 0 size) + (n/= 0 (&.size sample))) + (n/= size (&.size sample)))) + + (test "Can add and remove elements to rows." + (and (n/= (inc size) (&.size (&.add non-member sample))) + (n/= (dec size) (&.size (&.pop sample))))) + + (test "Can put and get elements into rows." + (|> sample + (&.put idx non-member) + (&.nth idx) + maybe.assume + (is? non-member))) + + (test "Can update elements of rows." + (|> sample + (&.put idx non-member) (&.update idx inc) + (&.nth idx) maybe.assume + (n/= (inc non-member)))) + + (test "Can safely transform to/from lists." + (|> sample &.to-list &.from-list (&/= sample))) + + (test "Can identify members of a row." + (and (not (&.member? number.equivalence sample non-member)) + (&.member? number.equivalence (&.add non-member sample) non-member))) + + (test "Can fold over elements of row." + (n/= (list/fold n/+ 0 (&.to-list sample)) + (&/fold n/+ 0 sample))) + + (test "Functor goes over every element." + (let [there (&/map inc sample) + back-again (&/map dec there)] + (and (not (&/= sample there)) + (&/= sample back-again)))) + + (test "Apply allows you to create singleton rows, and apply rows of functions to rows of values." + (and (&/= (&.row non-member) (&/wrap non-member)) + (&/= (&/map inc sample) (&/apply (&/wrap inc) sample)))) + + (test "Row concatenation is a monad." + (&/= (&/compose sample other-sample) + (&/join (&.row sample other-sample)))) + + (test "Can reverse." + (and (not (&/= sample + (&.reverse sample))) + (not (&/= sample + (&.reverse (&.reverse sample)))))) + )))) diff --git a/stdlib/source/test/lux/data/collection/sequence.lux b/stdlib/source/test/lux/data/collection/sequence.lux new file mode 100644 index 000000000..de398e6f6 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/sequence.lux @@ -0,0 +1,103 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + comonad] + [data + ["." maybe] + ["." number ("nat/." codec)] + ["." text ("text/." monoid)] + [collection + ["." list] + ["&" sequence]]] + [math + ["r" random]]] + lux/test) + +(context: "Sequences" + (<| (times 100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 2)))) + offset (|> r.nat (:: @ map (n/% 100))) + factor (|> r.nat (:: @ map (|>> (n/% 100) (n/max 2)))) + elem r.nat + cycle-seed (r.list size r.nat) + cycle-sample-idx (|> r.nat (:: @ map (n/% 1000))) + #let [(^open "List/.") (list.equivalence number.equivalence) + sample0 (&.iterate inc 0) + sample1 (&.iterate inc offset)]] + ($_ seq + (test "Can move along a sequence and take slices off it." + (and (and (List/= (list.n/range 0 (dec size)) + (&.take size sample0)) + (List/= (list.n/range offset (dec (n/+ offset size))) + (&.take size (&.drop offset sample0))) + (let [[drops takes] (&.split size sample0)] + (and (List/= (list.n/range 0 (dec size)) + drops) + (List/= (list.n/range size (dec (n/* 2 size))) + (&.take size takes))))) + (and (List/= (list.n/range 0 (dec size)) + (&.take-while (n/< size) sample0)) + (List/= (list.n/range offset (dec (n/+ offset size))) + (&.take-while (n/< (n/+ offset size)) + (&.drop-while (n/< offset) sample0))) + (let [[drops takes] (&.split-while (n/< size) sample0)] + (and (List/= (list.n/range 0 (dec size)) + drops) + (List/= (list.n/range size (dec (n/* 2 size))) + (&.take-while (n/< (n/* 2 size)) takes))))) + )) + + (test "Can repeat any element and infinite number of times." + (n/= elem (&.nth offset (&.repeat elem)))) + + (test "Can obtain the head & tail of a sequence." + (and (n/= offset (&.head sample1)) + (List/= (list.n/range (inc offset) (n/+ offset size)) + (&.take size (&.tail sample1))))) + + (test "Can filter sequences." + (and (n/= (n/* 2 offset) + (&.nth offset + (&.filter n/even? sample0))) + (let [[evens odds] (&.partition n/even? (&.iterate inc 0))] + (and (n/= (n/* 2 offset) + (&.nth offset evens)) + (n/= (inc (n/* 2 offset)) + (&.nth offset odds)))))) + + (test "Functor goes over 'all' elements in a sequence." + (let [(^open "&/.") &.functor + there (&/map (n/* factor) sample0) + back-again (&/map (n// factor) there)] + (and (not (List/= (&.take size sample0) + (&.take size there))) + (List/= (&.take size sample0) + (&.take size back-again))))) + + (test "CoMonad produces a value for every element in a sequence." + (let [(^open "&/.") &.functor] + (List/= (&.take size (&/map (n/* factor) sample1)) + (&.take size + (be &.comonad + [inputs sample1] + (n/* factor (&.head inputs))))))) + + (test "'unfold' generalizes 'iterate'." + (let [(^open "&/.") &.functor + (^open "List/.") (list.equivalence text.equivalence)] + (List/= (&.take size + (&/map nat/encode (&.iterate inc offset))) + (&.take size + (&.unfold (function (_ n) [(inc n) (nat/encode n)]) + offset))))) + + (test "Can cycle over the same elements as an infinite sequence." + (|> (&.cycle cycle-seed) + maybe.assume + (&.nth cycle-sample-idx) + (n/= (|> cycle-seed + (list.nth (n/% size cycle-sample-idx)) + maybe.assume)))) + )))) diff --git a/stdlib/source/test/lux/data/collection/set.lux b/stdlib/source/test/lux/data/collection/set.lux new file mode 100644 index 000000000..bbdc945f7 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/set.lux @@ -0,0 +1,67 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)]] + [data + ["." number] + [collection + ["&" set (#+ Set)] + ["." list]]] + [math + ["r" random]]] + lux/test) + +(def: gen-nat + (r.Random Nat) + (|> r.nat + (:: r.monad map (n/% 100)))) + +(context: "Sets" + (<| (times 100) + (do @ + [sizeL gen-nat + sizeR gen-nat + setL (r.set number.hash sizeL gen-nat) + setR (r.set number.hash sizeR gen-nat) + non-member (|> gen-nat + (r.filter (|>> (&.member? setL) not))) + #let [(^open "&/.") &.equivalence]] + ($_ seq + (test "I can query the size of a set." + (and (n/= sizeL (&.size setL)) + (n/= sizeR (&.size setR)))) + + (test "Converting sets to/from lists can't change their values." + (|> setL + &.to-list (&.from-list number.hash) + (&/= setL))) + + (test "Every set is a sub-set of the union of itself with another." + (let [setLR (&.union setL setR)] + (and (&.sub? setLR setL) + (&.sub? setLR setR)))) + + (test "Every set is a super-set of the intersection of itself with another." + (let [setLR (&.intersection setL setR)] + (and (&.super? setLR setL) + (&.super? setLR setR)))) + + (test "Union with the empty set leaves a set unchanged." + (&/= setL + (&.union (&.new number.hash) + setL))) + + (test "Intersection with the empty set results in the empty set." + (let [empty-set (&.new number.hash)] + (&/= empty-set + (&.intersection empty-set setL)))) + + (test "After substracting a set A from another B, no member of A can be a member of B." + (let [sub (&.difference setR setL)] + (not (list.any? (&.member? sub) (&.to-list setR))))) + + (test "Every member of a set must be identifiable." + (and (not (&.member? setL non-member)) + (&.member? (&.add non-member setL) non-member) + (not (&.member? (&.remove non-member (&.add non-member setL)) non-member)))) + )))) diff --git a/stdlib/source/test/lux/data/collection/set/ordered.lux b/stdlib/source/test/lux/data/collection/set/ordered.lux new file mode 100644 index 000000000..384a0506b --- /dev/null +++ b/stdlib/source/test/lux/data/collection/set/ordered.lux @@ -0,0 +1,98 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)]] + [data + ["." number] + [text + format] + [collection + ["." set + ["&" ordered]] + ["." list]]] + [math + ["r" random]]] + lux/test) + +(def: gen-nat + (r.Random Nat) + (|> r.nat + (:: r.monad map (n/% 100)))) + +(context: "Sets" + (<| (times 100) + (do @ + [sizeL gen-nat + sizeR gen-nat + listL (|> (r.set number.hash sizeL gen-nat) (:: @ map set.to-list)) + listR (|> (r.set number.hash sizeR gen-nat) (:: @ map set.to-list)) + #let [(^open "&/.") &.equivalence + setL (&.from-list number.order listL) + setR (&.from-list number.order listR) + sortedL (list.sort n/< listL) + minL (list.head sortedL) + maxL (list.last sortedL)]] + ($_ seq + (test "I can query the size of a set." + (n/= sizeL (&.size setL))) + + (test "Can query minimum value." + (case [(&.min setL) minL] + [#.None #.None] + #1 + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + #0)) + + (test "Can query maximum value." + (case [(&.max setL) maxL] + [#.None #.None] + #1 + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + #0)) + + (test "Converting sets to/from lists can't change their values." + (|> setL + &.to-list (&.from-list number.order) + (&/= setL))) + + (test "Order is preserved." + (let [listL (&.to-list setL) + (^open "L/.") (list.equivalence number.equivalence)] + (L/= listL + (list.sort n/< listL)))) + + (test "Every set is a sub-set of the union of itself with another." + (let [setLR (&.union setL setR)] + (and (&.sub? setLR setL) + (&.sub? setLR setR)))) + + (test "Every set is a super-set of the intersection of itself with another." + (let [setLR (&.intersection setL setR)] + (and (&.super? setLR setL) + (&.super? setLR setR)))) + + (test "Union with the empty set leaves a set unchanged." + (&/= setL + (&.union (&.new number.order) + setL))) + + (test "Intersection with the empty set results in the empty set." + (let [empty-set (&.new number.order)] + (&/= empty-set + (&.intersection empty-set setL)))) + + (test "After substracting a set A from another B, no member of A can be a member of B." + (let [sub (&.difference setR setL)] + (not (list.any? (&.member? sub) (&.to-list setR))))) + + (test "Every member of a set must be identifiable." + (list.every? (&.member? setL) (&.to-list setL))) + )))) diff --git a/stdlib/source/test/lux/data/collection/stack.lux b/stdlib/source/test/lux/data/collection/stack.lux new file mode 100644 index 000000000..d203b4246 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/stack.lux @@ -0,0 +1,46 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." maybe] + [collection + ["&" stack]]] + [math + ["r" random]]] + lux/test) + +(def: gen-nat + (r.Random Nat) + (|> r.nat + (:: r.monad map (n/% 100)))) + +(context: "Stacks" + (<| (times 100) + (do @ + [size gen-nat + sample (r.stack size gen-nat) + new-top gen-nat] + ($_ seq + (test "Can query the size of a stack." + (n/= size (&.size sample))) + + (test "Can peek inside non-empty stacks." + (case (&.peek sample) + #.None (&.empty? sample) + (#.Some _) (not (&.empty? sample)))) + + (test "Popping empty stacks doesn't change anything. + But, if they're non-empty, the top of the stack is removed." + (let [sample' (&.pop sample)] + (or (n/= (&.size sample) (inc (&.size sample'))) + (and (&.empty? sample) (&.empty? sample'))) + )) + + (test "Pushing onto a stack always increases it by 1, adding a new value at the top." + (and (is? sample + (&.pop (&.push new-top sample))) + (n/= (inc (&.size sample)) (&.size (&.push new-top sample))) + (|> (&.push new-top sample) &.peek maybe.assume + (is? new-top)))) + )))) diff --git a/stdlib/source/test/lux/data/collection/tree/rose.lux b/stdlib/source/test/lux/data/collection/tree/rose.lux new file mode 100644 index 000000000..47dbf94cf --- /dev/null +++ b/stdlib/source/test/lux/data/collection/tree/rose.lux @@ -0,0 +1,51 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)]] + [data + ["." product] + ["." number] + [text ("text/." equivalence) + format] + [collection + ["." list ("list/." functor fold)] + [tree + ["&" rose]]]] + [math + ["r" random]]] + lux/test) + +(def: gen-tree + (r.Random [Nat (&.Tree Nat)]) + (r.rec + (function (_ gen-tree) + (r.either (:: r.monad map (|>> &.leaf [1]) r.nat) + (do r.monad + [value r.nat + num-children (|> r.nat (:: @ map (n/% 3))) + children' (r.list num-children gen-tree) + #let [size' (list/fold n/+ 0 (list/map product.left children')) + children (list/map product.right children')]] + (wrap [(inc size') + (&.branch value children)])) + )))) + +(context: "Trees" + (<| (times 100) + (do @ + [[size sample] gen-tree + #let [(^open "&/.") (&.equivalence number.equivalence) + (^open "&/.") &.fold + concat (function (_ addition partial) (format partial (%n addition)))]] + ($_ seq + (test "Can compare trees for equivalence." + (&/= sample sample)) + + (test "Can flatten a tree to get all the nodes as a flat tree." + (n/= size + (list.size (&.flatten sample)))) + + (test "Can fold trees." + (text/= (&/fold concat "" sample) + (list/fold concat "" (&.flatten sample)))) + )))) diff --git a/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux new file mode 100644 index 000000000..3abf1dd26 --- /dev/null +++ b/stdlib/source/test/lux/data/collection/tree/rose/zipper.lux @@ -0,0 +1,128 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe] + [data + ["." number] + ["." maybe] + ["." text + format] + [collection + ["." list] + [tree + ["." rose + ["&" zipper]]]]] + [math + ["r" random]]] + lux/test) + +(def: gen-tree + (r.Random (rose.Tree Nat)) + (r.rec (function (_ gen-tree) + (do r.monad + ## Each branch can have, at most, 1 child. + [size (|> r.nat (:: @ map (n/% 2)))] + (r.and r.nat + (r.list size gen-tree)))))) + +(def: (to-end zipper) + (All [a] (-> (&.Zipper a) (&.Zipper a))) + (loop [zipper zipper] + (if (&.end? zipper) + zipper + (recur (&.next zipper))))) + +(context: "Zippers." + (<| (times 100) + (do @ + [sample gen-tree + new-val r.nat + pre-val r.nat + post-val r.nat + #let [(^open "tree/.") (rose.equivalence number.equivalence) + (^open "list/.") (list.equivalence number.equivalence)]] + ($_ seq + (test "Trees can be converted to/from zippers." + (|> sample + &.zip &.unzip + (tree/= sample))) + + (test "Creating a zipper gives you a root node." + (|> sample &.zip &.root?)) + + (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))) + (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)))) + #1))) + + (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 _) #0 + #.None #1)) + (|> zipper (&.insert-right post-val) (case> (#.Some _) #0 + #.None #1)))))) + + (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))))))) + + (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)) + (#.Cons (&.value zipper) + (recur (&.prev zipper))))))) + + (test "Can remove nodes (except root nodes)." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (and (|> zipper &.down &.root? not) + (|> zipper &.down &.remove (case> #.None #0 + (#.Some node) (&.root? node)))) + (|> zipper &.remove (case> #.None #1 + (#.Some _) #0))))) + )))) diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux new file mode 100644 index 000000000..503421db2 --- /dev/null +++ b/stdlib/source/test/lux/data/color.lux @@ -0,0 +1,99 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["@" color] + [number ("frac/." number)]] + ["." math + ["r" random]]] + lux/test) + +(def: color + (r.Random @.Color) + (|> ($_ r.and r.nat r.nat r.nat) + (:: r.monad map @.from-rgb))) + +(def: scale + (-> Nat Frac) + (|>> .int int-to-frac)) + +(def: square (-> Frac Frac) (math.pow +2.0)) + +(def: (distance from to) + (-> @.Color @.Color Frac) + (let [[fr fg fb] (@.to-rgb from) + [tr tg tb] (@.to-rgb to)] + (math.pow +0.5 ($_ f/+ + (|> (scale tr) (f/- (scale fr)) square) + (|> (scale tg) (f/- (scale fg)) square) + (|> (scale tb) (f/- (scale fb)) square))))) + +(def: error-margin Frac +1.8) + +(def: black (@.from-rgb [0 0 0])) +(def: white (@.from-rgb [255 255 255])) + +(do-template [<field>] + [(def: (<field> color) + (-> @.Color Frac) + (let [[hue saturation luminance] (@.to-hsl color)] + <field>))] + + [saturation] + [luminance] + ) + +(context: "Color." + (<| (times 100) + (do @ + [any color + colorful (|> color + (r.filter (function (_ color) (|> (distance color black) (f/>= +100.0)))) + (r.filter (function (_ color) (|> (distance color white) (f/>= +100.0))))) + mediocre (|> color + (r.filter (|>> saturation + ((function (_ saturation) + (and (f/>= +0.25 saturation) + (f/<= +0.75 saturation))))))) + ratio (|> r.frac (r.filter (f/>= +0.5)))] + ($_ seq + (test "Has equivalence." + (:: @.equivalence = any any)) + (test "Can convert to/from HSL." + (|> any @.to-hsl @.from-hsl + (distance any) + (f/<= error-margin))) + (test "Can convert to/from HSB." + (|> any @.to-hsb @.from-hsb + (distance any) + (f/<= error-margin))) + (test "Can convert to/from CMYK." + (|> any @.to-cmyk @.from-cmyk + (distance any) + (f/<= error-margin))) + (test "Can interpolate between 2 colors." + (and (f/<= (distance colorful black) + (distance (@.darker ratio colorful) black)) + (f/<= (distance colorful white) + (distance (@.brighter ratio colorful) white)))) + (test "Can calculate complement." + (let [~any (@.complement any) + (^open "@/.") @.equivalence] + (and (not (@/= any ~any)) + (@/= any (@.complement ~any))))) + (test "Can saturate color." + (f/> (saturation mediocre) + (saturation (@.saturate ratio mediocre)))) + (test "Can de-saturate color." + (f/< (saturation mediocre) + (saturation (@.de-saturate ratio mediocre)))) + (test "Can gray-scale color." + (let [gray'ed (@.gray-scale mediocre)] + (and (f/= +0.0 + (saturation gray'ed)) + (|> (luminance gray'ed) + (f/- (luminance mediocre)) + frac/abs + (f/<= error-margin))))) + )))) diff --git a/stdlib/source/test/lux/data/error.lux b/stdlib/source/test/lux/data/error.lux new file mode 100644 index 000000000..7f491dc2c --- /dev/null +++ b/stdlib/source/test/lux/data/error.lux @@ -0,0 +1,61 @@ +(.module: + [lux #* + ["." io] + [control + [monad (#+ do Monad)] + pipe] + [data + ["/" error (#+ Error)]]] + lux/test) + +(context: "Errors" + (let [(^open "//.") /.apply + (^open "//.") /.monad] + ($_ seq + (test "Functor correctly handles both cases." + (and (|> (: (Error Int) (#/.Success +10)) + (//map inc) + (case> (#/.Success +11) #1 _ #0)) + + (|> (: (Error Int) (#/.Failure "YOLO")) + (//map inc) + (case> (#/.Failure "YOLO") #1 _ #0)) + )) + + (test "Apply correctly handles both cases." + (and (|> (//wrap +20) + (case> (#/.Success +20) #1 _ #0)) + (|> (//apply (//wrap inc) (//wrap +10)) + (case> (#/.Success +11) #1 _ #0)) + (|> (//apply (//wrap inc) (#/.Failure "YOLO")) + (case> (#/.Failure "YOLO") #1 _ #0)))) + + (test "Monad correctly handles both cases." + (and (|> (do /.monad + [f (wrap i/+) + a (wrap +10) + b (wrap +20)] + (wrap (f a b))) + (case> (#/.Success +30) #1 _ #0)) + (|> (do /.monad + [f (wrap i/+) + a (#/.Failure "YOLO") + b (wrap +20)] + (wrap (f a b))) + (case> (#/.Failure "YOLO") #1 _ #0)) + )) + ))) + +(context: "Monad transformer" + (let [lift (/.lift io.monad) + (^open "io/.") io.monad] + (test "Can add error functionality to any monad." + (|> (io.run (do (/.ErrorT io.monad) + [a (lift (io/wrap +123)) + b (wrap +456)] + (wrap (i/+ a b)))) + (case> (#/.Success +579) + #1 + + _ + #0))))) diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux new file mode 100644 index 000000000..f54b51c3b --- /dev/null +++ b/stdlib/source/test/lux/data/format/json.lux @@ -0,0 +1,183 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + codec + [equivalence (#+ Equivalence)] + pipe + ["p" parser]] + [data + ["." error] + ["." bit] + ["." maybe] + ["." number] + ["." text + format] + [format + ["@" json]] + [collection + [row (#+ row)] + ["d" dictionary] + ["." list]]] + [macro + [poly (#+ derived:)] + ["." poly/equivalence] + ["." poly/json]] + [type + ["." unit]] + [math + ["r" random]] + [time + ["ti" instant] + ["tda" date] + ## ["tdu" duration] + ] + test] + [test + [lux + [time + ["_." instant] + ## ["_." duration] + ["_." date]]]] + ) + +(def: gen-json + (r.Random @.JSON) + (r.rec (function (_ gen-json) + (do r.monad + [size (:: @ map (n/% 2) r.nat)] + ($_ r.or + (:: @ wrap []) + r.bit + (|> r.frac (:: @ map (f/* +1_000_000.0))) + (r.unicode size) + (r.row size gen-json) + (r.dictionary text.hash size (r.unicode size) gen-json) + ))))) + +(context: "JSON" + (<| (times 100) + (do @ + [sample gen-json + #let [(^open "@/.") @.equivalence + (^open "@/.") @.codec]] + ($_ seq + (test "Every JSON is equal to itself." + (@/= sample sample)) + + (test "Can encode/decode JSON." + (|> sample @/encode @/decode + (case> (#.Right result) + (@/= sample result) + + (#.Left _) + #0))) + )))) + +(type: Variant + (#Case0 Bit) + (#Case1 Text) + (#Case2 Frac)) + +(type: #rec Recursive + (#Number Frac) + (#Addition Frac Recursive)) + +(type: Record + {#bit Bit + #frac Frac + #text Text + #maybe (Maybe Frac) + #list (List Frac) + #dict (d.Dictionary Text Frac) + ## #variant Variant + ## #tuple [Bit Frac Text] + #recursive Recursive + ## #instant ti.Instant + ## #duration tdu.Duration + #date tda.Date + #grams (unit.Qty unit.Gram) + }) + +(def: gen-recursive + (r.Random Recursive) + (r.rec (function (_ gen-recursive) + (r.or r.frac + (r.and r.frac gen-recursive))))) + +(derived: (poly/equivalence.Equivalence<?> Recursive)) + +(def: qty + (All [unit] (r.Random (unit.Qty unit))) + (|> r.int (:: r.monad map unit.in))) + +(def: gen-record + (r.Random Record) + (do r.monad + [size (:: @ map (n/% 2) r.nat)] + ($_ r.and + r.bit + r.frac + (r.unicode size) + (r.maybe r.frac) + (r.list size r.frac) + (r.dictionary text.hash size (r.unicode size) r.frac) + ## ($_ r.or r.bit (r.unicode size) r.frac) + ## ($_ r.and r.bit r.frac (r.unicode size)) + gen-recursive + ## _instant.instant + ## _duration.duration + _date.date + qty + ))) + +(derived: (poly/json.codec Record)) + +(structure: _ (Equivalence Record) + (def: (= recL recR) + (let [variant/= (function (_ left right) + (case [left right] + [(#Case0 left') (#Case0 right')] + (:: bit.equivalence = left' right') + + [(#Case1 left') (#Case1 right')] + (:: text.equivalence = left' right') + + [(#Case2 left') (#Case2 right')] + (f/= left' right') + + _ + #0))] + (and (:: bit.equivalence = (get@ #bit recL) (get@ #bit recR)) + (f/= (get@ #frac recL) (get@ #frac recR)) + (:: text.equivalence = (get@ #text recL) (get@ #text recR)) + (:: (maybe.equivalence number.equivalence) = (get@ #maybe recL) (get@ #maybe recR)) + (:: (list.equivalence number.equivalence) = (get@ #list recL) (get@ #list recR)) + (:: (d.equivalence number.equivalence) = (get@ #dict recL) (get@ #dict recR)) + ## (variant/= (get@ #variant recL) (get@ #variant recR)) + ## (let [[tL0 tL1 tL2] (get@ #tuple recL) + ## [tR0 tR1 tR2] (get@ #tuple recR)] + ## (and (:: bit.equivalence = tL0 tR0) + ## (f/= tL1 tR1) + ## (:: text.equivalence = tL2 tR2))) + (:: equivalence = (get@ #recursive recL) (get@ #recursive recR)) + ## (:: ti.equivalence = (get@ #instant recL) (get@ #instant recR)) + ## (:: tdu.equivalence = (get@ #duration recL) (get@ #duration recR)) + (:: tda.equivalence = (get@ #date recL) (get@ #date recR)) + (:: unit.equivalence = (get@ #grams recL) (get@ #grams recR)) + )))) + +(context: "Polytypism" + (<| (seed 14562075782602945288) + ## (times 100) + (do @ + [sample gen-record + #let [(^open "@/.") ..equivalence + (^open "@/.") ..codec]] + (test "Can encode/decode arbitrary types." + (|> sample @/encode @/decode + (case> (#error.Success result) + (@/= sample result) + + (#error.Failure error) + #0)))))) diff --git a/stdlib/source/test/lux/data/format/xml.lux b/stdlib/source/test/lux/data/format/xml.lux new file mode 100644 index 000000000..0f86eb63d --- /dev/null +++ b/stdlib/source/test/lux/data/format/xml.lux @@ -0,0 +1,121 @@ +(.module: + [lux #* + [control + [monad (#+ Monad do)] + ["p" parser] + pipe] + [data + ["." name] + ["E" error] + ["." maybe] + ["." text ("text/." equivalence) + format] + [format + ["&" xml]] + [collection + ["dict" dictionary] + ["." list ("list/." functor)]]] + [math + ["r" random ("r/." monad)]]] + lux/test) + +(def: char-range + Text + (format "_" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + +(def: xml-char^ + (r.Random Nat) + (do r.monad + [idx (|> r.nat (:: @ map (n/% (text.size char-range))))] + (wrap (maybe.assume (text.nth idx char-range))))) + +(def: (size^ bottom top) + (-> Nat Nat (r.Random Nat)) + (let [constraint (|>> (n/% top) (n/max bottom))] + (r/map constraint r.nat))) + +(def: (xml-text^ bottom top) + (-> Nat Nat (r.Random Text)) + (do r.monad + [size (size^ bottom top)] + (r.text xml-char^ size))) + +(def: xml-identifier^ + (r.Random Name) + (r.and (xml-text^ 0 10) + (xml-text^ 1 10))) + +(def: gen-xml + (r.Random &.XML) + (r.rec (function (_ gen-xml) + (r.or (xml-text^ 1 10) + (do r.monad + [size (size^ 0 2)] + ($_ r.and + xml-identifier^ + (r.dictionary name.hash size xml-identifier^ (xml-text^ 0 10)) + (r.list size gen-xml))))))) + +(context: "XML." + (<| (times 100) + (do @ + [sample gen-xml + #let [(^open "&/.") &.equivalence + (^open "&/.") &.codec]] + ($_ seq + (test "Every XML is equal to itself." + (&/= sample sample)) + + (test "Can encode/decode XML." + (|> sample &/encode &/decode + (case> (#.Right result) + (&/= sample result) + + (#.Left error) + #0))) + )))) + +(context: "Parsing." + (<| (times 100) + (do @ + [text (xml-text^ 1 10) + num-children (|> r.nat (:: @ map (n/% 5))) + children (r.list num-children (xml-text^ 1 10)) + tag xml-identifier^ + attr xml-identifier^ + value (xml-text^ 1 10) + #let [node (#&.Node tag + (dict.put attr value &.attrs) + (list/map (|>> #&.Text) children))]] + ($_ seq + (test "Can parse text." + (E.default #0 + (do E.monad + [output (&.run (#&.Text text) + &.text)] + (wrap (text/= text output))))) + (test "Can parse attributes." + (E.default #0 + (do E.monad + [output (|> (&.attr attr) + (p.before &.ignore) + (&.run node))] + (wrap (text/= value output))))) + (test "Can parse nodes." + (E.default #0 + (do E.monad + [_ (|> (&.node tag) + (p.before &.ignore) + (&.run node))] + (wrap #1)))) + (test "Can parse children." + (E.default #0 + (do E.monad + [outputs (|> (&.children (p.some &.text)) + (&.run node))] + (wrap (:: (list.equivalence text.equivalence) = + children + outputs))))) + )))) diff --git a/stdlib/source/test/lux/data/identity.lux b/stdlib/source/test/lux/data/identity.lux new file mode 100644 index 000000000..31bf105cd --- /dev/null +++ b/stdlib/source/test/lux/data/identity.lux @@ -0,0 +1,37 @@ +(.module: + [lux #* + [control + ["M" monad (#+ Monad do)] + comonad] + [data + ["&" identity] + [text ("text/." monoid equivalence)]]] + lux/test) + +(context: "Identity" + (let [(^open "&/.") &.apply + (^open "&/.") &.monad + (^open "&/.") &.comonad] + ($_ seq + (test "Functor does not affect values." + (text/= "yololol" (&/map (text/compose "yolo") "lol"))) + + (test "Apply does not affect values." + (and (text/= "yolo" (&/wrap "yolo")) + (text/= "yololol" (&/apply (&/wrap (text/compose "yolo")) (&/wrap "lol"))))) + + (test "Monad does not affect values." + (text/= "yololol" (do &.monad + [f (wrap text/compose) + a (wrap "yolo") + b (wrap "lol")] + (wrap (f a b))))) + + (test "CoMonad does not affect values." + (and (text/= "yololol" (&/unwrap "yololol")) + (text/= "yololol" (be &.comonad + [f text/compose + a "yolo" + b "lol"] + (f a b))))) + ))) diff --git a/stdlib/source/test/lux/data/lazy.lux b/stdlib/source/test/lux/data/lazy.lux new file mode 100644 index 000000000..f00b572ab --- /dev/null +++ b/stdlib/source/test/lux/data/lazy.lux @@ -0,0 +1,54 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)]] + [data + ["&" lazy]] + [math + ["r" random]]] + lux/test) + +(context: "Lazy." + (<| (times 100) + (do @ + [left r.nat + right r.nat + #let [lazy (&.freeze (n/* left right)) + expected (n/* left right)]] + ($_ seq + (test "Lazying does not alter the expected value." + (n/= expected + (&.thaw lazy))) + (test "Lazy values only evaluate once." + (and (not (is? expected + (&.thaw lazy))) + (is? (&.thaw lazy) + (&.thaw lazy)))) + )))) + +(context: "Functor, Apply, Monad." + (<| (times 100) + (do @ + [sample r.nat] + ($_ seq + (test "Functor map." + (|> (&.freeze sample) + (:: &.functor map inc) + &.thaw + (n/= (inc sample)))) + + (test "Monad." + (|> (do &.monad + [f (wrap inc) + a (wrap sample)] + (wrap (f a))) + &.thaw + (n/= (inc sample)))) + + (test "Apply apply." + (let [(^open "&/.") &.monad + (^open "&/.") &.apply] + (|> (&/apply (&/wrap inc) (&/wrap sample)) + &.thaw + (n/= (inc sample))))) + )))) diff --git a/stdlib/source/test/lux/data/maybe.lux b/stdlib/source/test/lux/data/maybe.lux new file mode 100644 index 000000000..eb09491a1 --- /dev/null +++ b/stdlib/source/test/lux/data/maybe.lux @@ -0,0 +1,69 @@ +(.module: + [lux #* + [control + ["M" monad (#+ Monad do)] + pipe] + [data + ["&" maybe ("&/." monoid)] + ["." text ("text/." monoid)]] + ["." io ("io/." monad)]] + lux/test) + +(context: "Maybe" + (let [(^open "&/.") &.apply + (^open "&/.") &.monad + (^open "&/.") (&.equivalence text.equivalence)] + ($_ seq + (test "Can compare Maybe values." + (and (&/= #.None #.None) + (&/= (#.Some "yolo") (#.Some "yolo")) + (not (&/= (#.Some "yolo") (#.Some "lol"))) + (not (&/= (#.Some "yolo") #.None)))) + + (test "Monoid respects Maybe." + (and (&/= #.None &/identity) + (&/= (#.Some "yolo") (&/compose (#.Some "yolo") (#.Some "lol"))) + (&/= (#.Some "yolo") (&/compose (#.Some "yolo") #.None)) + (&/= (#.Some "lol") (&/compose #.None (#.Some "lol"))) + (&/= #.None (: (Maybe Text) (&/compose #.None #.None))))) + + (test "Functor respects Maybe." + (and (&/= #.None (&/map (text/compose "yolo") #.None)) + (&/= (#.Some "yololol") (&/map (text/compose "yolo") (#.Some "lol"))))) + + (test "Apply respects Maybe." + (and (&/= (#.Some "yolo") (&/wrap "yolo")) + (&/= (#.Some "yololol") + (&/apply (&/wrap (text/compose "yolo")) (&/wrap "lol"))))) + + (test "Monad respects Maybe." + (&/= (#.Some "yololol") + (do &.monad + [f (wrap text/compose) + a (wrap "yolo") + b (wrap "lol")] + (wrap (f a b))))) + + (do r.monad + [default r.nat + maybe r.nat] + (_.test "Can have defaults for Maybe values." + (and (is? default (maybe.default default + #.None)) + + (is? maybe (maybe.default default + (#.Some maybe)))))) + ))) + +(context: "Monad transformer" + (let [lift (&.lift io.monad)] + (test "Can add maybe functionality to any monad." + (|> (io.run (do (&.MaybeT io.monad) + [a (lift (io/wrap +123)) + b (wrap +456)] + (wrap (i/+ a b)))) + (case> (#.Some +579) + #1 + + _ + #0))))) diff --git a/stdlib/source/test/lux/data/name.lux b/stdlib/source/test/lux/data/name.lux new file mode 100644 index 000000000..3855fe221 --- /dev/null +++ b/stdlib/source/test/lux/data/name.lux @@ -0,0 +1,73 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe] + [data + ["&" name] + ["." text ("text/." equivalence) + format]] + [math + ["r" random]]] + lux/test) + +(def: (gen-part size) + (-> Nat (r.Random Text)) + (|> (r.unicode size) (r.filter (|>> (text.contains? ".") not)))) + +(context: "Names" + (<| (times 100) + (do @ + [## First Name + sizeM1 (|> r.nat (:: @ map (n/% 100))) + sizeN1 (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) + module1 (gen-part sizeM1) + short1 (gen-part sizeN1) + #let [name1 [module1 short1]] + ## Second Name + sizeM2 (|> r.nat (:: @ map (n/% 100))) + sizeN2 (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) + module2 (gen-part sizeM2) + short2 (gen-part sizeN2) + #let [name2 [module2 short2]] + #let [(^open "&/.") &.equivalence + (^open "&/.") &.codec]] + ($_ seq + (test "Can get the module & short parts of an name." + (and (is? module1 (&.module name1)) + (is? short1 (&.short name1)))) + + (test "Can compare names for equivalence." + (and (&/= name1 name1) + (if (&/= name1 name2) + (and (text/= module1 module2) + (text/= short1 short2)) + (or (not (text/= module1 module2)) + (not (text/= short1 short2)))))) + + (test "Can encode names as text." + (|> name1 + &/encode &/decode + (case> (#.Right dec-name) (&/= name1 dec-name) + _ #0))) + + (test "Encoding an name without a module component results in text equal to the short of the name." + (if (text.empty? module1) + (text/= short1 (&/encode name1)) + #1)) + )))) + +(context: "Name-related macros." + (let [(^open "&/.") &.equivalence] + ($_ seq + (test "Can obtain Name from identifier." + (and (&/= ["lux" "yolo"] (name-of .yolo)) + (&/= ["test/lux/data/name" "yolo"] (name-of ..yolo)) + (&/= ["" "yolo"] (name-of yolo)) + (&/= ["lux/test" "yolo"] (name-of lux/test.yolo)))) + + (test "Can obtain Name from tag." + (and (&/= ["lux" "yolo"] (name-of #.yolo)) + (&/= ["test/lux/data/name" "yolo"] (name-of #..yolo)) + (&/= ["" "yolo"] (name-of #yolo)) + (&/= ["lux/test" "yolo"] (name-of #lux/test.yolo))))))) diff --git a/stdlib/source/test/lux/data/number.lux b/stdlib/source/test/lux/data/number.lux new file mode 100644 index 000000000..9d870ab08 --- /dev/null +++ b/stdlib/source/test/lux/data/number.lux @@ -0,0 +1,185 @@ +(.module: + [lux #* + [control + ["M" monad (#+ Monad do)] + pipe] + [data + number + [text ("text/." equivalence) + format]] + [math + ["r" random]]] + lux/test) + +(do-template [category rand-gen <Equivalence> <Order>] + [(context: (format "[" category "] " "Equivalence & Order") + (<| (times 100) + (do @ + [x rand-gen + y rand-gen] + (test "" (and (:: <Equivalence> = x x) + (or (:: <Equivalence> = x y) + (:: <Order> < y x) + (:: <Order> > y x)))))))] + + ["Nat" r.nat equivalence order] + ["Int" r.int equivalence order] + ["Rev" r.rev equivalence order] + ["Frac" r.frac equivalence order] + ) + +(do-template [category rand-gen <Number> <Order>] + [(context: (format "[" category "] " "Number") + (<| (times 100) + (do @ + [x rand-gen + #let [(^open ".") <Number> + (^open ".") <Order>]] + (test "" (and (>= x (abs x)) + ## abs(0.0) == 0.0 && negate(abs(0.0)) == -0.0 + (or (text/= "Frac" category) + (not (= x (negate x)))) + (= x (negate (negate x))) + ## There is loss of precision when multiplying + (or (text/= "Rev" category) + (= x (* (signum x) + (abs x)))))))))] + + ["Nat" r.nat number order] + ["Int" r.int number order] + ["Rev" r.rev number order] + ["Frac" r.frac number order] + ) + +(do-template [category rand-gen <Enum> <Number> <Order>] + [(context: (format "[" category "] " "Enum") + (<| (times 100) + (do @ + [x rand-gen] + (test "" (let [(^open ".") <Number> + (^open ".") <Order>] + (and (> x + (:: <Enum> succ x)) + (< x + (:: <Enum> pred x)) + + (= x + (|> x (:: <Enum> pred) (:: <Enum> succ))) + (= x + (|> x (:: <Enum> succ) (:: <Enum> pred))) + ))))))] + + ["Nat" r.nat enum number order] + ["Int" r.int enum number order] + ) + +(do-template [category rand-gen <Number> <Order> <Interval> <test>] + [(context: (format "[" category "] " "Interval") + (<| (times 100) + (do @ + [x (|> rand-gen (r.filter <test>)) + #let [(^open ".") <Number> + (^open ".") <Order>]] + (test "" (and (<= x (:: <Interval> bottom)) + (>= x (:: <Interval> top)))))))] + + ["Nat" r.nat number order interval (function (_ _) #1)] + ["Int" r.int number order interval (function (_ _) #1)] + ## Both min and max values will be positive (thus, greater than zero) + ["Rev" r.rev number order interval (function (_ _) #1)] + ["Frac" r.frac number order interval (f/> +0.0)] + ) + +(do-template [category rand-gen <Number> <Order> <Monoid> <cap> <test>] + [(context: (format "[" category "] " "Monoid") + (<| (times 100) + (do @ + [x (|> rand-gen (:: @ map (|>> (:: <Number> abs) <cap>)) (r.filter <test>)) + #let [(^open ".") <Number> + (^open ".") <Order> + (^open ".") <Monoid>]] + (test "Composing with identity doesn't change the value." + (and (= x (compose identity x)) + (= x (compose x identity)) + (= identity (compose identity identity)))))))] + + ["Nat/Add" r.nat number order add@monoid (n/% 1000) (function (_ _) #1)] + ["Nat/Mul" r.nat number order mul@monoid (n/% 1000) (function (_ _) #1)] + ["Nat/Min" r.nat number order min@monoid (n/% 1000) (function (_ _) #1)] + ["Nat/Max" r.nat number order max@monoid (n/% 1000) (function (_ _) #1)] + ["Int/Add" r.int number order add@monoid (i/% +1000) (function (_ _) #1)] + ["Int/Mul" r.int number order mul@monoid (i/% +1000) (function (_ _) #1)] + ["Int/Min" r.int number order min@monoid (i/% +1000) (function (_ _) #1)] + ["Int/Max" r.int number order max@monoid (i/% +1000) (function (_ _) #1)] + ["Rev/Add" r.rev number order add@monoid (r/% .125) (function (_ _) #1)] + ["Rev/Mul" r.rev number order mul@monoid (r/% .125) (function (_ _) #1)] + ["Rev/Min" r.rev number order min@monoid (r/% .125) (function (_ _) #1)] + ["Rev/Max" r.rev number order max@monoid (r/% .125) (function (_ _) #1)] + ["Frac/Add" r.frac number order add@monoid (f/% +1000.0) (f/> +0.0)] + ["Frac/Mul" r.frac number order mul@monoid (f/% +1000.0) (f/> +0.0)] + ["Frac/Min" r.frac number order min@monoid (f/% +1000.0) (f/> +0.0)] + ["Frac/Max" r.frac number order max@monoid (f/% +1000.0) (f/> +0.0)] + ) + +(do-template [<category> <rand-gen> <Equivalence> <Codec>] + [(context: (format "[" <category> "] " "Alternative formats") + (<| (times 100) + (do @ + [x <rand-gen>] + (test "Can encode/decode values." + (|> x + (:: <Codec> encode) + (:: <Codec> decode) + (case> (#.Right x') + (:: <Equivalence> = x x') + + (#.Left _) + #0))))))] + + ["Nat/Binary" r.nat equivalence binary@codec] + ["Nat/Octal" r.nat equivalence octal@codec] + ["Nat/Decimal" r.nat equivalence codec] + ["Nat/Hex" r.nat equivalence hex@codec] + + ["Int/Binary" r.int equivalence binary@codec] + ["Int/Octal" r.int equivalence octal@codec] + ["Int/Decimal" r.int equivalence codec] + ["Int/Hex" r.int equivalence hex@codec] + + ["Rev/Binary" r.rev equivalence binary@codec] + ["Rev/Octal" r.rev equivalence octal@codec] + ["Rev/Decimal" r.rev equivalence codec] + ["Rev/Hex" r.rev equivalence hex@codec] + + ["Frac/Binary" r.frac equivalence binary@codec] + ["Frac/Octal" r.frac equivalence octal@codec] + ["Frac/Decimal" r.frac equivalence codec] + ["Frac/Hex" r.frac equivalence hex@codec] + ) + +(context: "Can convert frac values to/from their bit patterns." + (<| (times 100) + (do @ + [raw r.frac + factor (|> r.nat (:: @ map (|>> (n/% 1000) (n/max 1)))) + #let [sample (|> factor .int int-to-frac (f/* raw))]] + (test "Can convert frac values to/from their bit patterns." + (|> sample frac-to-bits bits-to-frac (f/= sample)))))) + +(context: "Macros for alternative numeric encodings." + ($_ seq + (test "Binary." + (and (n/= (bin "11001001") (bin "11_00_10_01")) + (i/= (bin "+11001001") (bin "+11_00_10_01")) + (r/= (bin ".11001001") (bin ".11_00_10_01")) + (f/= (bin "+1100.1001") (bin "+11_00.10_01")))) + (test "Octal." + (and (n/= (oct "615243") (oct "615_243")) + (i/= (oct "+615243") (oct "+615_243")) + (r/= (oct ".615243") (oct ".615_243")) + (f/= (oct "+6152.43") (oct "+615_2.43")))) + (test "Hexadecimal." + (and (n/= (hex "deadBEEF") (hex "dead_BEEF")) + (i/= (hex "+deadBEEF") (hex "+dead_BEEF")) + (r/= (hex ".deadBEEF") (hex ".dead_BEEF")) + (f/= (hex "+deadBE.EF") (hex "+dead_BE.EF")))))) diff --git a/stdlib/source/test/lux/data/number/complex.lux b/stdlib/source/test/lux/data/number/complex.lux new file mode 100644 index 000000000..850845296 --- /dev/null +++ b/stdlib/source/test/lux/data/number/complex.lux @@ -0,0 +1,201 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe] + [data + ["." number ("frac/." number) + ["&" complex]] + [collection + ["." list ("list/." functor)]]] + ["." math + ["r" random]]] + lux/test) + +(def: margin-of-error Frac +1.0e-9) + +(def: (within? margin standard value) + (-> Frac &.Complex &.Complex Bit) + (let [real-dist (frac/abs (f/- (get@ #&.real standard) + (get@ #&.real value))) + imgn-dist (frac/abs (f/- (get@ #&.imaginary standard) + (get@ #&.imaginary value)))] + (and (f/< margin real-dist) + (f/< margin imgn-dist)))) + +(def: gen-dim + (r.Random Frac) + (do r.monad + [factor (|> r.nat (:: @ map (|>> (n/% 1000) (n/max 1)))) + measure (|> r.frac (r.filter (f/> +0.0)))] + (wrap (f/* (|> factor .int int-to-frac) + measure)))) + +(def: gen-complex + (r.Random &.Complex) + (do r.monad + [real gen-dim + imaginary gen-dim] + (wrap (&.complex real imaginary)))) + +(context: "Construction" + (<| (times 100) + (do @ + [real gen-dim + imaginary gen-dim] + ($_ seq + (test "Can build and tear apart complex numbers" + (let [r+i (&.complex real imaginary)] + (and (f/= real (get@ #&.real r+i)) + (f/= imaginary (get@ #&.imaginary r+i))))) + + (test "If either the real part or the imaginary part is NaN, the composite is NaN." + (and (&.not-a-number? (&.complex number.not-a-number imaginary)) + (&.not-a-number? (&.complex real number.not-a-number)))) + )))) + +(context: "Absolute value" + (<| (times 100) + (do @ + [real gen-dim + imaginary gen-dim] + ($_ seq + (test "Absolute value of complex >= absolute value of any of the parts." + (let [r+i (&.complex real imaginary) + abs (get@ #&.real (&.abs r+i))] + (and (f/>= (frac/abs real) abs) + (f/>= (frac/abs imaginary) abs)))) + + (test "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value." + (and (number.not-a-number? (get@ #&.real (&.abs (&.complex number.not-a-number imaginary)))) + (number.not-a-number? (get@ #&.real (&.abs (&.complex real number.not-a-number)))))) + + (test "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value." + (and (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex number.positive-infinity imaginary)))) + (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex real number.positive-infinity)))) + (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex number.negative-infinity imaginary)))) + (f/= number.positive-infinity (get@ #&.real (&.abs (&.complex real number.negative-infinity)))))) + )))) + +(context: "Addidion, substraction, multiplication and division" + (<| (times 100) + (do @ + [x gen-complex + y gen-complex + factor gen-dim] + ($_ seq + (test "Adding 2 complex numbers is the same as adding their parts." + (let [z (&.+ y x)] + (and (&.= z + (&.complex (f/+ (get@ #&.real y) + (get@ #&.real x)) + (f/+ (get@ #&.imaginary y) + (get@ #&.imaginary x))))))) + + (test "Subtracting 2 complex numbers is the same as adding their parts." + (let [z (&.- y x)] + (and (&.= z + (&.complex (f/- (get@ #&.real y) + (get@ #&.real x)) + (f/- (get@ #&.imaginary y) + (get@ #&.imaginary x))))))) + + (test "Subtraction is the inverse of addition." + (and (|> x (&.+ y) (&.- y) (within? margin-of-error x)) + (|> x (&.- y) (&.+ y) (within? margin-of-error x)))) + + (test "Division is the inverse of multiplication." + (|> x (&.* y) (&./ y) (within? margin-of-error x))) + + (test "Scalar division is the inverse of scalar multiplication." + (|> x (&.*' factor) (&./' factor) (within? margin-of-error x))) + + (test "If you subtract the remainder, all divisions must be exact." + (let [rem (&.% y x) + quotient (|> x (&.- rem) (&./ y)) + floored (|> quotient + (update@ #&.real math.floor) + (update@ #&.imaginary math.floor))] + (within? +0.000000000001 + x + (|> quotient (&.* y) (&.+ rem))))) + )))) + +(context: "Conjugate, reciprocal, signum, negation" + (<| (times 100) + (do @ + [x gen-complex] + ($_ seq + (test "Conjugate has same real part as original, and opposite of imaginary part." + (let [cx (&.conjugate x)] + (and (f/= (get@ #&.real x) + (get@ #&.real cx)) + (f/= (frac/negate (get@ #&.imaginary x)) + (get@ #&.imaginary cx))))) + + (test "The reciprocal functions is its own inverse." + (|> x &.reciprocal &.reciprocal (within? margin-of-error x))) + + (test "x*(x^-1) = 1" + (|> x (&.* (&.reciprocal x)) (within? margin-of-error &.one))) + + (test "Absolute value of signum is always root2(2), 1 or 0." + (let [signum-abs (|> x &.signum &.abs (get@ #&.real))] + (or (f/= +0.0 signum-abs) + (f/= +1.0 signum-abs) + (f/= (math.pow +0.5 +2.0) signum-abs)))) + + (test "Negation is its own inverse." + (let [there (&.negate x) + back-again (&.negate there)] + (and (not (&.= there x)) + (&.= back-again x)))) + + (test "Negation doesn't change the absolute value." + (f/= (get@ #&.real (&.abs x)) + (get@ #&.real (&.abs (&.negate x))))) + )))) + +(def: (trigonometric-symmetry forward backward angle) + (-> (-> &.Complex &.Complex) (-> &.Complex &.Complex) &.Complex Bit) + (let [normal (|> angle forward backward)] + (|> normal forward backward (within? margin-of-error normal)))) + +(context: "Trigonometry" + (<| (seed 17274883666004960943) + ## (times 100) + (do @ + [angle (|> gen-complex (:: @ map (|>> (update@ #&.real (f/% +1.0)) + (update@ #&.imaginary (f/% +1.0)))))] + ($_ seq + (test "Arc-sine is the inverse of sine." + (trigonometric-symmetry &.sin &.asin angle)) + + (test "Arc-cosine is the inverse of cosine." + (trigonometric-symmetry &.cos &.acos angle)) + + (test "Arc-tangent is the inverse of tangent." + (trigonometric-symmetry &.tan &.atan angle)))))) + +(context: "Power 2 and exponential/logarithm" + (<| (times 100) + (do @ + [x gen-complex] + ($_ seq + (test "Root 2 is inverse of power 2." + (|> x (&.pow' +2.0) (&.pow' +0.5) (within? margin-of-error x))) + + (test "Logarithm is inverse of exponentiation." + (|> x &.log &.exp (within? margin-of-error x))) + )))) + +(context: "Complex roots" + (<| (times 100) + (do @ + [sample gen-complex + degree (|> r.nat (:: @ map (|>> (n/max 1) (n/% 5))))] + (test "Can calculate the N roots for any complex number." + (|> sample + (&.roots degree) + (list/map (&.pow' (|> degree .int int-to-frac))) + (list.every? (within? margin-of-error sample))))))) diff --git a/stdlib/source/test/lux/data/number/i64.lux b/stdlib/source/test/lux/data/number/i64.lux new file mode 100644 index 000000000..62de5e56e --- /dev/null +++ b/stdlib/source/test/lux/data/number/i64.lux @@ -0,0 +1,75 @@ +(.module: + [lux #* + [control + ["M" monad (#+ do Monad)]] + [data + [number #* + ["&" i64]]] + [math + ["r" random]]] + lux/test) + +(context: "Bitwise operations." + (<| (times 100) + (do @ + [pattern r.nat + idx (:: @ map (n/% &.width) r.nat)] + ($_ seq + (test "Clearing and settings bits should alter the count." + (and (n/= (dec (&.count (&.set idx pattern))) + (&.count (&.clear idx pattern))) + (|> (&.count pattern) + (n/- (&.count (&.clear idx pattern))) + (n/<= 1)) + (|> (&.count (&.set idx pattern)) + (n/- (&.count pattern)) + (n/<= 1)))) + (test "Can query whether a bit is set." + (and (or (and (&.set? idx pattern) + (not (&.set? idx (&.clear idx pattern)))) + (and (not (&.set? idx pattern)) + (&.set? idx (&.set idx pattern)))) + + (or (and (&.set? idx pattern) + (not (&.set? idx (&.flip idx pattern)))) + (and (not (&.set? idx pattern)) + (&.set? idx (&.flip idx pattern)))))) + (test "The negation of a bit pattern should have a complementary bit-count." + (n/= &.width + (n/+ (&.count pattern) + (&.count (&.not pattern))))) + (test "Can do simple binary logic." + (and (n/= 0 + (&.and pattern + (&.not pattern))) + (n/= (&.not 0) + (&.or pattern + (&.not pattern))) + (n/= (&.not 0) + (&.xor pattern + (&.not pattern))) + (n/= 0 + (&.xor pattern + pattern)))) + (test "rotate-left and rotate-right are inverses of one another." + (and (|> pattern + (&.rotate-left idx) + (&.rotate-right idx) + (n/= pattern)) + (|> pattern + (&.rotate-right idx) + (&.rotate-left idx) + (n/= pattern)))) + (test "Rotate as many spaces as the bit-pattern's width leaves the pattern unchanged." + (and (|> pattern + (&.rotate-left &.width) + (n/= pattern)) + (|> pattern + (&.rotate-right &.width) + (n/= pattern)))) + (test "Shift right respect the sign of ints." + (let [value (.int pattern)] + (if (i/< +0 value) + (i/< +0 (&.arithmetic-right-shift idx value)) + (i/>= +0 (&.arithmetic-right-shift idx value))))) + )))) diff --git a/stdlib/source/test/lux/data/number/ratio.lux b/stdlib/source/test/lux/data/number/ratio.lux new file mode 100644 index 000000000..63d1e5fc8 --- /dev/null +++ b/stdlib/source/test/lux/data/number/ratio.lux @@ -0,0 +1,116 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe] + [data + [number + ["&" ratio ("&/." number)]]] + [math + ["r" random]]] + lux/test) + +(def: gen-part + (r.Random Nat) + (|> r.nat (:: r.monad map (|>> (n/% 1000) (n/max 1))))) + +(def: gen-ratio + (r.Random &.Ratio) + (do r.monad + [numerator gen-part + denominator (|> gen-part + (r.filter (|>> (n/= 0) not)) + (r.filter (|>> (n/= numerator) not)))] + (wrap (&.ratio numerator denominator)))) + +(context: "Normalization" + (<| (times 100) + (do @ + [denom1 gen-part + denom2 gen-part + sample gen-ratio] + ($_ seq + (test "All zeroes are the same." + (&.= (&.ratio 0 denom1) + (&.ratio 0 denom2))) + + (test "All ratios are built normalized." + (|> sample + &.normalize + ("lux in-module" "lux/data/number/ratio") + (&.= sample))) + )))) + +(context: "Arithmetic" + (<| (times 100) + (do @ + [x gen-ratio + y gen-ratio + #let [min (&.min x y) + max (&.max x y)]] + ($_ seq + (test "Addition and subtraction are opposites." + (and (|> max (&.- min) (&.+ min) (&.= max)) + (|> max (&.+ min) (&.- min) (&.= max)))) + + (test "Multiplication and division are opposites." + (and (|> max (&./ min) (&.* min) (&.= max)) + (|> max (&.* min) (&./ min) (&.= max)))) + + (test "Modulus by a larger ratio doesn't change the value." + (|> min (&.% max) (&.= min))) + + (test "Modulus by a smaller ratio results in a value smaller than the limit." + (|> max (&.% min) (&.< min))) + + (test "Can get the remainder of a division." + (let [remainder (&.% min max) + multiple (&.- remainder max) + factor (&./ min multiple)] + (and (|> factor (get@ #&.denominator) (n/= 1)) + (|> factor (&.* min) (&.+ remainder) (&.= max))))) + )))) + +(context: "Negation, absolute value and signum" + (<| (times 100) + (do @ + [sample gen-ratio] + ($_ seq + (test "Negation is it's own inverse." + (let [there (&/negate sample) + back-again (&/negate there)] + (and (not (&.= there sample)) + (&.= back-again sample)))) + + (test "All ratios are already at their absolute value." + (|> sample &/abs (&.= sample))) + + (test "Signum is the identity." + (|> sample (&.* (&/signum sample)) (&.= sample))) + )))) + +(context: "Order" + (<| (times 100) + (do @ + [x gen-ratio + y gen-ratio] + ($_ seq + (test "Can compare ratios." + (and (or (&.<= y x) + (&.> y x)) + (or (&.>= y x) + (&.< y x)))) + )))) + +(context: "Codec" + (<| (times 100) + (do @ + [sample gen-ratio + #let [(^open "&/.") &.codec]] + (test "Can encode/decode ratios." + (|> sample &/encode &/decode + (case> (#.Right output) + (&.= sample output) + + _ + #0)))))) diff --git a/stdlib/source/test/lux/data/product.lux b/stdlib/source/test/lux/data/product.lux new file mode 100644 index 000000000..86db80d0e --- /dev/null +++ b/stdlib/source/test/lux/data/product.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + ["@" product]]] + lux/test) + +(context: "Products" + ($_ seq + (test "Can access the sides of a pair." + (and (i/= +1 (@.left [+1 +2])) + (i/= +2 (@.right [+1 +2])))) + + (test "Can swap the sides of a pair." + (let [[_left _right] (@.swap [+1 +2])] + (and (i/= +2 _left) + (i/= +1 _right)))) + )) diff --git a/stdlib/source/test/lux/data/sum.lux b/stdlib/source/test/lux/data/sum.lux new file mode 100644 index 000000000..d47922304 --- /dev/null +++ b/stdlib/source/test/lux/data/sum.lux @@ -0,0 +1,37 @@ +(.module: + [lux #* + [control + pipe] + [data + sum + ["." text] + [collection + ["." list]]]] + lux/test) + +(context: "Sum operations" + (let [(^open "List/.") (list.equivalence text.equivalence)] + ($_ seq + (test "Can inject values into Either." + (and (|> (left "Hello") (case> (0 "Hello") #1 _ #0)) + (|> (right "World") (case> (1 "World") #1 _ #0)))) + + (test "Can discriminate eithers based on their cases." + (let [[_lefts _rights] (partition (: (List (| Text Text)) + (list (0 "+0") (1 "+1") (0 "+2"))))] + (and (List/= _lefts + (lefts (: (List (| Text Text)) + (list (0 "+0") (1 "+1") (0 "+2"))))) + + (List/= _rights + (rights (: (List (| Text Text)) + (list (0 "+0") (1 "+1") (0 "+2")))))))) + + (test "Can apply a function to an Either value depending on the case." + (and (i/= +10 (either (function (_ _) +10) + (function (_ _) +20) + (: (| Text Text) (0 "")))) + (i/= +20 (either (function (_ _) +10) + (function (_ _) +20) + (: (| Text Text) (1 "")))))) + ))) diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux new file mode 100644 index 000000000..01cd2220d --- /dev/null +++ b/stdlib/source/test/lux/data/text.lux @@ -0,0 +1,143 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe] + [data + ["&" text + format] + [collection + ["." list]]] + [math + ["r" random]]] + lux/test) + +(context: "Size" + (<| (times 100) + (do @ + [size (:: @ map (n/% 100) r.nat) + sample (r.unicode size)] + (test "" (or (and (n/= 0 size) + (&.empty? sample)) + (n/= size (&.size sample))))))) + +(def: bounded-size + (r.Random Nat) + (|> r.nat + (:: r.monad map (|>> (n/% 20) (n/+ 1))))) + +(context: "Locations" + (<| (times 100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.unicode size)] + (test "" (|> sample + (&.nth idx) + (case> (^multi (#.Some char) + [(&.from-code char) char] + [[(&.index-of char sample) + (&.last-index-of char sample) + (&.index-of' char idx sample) + (&.last-index-of' char idx sample)] + [(#.Some io) (#.Some lio) + (#.Some io') (#.Some lio')]]) + (and (n/<= idx io) + (n/>= idx lio) + + (n/= idx io') + (n/>= idx lio') + + (&.contains? char sample)) + + _ + #0 + )) + )))) + +(context: "Text functions" + (<| (times 100) + (do @ + [sizeL bounded-size + sizeR bounded-size + sampleL (r.unicode sizeL) + sampleR (r.unicode sizeR) + #let [sample (&.concat (list sampleL sampleR)) + fake-sample (&.join-with " " (list sampleL sampleR)) + dup-sample (&.join-with "" (list sampleL sampleR)) + enclosed-sample (&.enclose [sampleR sampleR] sampleL) + (^open ".") &.equivalence]] + (test "" (and (not (= sample fake-sample)) + (= sample dup-sample) + (&.starts-with? sampleL sample) + (&.ends-with? sampleR sample) + (= enclosed-sample + (&.enclose' sampleR sampleL)) + + (|> (&.split sizeL sample) + (case> (#.Right [_l _r]) + (and (= sampleL _l) + (= sampleR _r) + (= sample (&.concat (list _l _r)))) + + _ + #0)) + + (|> [(&.clip 0 sizeL sample) + (&.clip sizeL (&.size sample) sample) + (&.clip' sizeL sample) + (&.clip' 0 sample)] + (case> [(#.Right _l) (#.Right _r) (#.Right _r') (#.Right _f)] + (and (= sampleL _l) + (= sampleR _r) + (= _r _r') + (= sample _f)) + + _ + #0)) + ) + )))) + +(context: "More text functions" + (<| (times 100) + (do @ + [sizeP bounded-size + sizeL bounded-size + #let [## The wider unicode charset includes control characters that + ## can make text replacement work improperly. + ## Because of that, I restrict the charset. + normal-char-gen (|> r.nat (:: @ map (|>> (n/% 128) (n/max 1))))] + sep1 (r.text normal-char-gen 1) + sep2 (r.text normal-char-gen 1) + #let [part-gen (|> (r.text normal-char-gen sizeP) + (r.filter (|>> (&.contains? sep1) not)))] + parts (r.list sizeL part-gen) + #let [sample1 (&.concat (list.interpose sep1 parts)) + sample2 (&.concat (list.interpose sep2 parts)) + (^open "&/.") &.equivalence]] + ($_ seq + (test "Can split text through a separator." + (n/= (list.size parts) + (list.size (&.split-all-with sep1 sample1)))) + + (test "Can replace occurrences of a piece of text inside a larger text." + (&/= sample2 + (&.replace-all sep1 sep2 sample1))) + )))) + +(context: "Structures" + (let [(^open "&/.") &.order] + ($_ seq + (test "" (&/< "bcd" "abc")) + (test "" (not (&/< "abc" "abc"))) + (test "" (not (&/< "abc" "bcd"))) + (test "" (&/<= "bcd" "abc")) + (test "" (&/<= "abc" "abc")) + (test "" (not (&/<= "abc" "bcd"))) + (test "" (&/> "abc" "bcd")) + (test "" (not (&/> "abc" "abc"))) + (test "" (not (&/> "bcd" "abc"))) + (test "" (&/>= "abc" "bcd")) + (test "" (&/>= "abc" "abc")) + (test "" (not (&/>= "bcd" "abc"))) + ))) diff --git a/stdlib/source/test/lux/data/text/format.lux b/stdlib/source/test/lux/data/text/format.lux new file mode 100644 index 000000000..d3bbafe7e --- /dev/null +++ b/stdlib/source/test/lux/data/text/format.lux @@ -0,0 +1,21 @@ +(.module: + [lux #* + [control + [monad (#+ Monad do)]] + [data + ["." text + format]]] + lux/test) + +(context: "Formatters" + (let [(^open "&/.") text.equivalence] + ($_ seq + (test "Can format common values simply." + (and (&/= "#1" (%b #1)) + (&/= "123" (%n 123)) + (&/= "+123" (%i +123)) + (&/= "+123.456" (%f +123.456)) + (&/= ".5" (%r .5)) + (&/= (format text.double-quote "YOLO" text.double-quote) (%t "YOLO")) + (&/= "User-id: +123 -- Active: #1" (format "User-id: " (%i +123) " -- Active: " (%b #1))))) + ))) diff --git a/stdlib/source/test/lux/data/text/lexer.lux b/stdlib/source/test/lux/data/text/lexer.lux new file mode 100644 index 000000000..a1e52b64c --- /dev/null +++ b/stdlib/source/test/lux/data/text/lexer.lux @@ -0,0 +1,205 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe + ["p" parser]] + [data + ["." error (#+ Error)] + ["." text ("text/." equivalence) + format + ["&" lexer]] + [collection + ["." list]]] + [math + ["r" random]]] + lux/test) + +## [Utils] +(def: (should-fail input) + (All [a] (-> (Error a) Bit)) + (case input + (#.Left _) #1 + _ #0)) + +(def: (should-passT test input) + (-> Text (Error Text) Bit) + (case input + (#.Right output) + (text/= test output) + + _ + #0)) + +(def: (should-passL test input) + (-> (List Text) (Error (List Text)) Bit) + (let [(^open "list/.") (list.equivalence text.equivalence)] + (case input + (#.Right output) + (list/= test output) + + _ + #0))) + +(def: (should-passE test input) + (-> (Either Text Text) (Error (Either Text Text)) Bit) + (case input + (#.Right output) + (case [test output] + [(#.Left test) (#.Left output)] + (text/= test output) + + [(#.Right test) (#.Right output)] + (text/= test output) + + _ + #0) + + _ + #0)) + +## [Tests] +(context: "End" + ($_ seq + (test "Can detect the end of the input." + (|> (&.run "" + &.end) + (case> (#.Right _) #1 _ #0))) + + (test "Won't mistake non-empty text for no more input." + (|> (&.run "YOLO" + &.end) + (case> (#.Left _) #1 _ #0))) + )) + +(context: "Literals" + (<| (times 100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 10)))) + sample (r.unicode size) + non-sample (|> (r.unicode size) + (r.filter (|>> (text/= sample) not)))] + ($_ seq + (test "Can find literal text fragments." + (and (|> (&.run sample + (&.this sample)) + (case> (#.Right []) #1 _ #0)) + (|> (&.run non-sample + (&.this sample)) + (case> (#.Left _) #1 _ #0)))) + )))) + +(context: "Custom lexers" + ($_ seq + (test "Can lex anything" + (and (should-passT "A" (&.run "A" + &.any)) + (should-fail (&.run "" + &.any)))) + + (test "Can lex characters ranges." + (and (should-passT "Y" (&.run "Y" + (&.range (char "X") (char "Z")))) + (should-fail (&.run "M" + (&.range (char "X") (char "Z")))))) + + (test "Can lex upper-case and lower-case letters." + (and (should-passT "Y" (&.run "Y" + &.upper)) + (should-fail (&.run "m" + &.upper)) + + (should-passT "y" (&.run "y" + &.lower)) + (should-fail (&.run "M" + &.lower)))) + + (test "Can lex numbers." + (and (should-passT "1" (&.run "1" + &.decimal)) + (should-fail (&.run " " + &.decimal)) + + (should-passT "7" (&.run "7" + &.octal)) + (should-fail (&.run "8" + &.octal)) + + (should-passT "1" (&.run "1" + &.hexadecimal)) + (should-passT "a" (&.run "a" + &.hexadecimal)) + (should-passT "A" (&.run "A" + &.hexadecimal)) + (should-fail (&.run " " + &.hexadecimal)) + )) + + (test "Can lex alphabetic characters." + (and (should-passT "A" (&.run "A" + &.alpha)) + (should-passT "a" (&.run "a" + &.alpha)) + (should-fail (&.run "1" + &.alpha)))) + + (test "Can lex alphanumeric characters." + (and (should-passT "A" (&.run "A" + &.alpha-num)) + (should-passT "a" (&.run "a" + &.alpha-num)) + (should-passT "1" (&.run "1" + &.alpha-num)) + (should-fail (&.run " " + &.alpha-num)))) + + (test "Can lex white-space." + (and (should-passT " " (&.run " " + &.space)) + (should-fail (&.run "8" + &.space)))) + )) + +(context: "Combinators" + ($_ seq + (test "Can combine lexers sequentially." + (and (|> (&.run "YO" + (p.and &.any &.any)) + (case> (#.Right ["Y" "O"]) #1 + _ #0)) + (should-fail (&.run "Y" + (p.and &.any &.any))))) + + (test "Can create the opposite of a lexer." + (and (should-passT "a" (&.run "a" + (&.not (p.or &.decimal &.upper)))) + (should-fail (&.run "A" + (&.not (p.or &.decimal &.upper)))))) + + (test "Can select from among a set of characters." + (and (should-passT "C" (&.run "C" + (&.one-of "ABC"))) + (should-fail (&.run "D" + (&.one-of "ABC"))))) + + (test "Can avoid a set of characters." + (and (should-passT "D" (&.run "D" + (&.none-of "ABC"))) + (should-fail (&.run "C" + (&.none-of "ABC"))))) + + (test "Can lex using arbitrary predicates." + (and (should-passT "D" (&.run "D" + (&.satisfies (function (_ c) #1)))) + (should-fail (&.run "C" + (&.satisfies (function (_ c) #0)))))) + + (test "Can apply a lexer multiple times." + (and (should-passT "0123456789ABCDEF" (&.run "0123456789ABCDEF" + (&.many &.hexadecimal))) + (should-fail (&.run "yolo" + (&.many &.hexadecimal))) + + (should-passT "" (&.run "" + (&.some &.hexadecimal))))) + )) diff --git a/stdlib/source/test/lux/data/text/regex.lux b/stdlib/source/test/lux/data/text/regex.lux new file mode 100644 index 000000000..f6bc7d098 --- /dev/null +++ b/stdlib/source/test/lux/data/text/regex.lux @@ -0,0 +1,286 @@ +(.module: + [lux #* + [control + [monad (#+ do Monad)] + pipe + ["p" parser]] + [data + [number (#+ hex)] + ["." text ("text/." equivalence) + format + ["." lexer (#+ Lexer)] + ["&" regex]]] + [math + ["r" random]] + [macro + ["s" syntax (#+ syntax:)]]] + lux/test) + +## [Utils] +(def: (should-pass regex input) + (-> (Lexer Text) Text Bit) + (|> (lexer.run input regex) + (case> (#.Right parsed) + (text/= parsed input) + + _ + #0))) + +(def: (should-passT test regex input) + (-> Text (Lexer Text) Text Bit) + (|> (lexer.run input regex) + (case> (#.Right parsed) + (text/= test parsed) + + _ + #0))) + +(def: (should-fail regex input) + (All [a] (-> (Lexer a) Text Bit)) + (|> (lexer.run input regex) + (case> (#.Left _) #1 _ #0))) + +(syntax: (should-check pattern regex input) + (wrap (list (` (|> (lexer.run (~ input) (~ regex)) + (case> (^ (#.Right (~ pattern))) + #1 + + (~' _) + #0)))))) + +## [Tests] +(context: "Regular Expressions [Basics]" + (test "Can parse character literals." + (and (should-pass (&.regex "a") "a") + (should-fail (&.regex "a") ".") + (should-pass (&.regex "\.") ".") + (should-fail (&.regex "\.") "a")))) + +(context: "Regular Expressions [System character classes]" + ($_ seq + (test "Can parse anything." + (should-pass (&.regex ".") "a")) + + (test "Can parse digits." + (and (should-pass (&.regex "\d") "0") + (should-fail (&.regex "\d") "m"))) + + (test "Can parse non digits." + (and (should-pass (&.regex "\D") "m") + (should-fail (&.regex "\D") "0"))) + + (test "Can parse white-space." + (and (should-pass (&.regex "\s") " ") + (should-fail (&.regex "\s") "m"))) + + (test "Can parse non white-space." + (and (should-pass (&.regex "\S") "m") + (should-fail (&.regex "\S") " "))) + + (test "Can parse word characters." + (and (should-pass (&.regex "\w") "_") + (should-fail (&.regex "\w") "^"))) + + (test "Can parse non word characters." + (and (should-pass (&.regex "\W") ".") + (should-fail (&.regex "\W") "a"))) + )) + +(context: "Regular Expressions [Special system character classes : Part 1]" + ($_ seq + (test "Can parse using special character classes." + (and (and (should-pass (&.regex "\p{Lower}") "m") + (should-fail (&.regex "\p{Lower}") "M")) + + (and (should-pass (&.regex "\p{Upper}") "M") + (should-fail (&.regex "\p{Upper}") "m")) + + (and (should-pass (&.regex "\p{Alpha}") "M") + (should-fail (&.regex "\p{Alpha}") "0")) + + (and (should-pass (&.regex "\p{Digit}") "1") + (should-fail (&.regex "\p{Digit}") "n")) + + (and (should-pass (&.regex "\p{Alnum}") "1") + (should-fail (&.regex "\p{Alnum}") ".")) + + (and (should-pass (&.regex "\p{Space}") " ") + (should-fail (&.regex "\p{Space}") ".")) + )) + )) + +(context: "Regular Expressions [Special system character classes : Part 2]" + ($_ seq + (test "Can parse using special character classes." + (and (and (should-pass (&.regex "\p{HexDigit}") "a") + (should-fail (&.regex "\p{HexDigit}") ".")) + + (and (should-pass (&.regex "\p{OctDigit}") "6") + (should-fail (&.regex "\p{OctDigit}") ".")) + + (and (should-pass (&.regex "\p{Blank}") text.tab) + (should-fail (&.regex "\p{Blank}") ".")) + + (and (should-pass (&.regex "\p{ASCII}") text.tab) + (should-fail (&.regex "\p{ASCII}") (text.from-code (hex "1234")))) + + (and (should-pass (&.regex "\p{Contrl}") (text.from-code (hex "12"))) + (should-fail (&.regex "\p{Contrl}") "a")) + + (and (should-pass (&.regex "\p{Punct}") "@") + (should-fail (&.regex "\p{Punct}") "a")) + + (and (should-pass (&.regex "\p{Graph}") "@") + (should-fail (&.regex "\p{Graph}") " ")) + + (and (should-pass (&.regex "\p{Print}") (text.from-code (hex "20"))) + (should-fail (&.regex "\p{Print}") (text.from-code (hex "1234")))) + )) + )) + +(context: "Regular Expressions [Custom character classes : Part 1]" + ($_ seq + (test "Can parse using custom character classes." + (and (should-pass (&.regex "[abc]") "a") + (should-fail (&.regex "[abc]") "m"))) + + (test "Can parse using character ranges." + (and (should-pass (&.regex "[a-z]") "a") + (should-pass (&.regex "[a-z]") "m") + (should-pass (&.regex "[a-z]") "z"))) + + (test "Can combine character ranges." + (and (should-pass (&.regex "[a-zA-Z]") "a") + (should-pass (&.regex "[a-zA-Z]") "m") + (should-pass (&.regex "[a-zA-Z]") "z") + (should-pass (&.regex "[a-zA-Z]") "A") + (should-pass (&.regex "[a-zA-Z]") "M") + (should-pass (&.regex "[a-zA-Z]") "Z"))) + )) + +(context: "Regular Expressions [Custom character classes : Part 2]" + ($_ seq + (test "Can negate custom character classes." + (and (should-fail (&.regex "[^abc]") "a") + (should-pass (&.regex "[^abc]") "m"))) + + (test "Can negate character ranges.." + (and (should-fail (&.regex "[^a-z]") "a") + (should-pass (&.regex "[^a-z]") "0"))) + + (test "Can parse negate combinations of character ranges." + (and (should-fail (&.regex "[^a-zA-Z]") "a") + (should-pass (&.regex "[^a-zA-Z]") "0"))) + )) + +(context: "Regular Expressions [Custom character classes : Part 3]" + ($_ seq + (test "Can make custom character classes more specific." + (and (let [RE (&.regex "[a-z&&[def]]")] + (and (should-fail RE "a") + (should-pass RE "d"))) + + (let [RE (&.regex "[a-z&&[^bc]]")] + (and (should-pass RE "a") + (should-fail RE "b"))) + + (let [RE (&.regex "[a-z&&[^m-p]]")] + (and (should-pass RE "a") + (should-fail RE "m") + (should-fail RE "p"))))) + )) + +(context: "Regular Expressions [Reference]" + (let [number (&.regex "\d+")] + (test "Can build complex regexs by combining simpler ones." + (should-check ["809-345-6789" "809" "345" "6789"] (&.regex "(\@<number>)-(\@<number>)-(\@<number>)") "809-345-6789")))) + +(context: "Regular Expressions [Fuzzy Quantifiers]" + ($_ seq + (test "Can sequentially combine patterns." + (should-passT "aa" (&.regex "aa") "aa")) + + (test "Can match patterns optionally." + (and (should-passT "a" (&.regex "a?") "a") + (should-passT "" (&.regex "a?") ""))) + + (test "Can match a pattern 0 or more times." + (and (should-passT "aaa" (&.regex "a*") "aaa") + (should-passT "" (&.regex "a*") ""))) + + (test "Can match a pattern 1 or more times." + (and (should-passT "aaa" (&.regex "a+") "aaa") + (should-passT "a" (&.regex "a+") "a") + (should-fail (&.regex "a+") ""))) + )) + +(context: "Regular Expressions [Crisp Quantifiers]" + ($_ seq + (test "Can match a pattern N times." + (and (should-passT "aa" (&.regex "a{2}") "aa") + (should-passT "a" (&.regex "a{1}") "a") + (should-fail (&.regex "a{3}") "aa"))) + + (test "Can match a pattern at-least N times." + (and (should-passT "aa" (&.regex "a{1,}") "aa") + (should-passT "aa" (&.regex "a{2,}") "aa") + (should-fail (&.regex "a{3,}") "aa"))) + + (test "Can match a pattern at-most N times." + (and (should-passT "aa" (&.regex "a{,2}") "aa") + (should-passT "aa" (&.regex "a{,3}") "aa"))) + + (test "Can match a pattern between N and M times." + (and (should-passT "a" (&.regex "a{1,2}") "a") + (should-passT "aa" (&.regex "a{1,2}") "aa"))) + )) + +(context: "Regular Expressions [Groups]" + ($_ seq + (test "Can extract groups of sub-matches specified in a pattern." + (and (should-check ["abc" "b"] (&.regex "a(.)c") "abc") + (should-check ["abbbbbc" "bbbbb"] (&.regex "a(b+)c") "abbbbbc") + (should-check ["809-345-6789" "809" "345" "6789"] (&.regex "(\d{3})-(\d{3})-(\d{4})") "809-345-6789") + (should-check ["809-345-6789" "809" "6789"] (&.regex "(\d{3})-(?:\d{3})-(\d{4})") "809-345-6789") + (should-check ["809-809-6789" "809" "6789"] (&.regex "(\d{3})-\0-(\d{4})") "809-809-6789") + (should-check ["809-809-6789" "809" "6789"] (&.regex "(?<code>\d{3})-\k<code>-(\d{4})") "809-809-6789") + (should-check ["809-809-6789-6789" "809" "6789"] (&.regex "(?<code>\d{3})-\k<code>-(\d{4})-\0") "809-809-6789-6789"))) + + (test "Can specify groups within groups." + (should-check ["809-345-6789" "809" ["345-6789" "345" "6789"]] (&.regex "(\d{3})-((\d{3})-(\d{4}))") "809-345-6789")) + )) + +(context: "Regular Expressions [Alternation]" + ($_ seq + (test "Can specify alternative patterns." + (and (should-check ["a" (0 [])] (&.regex "a|b") "a") + (should-check ["b" (1 [])] (&.regex "a|b") "b") + (should-fail (&.regex "a|b") "c"))) + + (test "Can have groups within alternations." + (and (should-check ["abc" (0 ["b" "c"])] (&.regex "a(.)(.)|b(.)(.)") "abc") + (should-check ["bcd" (1 ["c" "d"])] (&.regex "a(.)(.)|b(.)(.)") "bcd") + (should-fail (&.regex "a(.)(.)|b(.)(.)") "cde") + + (should-check ["809-345-6789" (0 ["809" "345-6789" "345" "6789"])] + (&.regex "(\d{3})-((\d{3})-(\d{4}))|b(.)d") + "809-345-6789"))) + )) + +(context: "Pattern-matching" + (<| (times 100) + (do @ + [sample1 (r.unicode 3) + sample2 (r.unicode 3) + sample3 (r.unicode 4)] + (case (format sample1 "-" sample2 "-" sample3) + (&.^regex "(.{3})-(.{3})-(.{4})" + [_ match1 match2 match3]) + (test "Can pattern-match using regular-expressions." + (and (text/= sample1 match1) + (text/= sample2 match2) + (text/= sample3 match3))) + + _ + (test "Cannot pattern-match using regular-expressions." + #0))))) |