From 4f1553c6f6bb579f09749d5b9ca955c43a7440a4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Apr 2020 20:54:02 -0400 Subject: Test for concatenative programming. --- stdlib/source/test/lux/control.lux | 2 + stdlib/source/test/lux/control/concatenative.lux | 235 +++++++++++++++++++++++ stdlib/source/test/lux/control/continuation.lux | 14 +- 3 files changed, 244 insertions(+), 7 deletions(-) create mode 100644 stdlib/source/test/lux/control/concatenative.lux (limited to 'stdlib/source/test') diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index ace450eba..169332b30 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -2,6 +2,7 @@ [lux (#- function) ["_" test (#+ Test)]] ["." / #_ + ["#." concatenative] ["#." continuation] ["#." try] ["#." exception] @@ -60,6 +61,7 @@ (def: #export test Test ($_ _.and + /concatenative.test /continuation.test /try.test /exception.test diff --git a/stdlib/source/test/lux/control/concatenative.lux b/stdlib/source/test/lux/control/concatenative.lux new file mode 100644 index 000000000..c649128b0 --- /dev/null +++ b/stdlib/source/test/lux/control/concatenative.lux @@ -0,0 +1,235 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [data + ["." sum] + ["." name] + ["." bit ("#@." equivalence)] + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]] + [text + ["%" format (#+ format)]]] + [math + ["." random]] + [macro + ["." template]]] + {1 + ["." / (#+ word: => ||>)]}) + +(def: stack-shuffling + Test + (do random.monad + [sample random.nat + dummy random.nat] + (`` ($_ _.and + (_.test (%.name (name-of /.push)) + (n.= sample + (||> (/.push sample)))) + (_.test (%.name (name-of /.drop)) + (n.= sample + (||> (/.push sample) + (/.push dummy) + /.drop))) + (_.test (%.name (name-of /.nip)) + (n.= sample + (||> (/.push dummy) + (/.push sample) + /.nip))) + (_.test (%.name (name-of /.dup)) + (||> (/.push sample) + /.dup + /.n/=)) + (_.test (%.name (name-of /.swap)) + (n.= sample + (||> (/.push sample) + (/.push dummy) + /.swap))) + (_.test (%.name (name-of /.rotL)) + (n.= sample + (||> (/.push sample) + (/.push dummy) + (/.push dummy) + /.rotL))) + (_.test (%.name (name-of /.rotR)) + (n.= sample + (||> (/.push dummy) + (/.push sample) + (/.push dummy) + /.rotR))) + (_.test (%.name (name-of /.&&)) + (let [[left right] (||> (/.push sample) + (/.push dummy) + /.&&)] + (and (n.= sample left) + (n.= dummy right)))) + (~~ (template [ ] + [(_.test (%.name (name-of )) + ((sum.equivalence n.= n.=) + ( sample) + (||> (/.push sample) + )))] + + [/.||L #.Left] + [/.||R #.Right])) + (_.test (%.name (name-of /.dip)) + (n.= (inc sample) + (||> (/.push sample) + (/.push dummy) + (/.push (/.apply/1 inc)) + /.dip + /.drop))) + (_.test (%.name (name-of /.dip/2)) + (n.= (inc sample) + (||> (/.push sample) + (/.push dummy) + (/.push dummy) + (/.push (/.apply/1 inc)) + /.dip/2 + /.drop /.drop))) + )))) + +(template: (!numerical <=> ) + (: Test + (with-expansions [' (template.splice ) + ' (template.splice )] + (do random.monad + [parameter (|> (random.filter )) + subject ] + (`` ($_ _.and + (~~ (template [ ] + [(_.test (%.name (name-of )) + (<=> ( parameter subject) + (||> (/.push subject) + (/.push parameter) + )))] + + ')) + (~~ (template [ ] + [(_.test (%.name (name-of )) + (bit@= ( parameter subject) + (||> (/.push subject) + (/.push parameter) + )))] + + ')) + )))))) + +(def: numerical + Test + ($_ _.and + (!numerical n.= random.nat (|>> (n.= 0) not) + [[/.n/+ n.+] [/.n/- n.-] [/.n/* n.*] [/.n// n./] [/.n/% n.%]] + [[/.n/= n.=] [/.n/< n.<] [/.n/<= n.<=] [/.n/> n.>] [/.n/>= n.>=]]) + (!numerical i.= random.int (|>> (i.= +0) not) + [[/.i/+ i.+] [/.i/- i.-] [/.i/* i.*] [/.i// i./] [/.i/% i.%]] + [[/.i/= i.=] [/.i/< i.<] [/.i/<= i.<=] [/.i/> i.>] [/.i/>= i.>=]]) + (!numerical r.= random.rev (|>> (r.= .0) not) + [[/.r/+ r.+] [/.r/- r.-] [/.r/* r.*] [/.r// r./] [/.r/% r.%]] + [[/.r/= r.=] [/.r/< r.<] [/.r/<= r.<=] [/.r/> r.>] [/.r/>= r.>=]]) + (!numerical f.= random.frac (|>> (f.= +0.0) not) + [[/.f/+ f.+] [/.f/- f.-] [/.f/* f.*] [/.f// f./] [/.f/% f.%]] + [[/.f/= f.=] [/.f/< f.<] [/.f/<= f.<=] [/.f/> f.>] [/.f/>= f.>=]]) + )) + +(def: control-flow + Test + (do random.monad + [choice random.bit + sample random.nat + start random.nat + #let [distance 10 + |inc| (/.apply/1 inc) + |test| (/.apply/1 (|>> (n.- start) (n.< distance)))]] + ($_ _.and + (_.test (%.name (name-of /.call)) + (n.= (inc sample) + (||> (/.push sample) + (/.push (/.apply/1 inc)) + /.call))) + (_.test (%.name (name-of /.if)) + (n.= (if choice + (inc sample) + (dec sample)) + (||> (/.push sample) + (/.push choice) + (/.push (/.apply/1 inc)) + (/.push (/.apply/1 dec)) + /.if))) + (_.test (%.name (name-of /.loop)) + (n.= (n.+ distance start) + (||> (/.push start) + (/.push (|>> |inc| /.dup |test|)) + /.loop))) + (_.test (%.name (name-of /.while)) + (n.= (n.+ distance start) + (||> (/.push start) + (/.push (|>> /.dup |test|)) + (/.push |inc|) + /.while))) + (_.test (%.name (name-of /.do)) + (n.= (inc sample) + (||> (/.push sample) + (/.push (|>> (/.push false))) + (/.push |inc|) + /.do /.while))) + (_.test (%.name (name-of /.compose)) + (n.= (inc (inc sample)) + (||> (/.push sample) + (/.push |inc|) + (/.push |inc|) + /.compose + /.call))) + (_.test (%.name (name-of /.curry)) + (n.= (n.+ sample sample) + (||> (/.push sample) + (/.push sample) + (/.push (/.apply/2 n.+)) + /.curry + /.call))) + (_.test (%.name (name-of /.when)) + (n.= (if choice + (inc sample) + sample) + (||> (/.push sample) + (/.push choice) + (/.push (/.apply/1 inc)) + /.when))) + (_.test (%.name (name-of /.?)) + (n.= (if choice + (inc sample) + (dec sample)) + (||> (/.push choice) + (/.push (inc sample)) + (/.push (dec sample)) + /.?))) + ))) + +(word: square + (=> [Nat] [Nat]) + + /.dup + (/.apply/2 n.*)) + +(def: definition + Test + (do random.monad + [sample random.nat] + (_.test (%.name (name-of /.word:)) + (n.= (n.* sample sample) + (||> (/.push sample) + ..square))))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..stack-shuffling + ..numerical + ..control-flow + ..definition + ))) diff --git a/stdlib/source/test/lux/control/continuation.lux b/stdlib/source/test/lux/control/continuation.lux index 105dccd3f..8d6724614 100644 --- a/stdlib/source/test/lux/control/continuation.lux +++ b/stdlib/source/test/lux/control/continuation.lux @@ -34,8 +34,8 @@ (<| (_.context (%.name (name-of /.Cont))) (do r.monad [sample r.nat - #let [(^open "_;.") /.apply - (^open "_;.") /.monad] + #let [(^open "_@.") /.apply + (^open "_@.") /.monad] elems (r.list 3 r.nat)] ($_ _.and ($functor.spec ..injection ..comparison /.functor) @@ -43,7 +43,7 @@ ($monad.spec ..injection ..comparison /.monad) (_.test "Can run continuations to compute their values." - (n.= sample (/.run (_;wrap sample)))) + (n.= sample (/.run (_@wrap sample)))) (_.test "Can use the current-continuation as a escape hatch." (n.= (n.* 2 sample) @@ -67,14 +67,14 @@ (wrap output)))))) (_.test "Can use delimited continuations with shifting." - (let [(^open "_;.") /.monad - (^open "list;.") (list.equivalence n.equivalence) + (let [(^open "_@.") /.monad + (^open "list@.") (list.equivalence n.equivalence) visit (: (-> (List Nat) (Cont (List Nat) (List Nat))) (function (visit xs) (case xs #.Nil - (_;wrap #.Nil) + (_@wrap #.Nil) (#.Cons x xs') (do /.monad @@ -83,6 +83,6 @@ [tail (k xs')] (wrap (#.Cons x tail)))))] (visit output)))))] - (list;= elems + (list@= elems (/.run (/.reset (visit elems)))))) )))) -- cgit v1.2.3