aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/test
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/test/test/luxc/generator/case.lux87
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/common.jvm.lux180
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/host.jvm.lux2
3 files changed, 130 insertions, 139 deletions
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux
index 86319259c..34846a988 100644
--- a/new-luxc/test/test/luxc/generator/case.lux
+++ b/new-luxc/test/test/luxc/generator/case.lux
@@ -3,18 +3,10 @@
(lux [io]
(control [monad #+ do]
pipe)
- (data text/format
- [product]
- ["e" error]
- [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
- (coll ["a" array]
- [list "L/" Functor<List>]
- ["S" set]))
+ (data ["e" error]
+ (coll [list]))
["r" math/random "r/" Monad<Random>]
- [meta #+ Monad<Meta>]
- (meta [code])
- [host]
+ [meta]
test)
(luxc (lang ["ls" synthesis])
[analyser]
@@ -34,54 +26,51 @@
(def: gen-case
(r;Random [ls;Synthesis ls;Path])
(<| r;rec (function [gen-case])
- (with-expansions [<simple> (do-template [<gen> <synth> <path>]
- [(do r;Monad<Random>
- [value <gen>]
- (wrap [(<synth> value) (<path> value)]))]
+ (`` ($_ r;either
+ (r/wrap [#ls;Unit #ls;UnitP])
+ (~~ (do-template [<gen> <synth> <path>]
+ [(do r;Monad<Random>
+ [value <gen>]
+ (wrap [(<synth> value) (<path> value)]))]
- [r;bool #ls;Bool #ls;BoolP]
- [r;nat #ls;Nat #ls;NatP]
- [r;int #ls;Int #ls;IntP]
- [r;deg #ls;Deg #ls;DegP]
- [r;frac #ls;Frac #ls;FracP]
- [(r;text +5) #ls;Text #ls;TextP])]
- ($_ r;either
- (r/wrap [#ls;Unit #ls;UnitP])
- <simple>
- (do r;Monad<Random>
- [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
- idx (|> r;nat (:: @ map (n.% size)))
- [subS subP] gen-case
- #let [dummyS (list;repeat (n.dec size) #ls;Unit)
- caseS (#ls;Tuple (list;concat (list (list;take idx dummyS)
- (list subS)
- (list;drop idx dummyS))))
- caseP (#ls;TupleP (if (tail? idx idx)
- (#;Right idx)
- (#;Left idx))
- subP)]]
- (wrap [caseS caseP]))
- (do r;Monad<Random>
- [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
- idx (|> r;nat (:: @ map (n.% size)))
- [subS subP] gen-case
- #let [caseS (#ls;Variant idx (tail? idx idx) subS)
- caseP (#ls;VariantP (if (tail? idx idx)
+ [r;bool #ls;Bool #ls;BoolP]
+ [r;nat #ls;Nat #ls;NatP]
+ [r;int #ls;Int #ls;IntP]
+ [r;deg #ls;Deg #ls;DegP]
+ [r;frac #ls;Frac #ls;FracP]
+ [(r;text +5) #ls;Text #ls;TextP]))
+ (do r;Monad<Random>
+ [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+ idx (|> r;nat (:: @ map (n.% size)))
+ [subS subP] gen-case
+ #let [caseS (#ls;Tuple (list;concat (list (list;repeat idx #ls;Unit)
+ (list subS)
+ (list;repeat (|> size n.dec (n.- idx)) #ls;Unit))))
+ caseP (#ls;TupleP (if (tail? size idx)
(#;Right idx)
(#;Left idx))
subP)]]
- (wrap [caseS caseP]))
- ))))
+ (wrap [caseS caseP]))
+ (do r;Monad<Random>
+ [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+ idx (|> r;nat (:: @ map (n.% size)))
+ [subS subP] gen-case
+ #let [caseS (#ls;Variant idx (tail? idx idx) subS)
+ caseP (#ls;VariantP (if (tail? idx idx)
+ (#;Right idx)
+ (#;Left idx))
+ subP)]]
+ (wrap [caseS caseP]))
+ ))))
(context: "Pattern-matching."
- (<| (seed +17952275935008918762)
- ## (times +100)
+ (<| (times +100)
(do @
[[valueS path] gen-case
to-bind r;nat]
($_ seq
(test "Can generate pattern-matching."
- (|> (do Monad<Meta>
+ (|> (do meta;Monad<Meta>
[runtime-bytecode @runtime;generate
sampleI (@;generate valueS
(#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
@@ -94,7 +83,7 @@
_
false)))
(test "Can bind values."
- (|> (do Monad<Meta>
+ (|> (do meta;Monad<Meta>
[runtime-bytecode @runtime;generate
sampleI (@;generate (#ls;Nat to-bind)
(#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))]
diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
index 00cfd601b..dde15b19b 100644
--- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
@@ -8,10 +8,10 @@
["e" error]
[bool "bool/" Eq<Bool>]
[text "text/" Eq<Text>]
- [number "n/" Interval<Nat> "i/" Interval<Int> "r/" Interval<Frac> "d/" Interval<Deg>]
+ [number "nat/" Interval<Nat> "int/" Interval<Int> "real/" Interval<Frac> "deg/" Interval<Deg>]
(coll ["a" array]
[list]))
- ["r" math/random "r/" Monad<Random>]
+ ["r" math/random]
[meta #+ Monad<Meta>]
[host]
test)
@@ -94,8 +94,8 @@
_
false)))]
- ["nat min" n/bottom]
- ["nat max" n/top]
+ ["nat min" nat/bottom]
+ ["nat max" nat/top]
)
<unary> (do-template [<name> <type> <prepare> <comp>]
[(test <name>
@@ -158,8 +158,8 @@
_
false)))]
- ["int min" i/bottom]
- ["int max" i/top]
+ ["int min" int/bottom]
+ ["int max" int/top]
)
<unary> (do-template [<name> <type> <prepare> <comp>]
[(test <name>
@@ -254,8 +254,8 @@
_
false)))]
- ["frac min" (f.= r/bottom)]
- ["frac max" (f.= r/top)]
+ ["frac min" (f.= real/bottom)]
+ ["frac max" (f.= real/top)]
["frac not-a-number" number;not-a-number?]
["frac positive-infinity" (f.= number;positive-infinity)]
["frac negative-infinity" (f.= number;negative-infinity)]
@@ -296,87 +296,89 @@
false)))
)))))
+(def: (above-threshold value)
+ (-> Deg Deg)
+ (let [threshold .000000001 #( 1/(2^30) )#]
+ (if (d.< threshold value)
+ (d.+ threshold value)
+ value)))
+
(context: "Deg procedures"
- (<| (seed +1021167468900)
- ## (times +100)
+ (<| (times +100)
(do @
- [param (|> r;deg (r;filter (|>. (d.= .0) not)))
+ [param (|> r;deg (:: @ map above-threshold))
special r;nat
- subject r;deg]
- (with-expansions [<nullary> (do-template [<name> <reference>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (d.= <reference> (:! Deg valueG))
-
- _
- false)))]
-
- ["deg min" d/bottom]
- ["deg max" d/top]
- )
- <unary> (do-template [<name> <type> <prepare> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<prepare> subject) (:! <type> valueG))
-
- _
- false)))]
-
- ["deg to-frac" Frac deg-to-frac f.=]
- )
- <binary> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Deg subject)
- (#ls;Deg param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> param subject) (:! <outputT> valueG))
-
- _
- false)))]
-
- ["deg +" d.+ Deg d.=]
- ["deg -" d.- Deg d.=]
- ["deg *" d.* Deg d.=]
- ["deg /" d./ Deg d.=]
- ["deg %" d.% Deg d.=]
- ["deg =" d.= Bool bool/=]
- ["deg <" d.< Bool bool/=]
- )
- <special> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Deg subject)
- (#ls;Nat special))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> special subject) (:! <outputT> valueG))
-
- _
- false)))]
-
- ["deg scale" d.scale Deg d.=]
- ["deg reciprocal" d.reciprocal Deg d.=]
- )]
- ($_ seq
- <nullary>
- <unary>
- <binary>
- <special>
- )))))
+ subject (|> r;deg (:: @ map above-threshold))]
+ (`` ($_ seq
+ (~~ (do-template [<name> <reference>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (d.= <reference> (:! Deg valueG))
+
+ _
+ false)))]
+
+ ["deg min" deg/bottom]
+ ["deg max" deg/top]
+ ))
+ (~~ (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["deg to-frac" Frac deg-to-frac f.=]
+ ))
+ (~~ (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Deg subject)
+ (#ls;Deg param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["deg +" d.+ Deg d.=]
+ ["deg -" d.- Deg d.=]
+ ["deg *" d.* Deg d.=]
+ ["deg /" d./ Deg d.=]
+ ["deg %" d.% Deg d.=]
+ ["deg =" d.= Bool bool/=]
+ ["deg <" d.< Bool bool/=]
+ ))
+ (~~ (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Deg subject)
+ (#ls;Nat special))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> special subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["deg scale" d.scale Deg d.=]
+ ["deg reciprocal" d.reciprocal Deg d.=]
+ ))
+ )))))
diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
index c5aad2cae..097c2b802 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -445,7 +445,7 @@
(case> (#e;Success outputG)
(case (:! (e;Error Top) outputG)
(#e;Error error)
- (text/= exception-message error)
+ (text;contains? exception-message error)
(#e;Success outputG)
false)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 20:20:59 +0000