From e2621632653ad1252744eecff6da143faaf90787 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 26 Oct 2017 20:30:17 -0400 Subject: - Fixed remaining tests in compiler. - Now showing stack-traces for errors on JVM. --- new-luxc/test/test/luxc/generator/case.lux | 87 +++++----- .../test/luxc/generator/procedure/common.jvm.lux | 180 +++++++++++---------- .../test/luxc/generator/procedure/host.jvm.lux | 2 +- 3 files changed, 130 insertions(+), 139 deletions(-) (limited to 'new-luxc/test') 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] - [text "T/" Eq] - (coll ["a" array] - [list "L/" Functor] - ["S" set])) + (data ["e" error] + (coll [list])) ["r" math/random "r/" Monad] - [meta #+ Monad] - (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 [ (do-template [ ] - [(do r;Monad - [value ] - (wrap [( value) ( value)]))] + (`` ($_ r;either + (r/wrap [#ls;Unit #ls;UnitP]) + (~~ (do-template [ ] + [(do r;Monad + [value ] + (wrap [( value) ( 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]) - - (do r;Monad - [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 - [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 + [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 + [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 + (|> (do meta;Monad [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 + (|> (do meta;Monad [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] [text "text/" Eq] - [number "n/" Interval "i/" Interval "r/" Interval "d/" Interval] + [number "nat/" Interval "int/" Interval "real/" Interval "deg/" Interval] (coll ["a" array] [list])) - ["r" math/random "r/" Monad] + ["r" math/random] [meta #+ Monad] [host] test) @@ -94,8 +94,8 @@ _ false)))] - ["nat min" n/bottom] - ["nat max" n/top] + ["nat min" nat/bottom] + ["nat max" nat/top] ) (do-template [ ] [(test @@ -158,8 +158,8 @@ _ false)))] - ["int min" i/bottom] - ["int max" i/top] + ["int min" int/bottom] + ["int max" int/top] ) (do-template [ ] [(test @@ -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 [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (d.= (:! Deg valueG)) - - _ - false)))] - - ["deg min" d/bottom] - ["deg max" d/top] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure (list (#ls;Deg subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["deg to-frac" Frac deg-to-frac f.=] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Deg subject) - (#ls;Deg param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! 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 [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Deg subject) - (#ls;Nat special))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( special subject) (:! valueG)) - - _ - false)))] - - ["deg scale" d.scale Deg d.=] - ["deg reciprocal" d.reciprocal Deg d.=] - )] - ($_ seq - - - - - ))))) + subject (|> r;deg (:: @ map above-threshold))] + (`` ($_ seq + (~~ (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (d.= (:! Deg valueG)) + + _ + false)))] + + ["deg min" deg/bottom] + ["deg max" deg/top] + )) + (~~ (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure (list (#ls;Deg subject))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( subject) (:! valueG)) + + _ + false)))] + + ["deg to-frac" Frac deg-to-frac f.=] + )) + (~~ (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Deg subject) + (#ls;Deg param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( param subject) (:! 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 [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Deg subject) + (#ls;Nat special))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( special subject) (:! 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) -- cgit v1.2.3