diff options
Diffstat (limited to 'new-luxc/test/test/luxc/lang/translation')
7 files changed, 1433 insertions, 0 deletions
diff --git a/new-luxc/test/test/luxc/lang/translation/case.lux b/new-luxc/test/test/luxc/lang/translation/case.lux new file mode 100644 index 000000000..3a8608ea7 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/case.lux @@ -0,0 +1,101 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + text/format + (coll [list])) + ["r" math/random "r/" Monad<Random>] + [meta] + (meta [code]) + test) + (luxc (lang ["ls" synthesis] + (translation ["@" case] + [";T" expression] + ["@;" eval] + ["@;" runtime] + ["@;" common]))) + (test/luxc common)) + +(def: struct-limit Nat +10) + +(def: (tail? size idx) + (-> Nat Nat Bool) + (n.= (n.dec size) idx)) + +(def: gen-case + (r;Random [ls;Synthesis ls;Path]) + (<| r;rec (function [gen-case]) + (`` ($_ r;either + (r/wrap [(' []) (' ("lux case pop"))]) + (~~ (do-template [<gen> <synth>] + [(do r;Monad<Random> + [value <gen>] + (wrap [(<synth> value) (<synth> value)]))] + + [r;bool code;bool] + [r;nat code;nat] + [r;int code;int] + [r;deg code;deg] + [r;frac code;frac] + [(r;text +5) code;text])) + (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 (` [(~@ (list;concat (list (list;repeat idx (' [])) + (list subS) + (list;repeat (|> size n.dec (n.- idx)) (' [])))))]) + caseP (if (tail? size idx) + (` ("lux case tuple right" (~ (code;nat idx)) (~ subP))) + (` ("lux case tuple left" (~ (code;nat 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 (` ((~ (code;nat idx)) (~ (code;bool (tail? size idx))) (~ subS))) + caseP (if (tail? size idx) + (` ("lux case variant right" (~ (code;nat idx)) (~ subP))) + (` ("lux case variant left" (~ (code;nat idx)) (~ subP))))]] + (wrap [caseS caseP])) + )))) + +(context: "Pattern-matching." + (<| (times +100) + (do @ + [[valueS pathS] gen-case + to-bind r;nat] + ($_ seq + (test "Can generate pattern-matching." + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (@;generate-case expressionT;generate + valueS + (` ("lux case alt" + ("lux case seq" (~ pathS) + ("lux case exec" true)) + ("lux case seq" ("lux case bind" +0) + ("lux case exec" false)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (:! Bool valueT) + + (#e;Error error) + false))) + (test "Can bind values." + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (@;generate-case expressionT;generate + (code;nat to-bind) + (` ("lux case seq" ("lux case bind" +0) + ("lux case exec" (0)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= to-bind (:! Nat valueT)) + + _ + false))))))) diff --git a/new-luxc/test/test/luxc/lang/translation/function.lux b/new-luxc/test/test/luxc/lang/translation/function.lux new file mode 100644 index 000000000..1896adff3 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/function.lux @@ -0,0 +1,99 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [product] + [maybe] + ["e" error] + (coll ["a" array] + [list "list/" Functor<List>])) + ["r" math/random "r/" Monad<Random>] + [meta] + (meta [code]) + [host] + test) + (luxc (lang ["ls" synthesis] + (translation [";T" expression] + ["@;" eval] + ["@;" runtime] + ["@;" common]))) + (test/luxc common)) + +(def: arity-limit Nat +10) + +(def: arity + (r;Random ls;Arity) + (|> r;nat (r/map (|>. (n.% arity-limit) (n.max +1))))) + +(def: gen-function + (r;Random [ls;Arity Nat ls;Synthesis]) + (do r;Monad<Random> + [arity arity + arg (|> r;nat (:: @ map (n.% arity))) + #let [functionS (` ("lux function" (~ (code;nat arity)) [] + ((~ (code;int (nat-to-int (n.inc arg)))))))]] + (wrap [arity arg functionS]))) + +(context: "Function." + (<| (times +100) + (do @ + [[arity arg functionS] gen-function + cut-off (|> r;nat (:: @ map (n.% arity))) + args (r;list arity r;nat) + #let [arg-value (maybe;assume (list;nth arg args)) + argsS (list/map code;nat args) + last-arg (n.dec arity) + cut-off (|> cut-off (n.min (n.dec last-arg)))]] + ($_ seq + (test "Can read arguments." + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` ("lux call" (~ functionS) (~@ argsS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= arg-value (:! Nat valueT)) + + (#e;Error error) + false))) + (test "Can partially apply functions." + (or (n.= +1 arity) + (|> (do meta;Monad<Meta> + [#let [partial-arity (n.inc cut-off) + preS (list;take partial-arity argsS) + postS (list;drop partial-arity argsS)] + runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` ("lux call" + ("lux call" (~ functionS) (~@ preS)) + (~@ postS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= arg-value (:! Nat valueT)) + + (#e;Error error) + false)))) + (test "Can read environment." + (or (n.= +1 arity) + (|> (do meta;Monad<Meta> + [#let [env (|> (list;n.range +0 cut-off) + (list/map (|>. n.inc nat-to-int))) + super-arity (n.inc cut-off) + arg-var (if (n.<= cut-off arg) + (|> arg n.inc nat-to-int (i.* -1)) + (|> arg n.inc (n.- super-arity) nat-to-int)) + sub-arity (|> arity (n.- super-arity)) + functionS (` ("lux function" (~ (code;nat super-arity)) [] + ("lux function" (~ (code;nat sub-arity)) [(~@ (list/map code;int env))] + ((~ (code;int arg-var))))))] + runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` ("lux call" (~ functionS) (~@ argsS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= arg-value (:! Nat valueT)) + + (#e;Error error) + false)))) + )))) diff --git a/new-luxc/test/test/luxc/lang/translation/primitive.lux b/new-luxc/test/test/luxc/lang/translation/primitive.lux new file mode 100644 index 000000000..8604ed369 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/primitive.lux @@ -0,0 +1,62 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + ["e" error] + [bool "B/" Eq<Bool>] + [text "T/" Eq<Text>]) + ["r" math/random] + [meta] + (meta [code]) + test) + (luxc [";L" host] + (lang ["ls" synthesis] + (translation [";T" expression] + ["@;" runtime] + ["@;" eval] + ["@;" common]))) + (test/luxc common)) + +(context: "Primitives." + (<| (times +100) + (do @ + [%bool% r;bool + %nat% r;nat + %int% r;int + %deg% r;deg + %frac% r;frac + %text% (r;text +5)] + (with-expansions + [<tests> (do-template [<desc> <type> <synthesis> <sample> <test>] + [(test (format "Can generate " <desc> ".") + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (<synthesis> <sample>))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> <sample> (:! <type> valueT)) + + _ + false)))] + + ["bool" Bool code;bool %bool% B/=] + ["nat" Nat code;nat %nat% n.=] + ["int" Int code;int %int% i.=] + ["deg" Deg code;deg %deg% d.=] + ["frac" Frac code;frac %frac% f.=] + ["text" Text code;text %text% T/=])] + ($_ seq + (test "Can generate unit." + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (' []))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (is hostL;unit (:! Text valueT)) + + _ + false))) + <tests> + ))))) diff --git a/new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux new file mode 100644 index 000000000..8c44007d0 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/procedure/common.jvm.lux @@ -0,0 +1,367 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + [bit] + ["e" error] + [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] + [number "nat/" Interval<Nat> "int/" Interval<Int> "real/" Interval<Frac> "deg/" Interval<Deg>] + (coll ["a" array] + [list])) + ["r" math/random] + [meta] + (meta [code]) + [host] + test) + (luxc (lang ["ls" synthesis] + (translation [";T" expression] + ["@;" eval] + ["@;" runtime] + ["@;" common]))) + (test/luxc common)) + +(context: "Bit procedures" + (<| (times +100) + (do @ + [param r;nat + subject r;nat] + (with-expansions [<binary> (do-template [<name> <reference>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name> (~ (code;nat subject)) + (~ (code;nat param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= (<reference> param subject) (:! Nat valueT)) + + _ + false)))] + + ["bit and" bit;and] + ["bit or" bit;or] + ["bit xor" bit;xor] + ["bit shift-left" bit;shift-left] + ["bit unsigned-shift-right" bit;shift-right] + )] + ($_ seq + (test "bit count" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("bit count" (~ (code;nat subject)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= (bit;count subject) (:! Nat valueT)) + + _ + false))) + + <binary> + (test "bit shift-right" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("bit shift-right" + (~ (code;int (nat-to-int subject))) + (~ (code;nat param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (i.= (bit;signed-shift-right param (nat-to-int subject)) + (:! Int valueT)) + + _ + false))) + ))))) + +(context: "Nat procedures" + (<| (times +100) + (do @ + [param (|> r;nat (r;filter (|>. (n.= +0) not))) + subject r;nat] + (`` ($_ seq + (~~ (do-template [<name> <reference>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name>)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= <reference> (:! Nat valueT)) + + _ + false)))] + + ["nat min" nat/bottom] + ["nat max" nat/top] + )) + (~~ (do-template [<name> <type> <prepare> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name> (~ (code;nat subject)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<prepare> subject) (:! <type> valueT)) + + _ + false)))] + + ["nat to-int" Int nat-to-int i.=] + ["nat to-char" Text text;from-code text/=] + )) + (~~ (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;nat subject)) (~ (code;nat param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["nat +" n.+ Nat n.=] + ["nat -" n.- Nat n.=] + ["nat *" n.* Nat n.=] + ["nat /" n./ Nat n.=] + ["nat %" n.% Nat n.=] + ["nat =" n.= Bool bool/=] + ["nat <" n.< Bool bool/=] + )) + ))))) + +(context: "Int procedures" + (<| (times +100) + (do @ + [param (|> r;int (r;filter (|>. (i.= 0) not))) + subject r;int] + (with-expansions [<nullary> (do-template [<name> <reference>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name>)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (i.= <reference> (:! Int valueT)) + + _ + false)))] + + ["int min" int/bottom] + ["int max" int/top] + ) + <unary> (do-template [<name> <type> <prepare> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name> (~ (code;int subject)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<prepare> subject) (:! <type> valueT)) + + _ + false)))] + + ["int to-nat" Nat int-to-nat n.=] + ["int to-frac" Frac int-to-frac f.=] + ) + <binary> (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;int subject)) (~ (code;int param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["int +" i.+ Int i.=] + ["int -" i.- Int i.=] + ["int *" i.* Int i.=] + ["int /" i./ Int i.=] + ["int %" i.% Int i.=] + ["int =" i.= Bool bool/=] + ["int <" i.< Bool bool/=] + )] + ($_ seq + <nullary> + <unary> + <binary> + ))))) + +(context: "Frac procedures [Part 1]" + (<| (times +100) + (do @ + [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) + subject r;frac] + (with-expansions [<binary> (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;frac subject)) (~ (code;frac param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + false)))] + + ["frac +" f.+ Frac f.=] + ["frac -" f.- Frac f.=] + ["frac *" f.* Frac f.=] + ["frac /" f./ Frac f.=] + ["frac %" f.% Frac f.=] + ["frac =" f.= Bool bool/=] + ["frac <" f.< Bool bool/=] + )] + ($_ seq + <binary> + ))))) + +(context: "Frac procedures [Part 2]" + (<| (times +100) + (do @ + [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) + subject r;frac] + (with-expansions [<nullary> (do-template [<name> <test>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name>)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> (:! Frac valueT)) + + _ + false)))] + + ["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)] + ["frac smallest" (f.= (_lux_proc [ "frac" "smallest-value"] []))] + ) + <unary> (do-template [<name> <type> <prepare> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;frac subject)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<prepare> subject) (:! <type> valueT)) + + _ + false)))] + + ["frac to-int" Int frac-to-int i.=] + ["frac to-deg" Deg frac-to-deg d.=] + )] + ($_ seq + <nullary> + <unary> + (test "frac encode|decode" + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` ("frac decode" ("frac encode" (~ (code;frac subject))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success valueT) + [(:! (Maybe Frac) valueT) (#;Some value)]) + (f.= subject value) + + _ + false))) + ))))) + +(def: (above-threshold value) + (-> Deg Deg) + (let [threshold .000000001 #( 1/(2^30) )#] + (if (d.< threshold value) + (d.+ threshold value) + value))) + +(context: "Deg procedures" + (<| (times +100) + (do @ + [param (|> r;deg (:: @ map above-threshold)) + special r;nat + subject (|> r;deg (:: @ map above-threshold))] + (`` ($_ seq + (~~ (do-template [<name> <reference>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<name>)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (d.= <reference> (:! Deg valueT)) + + _ + false)))] + + ["deg min" deg/bottom] + ["deg max" deg/top] + )) + (~~ (do-template [<name> <type> <prepare> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;deg subject)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<prepare> subject) (:! <type> valueT)) + + _ + false)))] + + ["deg to-frac" Frac deg-to-frac f.=] + )) + (~~ (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;deg subject)) (~ (code;deg param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<reference> param subject) (:! <outputT> valueT)) + + _ + 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 meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` (<name> (~ (code;deg subject)) (~ (code;nat special)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<comp> (<reference> special subject) (:! <outputT> valueT)) + + _ + false)))] + + ["deg scale" d.scale Deg d.=] + ["deg reciprocal" d.reciprocal Deg d.=] + )) + ))))) diff --git a/new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux new file mode 100644 index 000000000..35453c44b --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/procedure/host.jvm.lux @@ -0,0 +1,614 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [maybe] + ["e" error] + [bit] + [bool "bool/" Eq<Bool>] + [number "int/" Number<Int> Codec<Text,Int>] + [text "text/" Eq<Text>] + text/format + (coll [list])) + ["r" math/random "r/" Monad<Random>] + [meta] + (meta [code]) + [host] + test) + (luxc [";L" host] + (lang ["ls" synthesis] + (translation [";T" expression] + ["@;" eval] + ["@;" runtime] + ["@;" common]))) + (test/luxc common)) + +(context: "Conversions [Part 1]" + (<| (times +100) + (do @ + [int-sample (|> r;int (:: @ map (i.% 128))) + #let [frac-sample (int-to-frac int-sample)]] + (with-expansions [<2step> (do-template [<step1> <step2> <tag> <sample> <cast> <test>] + [(test (format <step1> " / " <step2>) + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (|> (~ (<tag> <sample>)) <step1> <step2> (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> <sample> (:! <cast> valueT)) + + (#e;Error error) + false)))] + + ["jvm convert double-to-float" "jvm convert float-to-double" code;frac frac-sample Frac f.=] + ["jvm convert double-to-int" "jvm convert int-to-double" code;frac frac-sample Frac f.=] + ["jvm convert double-to-long" "jvm convert long-to-double" code;frac frac-sample Frac f.=] + + ["jvm convert long-to-float" "jvm convert float-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] + )] + ($_ seq + <2step> + ))))) + +(context: "Conversions [Part 2]" + (<| (times +100) + (do @ + [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) + #let [frac-sample (int-to-frac int-sample)]] + (`` ($_ seq + (~~ (do-template [<step1> <step2> <step3> <tag> <sample> <cast> <test>] + [(test (format <step1> " / " <step2> " / " <step3>) + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (|> (~ (<tag> <sample>)) <step1> <step2> <step3> (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> <sample> (:! <cast> valueT)) + + (#e;Error error) + false)))] + + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-float" "jvm convert float-to-long" code;int int-sample Int i.=] + )) + ))))) + +(context: "Conversions [Part 3]" + (<| (times +100) + (do @ + [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) + #let [frac-sample (int-to-frac int-sample)]] + (`` ($_ seq + (~~ (do-template [<step1> <step2> <step3> <step4> <tag> <sample> <cast> <test>] + [(test (format <step1> " / " <step2> " / " <step3>) + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (|> (~ (<tag> <sample>)) <step1> <step2> <step3> <step4> (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> <sample> (:! <cast> valueT)) + + (#e;Error error) + false)))] + + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] + )) + ))))) + +(def: gen-nat + (r;Random Nat) + (|> r;nat + (r/map (n.% +128)) + (r;filter (|>. (n.= +0) not)))) + +(def: gen-int + (r;Random Int) + (|> gen-nat (r/map nat-to-int))) + +(def: gen-frac + (r;Random Frac) + (|> gen-int (r/map int-to-frac))) + +(do-template [<domain> <generator> <tag> <type> <test> <augmentation> <+> <-> <*> </> <%> <pre> <post>] + [(context: (format "Arithmetic [" <domain> "]") + (<| (times +100) + (do @ + [param <generator> + #let [subject (<augmentation> param)]] + (with-expansions [<tests> (do-template [<procedure> <reference>] + [(test <procedure> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<post> ((~ (code;text <procedure>)) + (<pre> (~ (<tag> subject))) + (<pre> (~ (<tag> param)))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> (<reference> param subject) + (:! <type> valueT)) + + (#e;Error error) + false)))] + + [(format "jvm " <domain> " +") <+>] + [(format "jvm " <domain> " -") <->] + [(format "jvm " <domain> " *") <*>] + [(format "jvm " <domain> " /") </>] + [(format "jvm " <domain> " %") <%>] + )] + ($_ seq + <tests> + )))))] + + ["int" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "jvm convert long-to-int" "jvm convert int-to-long"] + ["long" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "lux noop" "lux noop"] + ["float" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "jvm convert double-to-float" "jvm convert float-to-double"] + ["double" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "lux noop" "lux noop"] + ) + +(do-template [<domain> <post> <convert>] + [(context: (format "Bit-wise [" <domain> "] { Combiners ]") + (<| (times +100) + (do @ + [param gen-nat + subject gen-nat] + (`` ($_ seq + (~~ (do-template [<procedure> <reference>] + [(test <procedure> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<post> ((~ (code;text <procedure>)) + (<convert> (~ (code;nat subject))) + (<convert> (~ (code;nat param)))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (n.= (<reference> param subject) + (:! Nat valueT)) + + (#e;Error error) + false)))] + + [(format "jvm " <domain> " and") bit;and] + [(format "jvm " <domain> " or") bit;or] + [(format "jvm " <domain> " xor") bit;xor] + )) + )))))] + + ["int" "jvm convert int-to-long" "jvm convert long-to-int"] + ["long" "lux noop" "lux noop"] + ) + +(do-template [<domain> <post> <convert>] + [(context: (format "Bit-wise [" <domain> "] { Shifters }") + (<| (times +100) + (do @ + [param gen-nat + subject gen-nat + #let [shift (n.% +10 param)]] + (`` ($_ seq + (~~ (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>] + [(test <procedure> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` (<post> ((~ (code;text <procedure>)) + (<convert> (~ (<pre> subject))) + ("jvm convert long-to-int" (~ (code;nat shift)))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (<test> (<reference> shift (<pre-subject> subject)) + (:! <type> valueT)) + + (#e;Error error) + false)))] + + [(format "jvm " <domain> " shl") bit;shift-left Nat n.= id code;nat] + [(format "jvm " <domain> " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int code;int)] + [(format "jvm " <domain> " ushr") bit;shift-right Nat n.= id code;nat] + )) + )))))] + + ["int" "jvm convert int-to-long" "jvm convert long-to-int"] + ["long" "lux noop" "lux noop"] + ) + +(do-template [<domain> <generator> <tag> <=> <<> <pre>] + [(context: (format "Order [" <domain> "]") + (<| (times +100) + (do @ + [param <generator> + subject <generator>] + (with-expansions [<tests> (do-template [<procedure> <reference>] + [(test <procedure> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ((~ (code;text <procedure>)) + (<pre> (~ (<tag> subject))) + (<pre> (~ (<tag> param))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (bool/= (<reference> param subject) + (:! Bool valueT)) + + (#e;Error error) + false)))] + + [(format "jvm " <domain> " =") <=>] + [(format "jvm " <domain> " <") <<>] + )] + ($_ seq + <tests> + )))))] + + ["int" gen-int code;int i.= i.< "jvm convert long-to-int"] + ["long" gen-int code;int i.= i.< "lux noop"] + ["float" gen-frac code;frac f.= f.< "jvm convert double-to-float"] + ["double" gen-frac code;frac f.= f.< "lux noop"] + ["char" gen-int code;int i.= i.< "jvm convert long-to-char"] + ) + +(def: (jvm//array//new dimension class size) + (-> Nat Text Nat ls;Synthesis) + (` ("jvm array new" (~ (code;nat dimension)) (~ (code;text class)) (~ (code;nat size))))) + +(def: (jvm//array//write class idx inputS arrayS) + (-> Text Nat ls;Synthesis ls;Synthesis ls;Synthesis) + (` ("jvm array write" (~ (code;text class)) (~ (code;nat idx)) (~ inputS) (~ arrayS)))) + +(def: (jvm//array//read class idx arrayS) + (-> Text Nat ls;Synthesis ls;Synthesis) + (` ("jvm array read" (~ (code;text class)) (~ (code;nat idx)) (~ arrayS)))) + +(context: "Array [Part 1]" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1)))) + idx (|> r;nat (:: @ map (n.% size))) + valueZ r;bool + valueB gen-int + valueS gen-int + valueI gen-int + valueL r;int + valueF gen-frac + valueD r;frac + valueC gen-int] + (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>] + [(test <class> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (|> (jvm//array//new +0 <class> size) + (jvm//array//write <class> idx <input>) + (jvm//array//read <class> idx) + (~) + <post> + (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputZ) + (<test> <value> (:! <type> outputZ)) + + (#e;Error error) + false)))] + + ["boolean" Bool valueZ bool/= (code;bool valueZ) + "lux noop"] + ["byte" Int valueB i.= (|> (code;int valueB) (~) "jvm convert long-to-byte" (`)) + "jvm convert byte-to-long"] + ["short" Int valueS i.= (|> (code;int valueS) (~) "jvm convert long-to-short" (`)) + "jvm convert short-to-long"] + ["int" Int valueI i.= (|> (code;int valueI) (~) "jvm convert long-to-int" (`)) + "jvm convert int-to-long"] + ["long" Int valueL i.= (code;int valueL) + "lux noop"] + ["float" Frac valueF f.= (|> (code;frac valueF) (~) "jvm convert double-to-float" (`)) + "jvm convert float-to-double"] + ["double" Frac valueD f.= (code;frac valueD) + "lux noop"] + )] + ($_ seq + <array> + ))))) + +(context: "Array [Part 2]" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1)))) + idx (|> r;nat (:: @ map (n.% size))) + valueZ r;bool + valueB gen-int + valueS gen-int + valueI gen-int + valueL r;int + valueF gen-frac + valueD r;frac + valueC gen-int] + (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>] + [(test <class> + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (|> (jvm//array//new +0 <class> size) + (jvm//array//write <class> idx <input>) + (jvm//array//read <class> idx) + (~) + <post> + (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (<test> <value> (:! <type> outputT)) + + (#e;Error error) + false)))] + + ["char" Int valueC i.= + (|> (code;int valueC) (~) "jvm convert long-to-int" "jvm convert int-to-char" (`)) + "jvm convert char-to-long"] + ["java.lang.Long" Int valueL i.= + (code;int valueL) + "lux noop"] + )] + ($_ seq + <array> + (test "java.lang.Double (level 1)" + (|> (do meta;Monad<Meta> + [#let [inner (|> ("jvm array new" +0 "java.lang.Double" (~ (code;nat size))) + ("jvm array write" "java.lang.Double" (~ (code;nat idx)) (~ (code;frac valueD))) + (`))] + sampleI (expressionT;generate (|> ("jvm array new" +1 "java.lang.Double" (~ (code;nat size))) + ("jvm array write" "#Array" (~ (code;nat idx)) (~ inner)) + ("jvm array read" "#Array" (~ (code;nat idx))) + ("jvm array read" "java.lang.Double" (~ (code;nat idx))) + (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (f.= valueD (:! Frac outputT)) + + (#e;Error error) + false))) + (test "jvm array length" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm array length" ("jvm array new" +0 "java.lang.Object" (~ (code;nat size))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (n.= size (:! Nat outputT)) + + (#e;Error error) + false))) + ))))) + +(host;import java.lang.Class + (getName [] String)) + +(def: classes + (List Text) + (list "java.lang.Object" "java.lang.Class" + "java.lang.String" "java.lang.Number")) + +(def: instances + (List [Text (r;Random ls;Synthesis)]) + (let [gen-boolean (|> r;bool (:: r;Functor<Random> map code;bool)) + gen-integer (|> r;int (:: r;Functor<Random> map code;int)) + gen-double (|> r;frac (:: r;Functor<Random> map code;frac)) + gen-string (|> (r;text +5) (:: r;Functor<Random> map code;text))] + (list ["java.lang.Boolean" gen-boolean] + ["java.lang.Long" gen-integer] + ["java.lang.Double" gen-double] + ["java.lang.String" gen-string] + ["java.lang.Object" (r;either (r;either gen-boolean + gen-integer) + (r;either gen-double + gen-string))]))) + +(context: "Object." + (<| (times +100) + (do @ + [#let [num-classes (list;size classes)] + #let [num-instances (list;size instances)] + class-idx (|> r;nat (:: @ map (n.% num-classes))) + instance-idx (|> r;nat (:: @ map (n.% num-instances))) + exception-message (r;text +5) + #let [class (maybe;assume (list;nth class-idx classes)) + [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances)) + exception-message$ (` ["java.lang.String" (~ (code;text exception-message))])] + sample r;int + monitor r;int + instance instance-gen] + ($_ seq + (test "jvm object null" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm object null?" ("jvm object null"))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (:! Bool outputT) + + (#e;Error error) + false))) + (test "jvm object null?" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm object null?" (~ (code;int sample)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (not (:! Bool outputT)) + + (#e;Error error) + false))) + (test "jvm object synchronized" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm object synchronized" (~ (code;int monitor)) (~ (code;int sample)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (i.= sample (:! Int outputT)) + + (#e;Error error) + false))) + (test "jvm object throw" + (|> (do meta;Monad<Meta> + [_ @runtime;generate + sampleI (expressionT;generate (` ("lux try" ("lux function" +1 [] + ("jvm object throw" ("jvm member invoke constructor" + "java.lang.Throwable" + (~ exception-message$)))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (case (:! (e;Error Top) outputT) + (#e;Error error) + (text;contains? exception-message error) + + (#e;Success outputT) + false) + + (#e;Error error) + false))) + (test "jvm object class" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm object class" (~ (code;text class)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (|> outputT (:! Class) (Class.getName []) (text/= class)) + + (#e;Error error) + false))) + (test "jvm object instance?" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm object instance?" (~ (code;text instance-class)) (~ instance))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (:! Bool outputT) + + (#e;Error error) + false))) + )))) + +(host;import java.util.GregorianCalendar + (#static AD int)) + +(context: "Member [Field]" + (<| (times +100) + (do @ + [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100)))) + sample-string (r;text +5) + other-sample-string (r;text +5) + #let [shortS (` ["short" ("jvm convert long-to-short" (~ (code;int sample-short)))]) + stringS (` ["java.lang.String" (~ (code;text sample-string))]) + type-codeS (` ["org.omg.CORBA.TypeCode" ("jvm object null")]) + idl-typeS (` ["org.omg.CORBA.IDLType" ("jvm object null")]) + value-memberS (` ("jvm member invoke constructor" + "org.omg.CORBA.ValueMember" + (~ stringS) (~ stringS) (~ stringS) (~ stringS) + (~ type-codeS) (~ idl-typeS) (~ shortS)))]] + ($_ seq + (test "jvm member static get" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm convert int-to-long" ("jvm member static get" "java.util.GregorianCalendar" "AD" "int"))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (i.= GregorianCalendar.AD (:! Int outputT)) + + (#e;Error error) + false))) + (test "jvm member static put" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm member static put" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor" + ("jvm member static get" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor"))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (is hostL;unit (:! Text outputT)) + + (#e;Error error) + false))) + (test "jvm member virtual get" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String" (~ value-memberS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (text/= sample-string (:! Text outputT)) + + (#e;Error error) + false))) + (test "jvm member virtual put" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String" + ("jvm member virtual put" "org.omg.CORBA.ValueMember" "name" "java.lang.String" + (~ (code;text other-sample-string)) (~ value-memberS)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (text/= other-sample-string (:! Text outputT)) + + (#e;Error error) + false))) + )))) + +(host;import java.lang.Object) + +(host;import (java.util.ArrayList a)) + +(context: "Member [Method]" + (<| (times +100) + (do @ + [sample (|> r;int (:: @ map (|>. int/abs (i.% 100)))) + #let [object-longS (` ["java.lang.Object" (~ (code;int sample))]) + intS (` ["int" ("jvm convert long-to-int" (~ (code;int sample)))]) + coded-intS (` ["java.lang.String" (~ (code;text (int/encode sample)))]) + array-listS (` ("jvm member invoke constructor" "java.util.ArrayList" (~ intS)))]] + ($_ seq + (test "jvm member invoke static" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm member invoke static" "java.lang.Long" "decode" "java.lang.Long" (~ coded-intS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (i.= sample (:! Int outputT)) + + (#e;Error error) + false))) + (test "jvm member invoke virtual" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean" + (~ (code;int sample)) (~ object-longS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (:! Bool outputT) + + (#e;Error error) + false))) + (test "jvm member invoke interface" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (` ("jvm member invoke interface" "java.util.Collection" "add" "boolean" + (~ array-listS) (~ object-longS))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (:! Bool outputT) + + (#e;Error error) + false))) + (test "jvm member invoke constructor" + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate array-listS)] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (host;instance? ArrayList (:! Object outputT)) + + (#e;Error error) + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/translation/reference.lux b/new-luxc/test/test/luxc/lang/translation/reference.lux new file mode 100644 index 000000000..0bc2bb325 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/reference.lux @@ -0,0 +1,80 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [text]) + ["r" math/random] + [meta] + (meta [code]) + test) + (luxc (host ["$" jvm] + (jvm ["$i" inst])) + (lang ["ls" synthesis] + (translation [";T" statement] + [";T" eval] + [";T" expression] + [";T" case] + [";T" runtime])) + ["_;" module]) + (test/luxc common)) + +(def: nilI $;Inst runtimeT;noneI) + +(def: cursorI + $;Inst + (|>. ($i;int 3) + ($i;array runtimeT;$Tuple) + $i;DUP ($i;int 0) ($i;string "") $i;AASTORE + $i;DUP ($i;int 1) ($i;long 0) ($i;wrap #$;Long) $i;AASTORE + $i;DUP ($i;int 2) ($i;long 0) ($i;wrap #$;Long) $i;AASTORE)) + +(def: empty-metaI + (|>. ($i;int 2) + ($i;array runtimeT;$Tuple) + $i;DUP ($i;int 0) cursorI $i;AASTORE + $i;DUP ($i;int 1) nilI $i;AASTORE)) + +(context: "Definitions." + (<| (times +100) + (do @ + [module-name (|> (r;text +5) (r;filter (|>. (text;contains? "/") not))) + def-name (r;text +5) + def-value r;int + #let [valueI (|>. ($i;long def-value) ($i;wrap #$;Long))]] + ($_ seq + (test "Can refer to definitions." + (|> (do meta;Monad<Meta> + [_ (_module;with-module +0 module-name + (statementT;generate-def def-name Int valueI empty-metaI (' {}))) + sampleI (expressionT;generate (code;symbol [module-name def-name]))] + (evalT;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (i.= def-value (:! Int valueT)) + + (#e;Error error) + false))) + )))) + +(context: "Variables." + (<| (times +100) + (do @ + [register (|> r;nat (:: @ map (n.% +100))) + value r;int] + ($_ seq + (test "Can refer to local variables/registers." + (|> (do meta;Monad<Meta> + [sampleI (caseT;generate-let expressionT;generate + register + (code;int value) + (` ((~ (code;int (nat-to-int register))))))] + (evalT;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputT) + (i.= value (:! Int outputT)) + + (#e;Error error) + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/translation/structure.lux b/new-luxc/test/test/luxc/lang/translation/structure.lux new file mode 100644 index 000000000..a8f74ec6a --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/structure.lux @@ -0,0 +1,110 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] + text/format + (coll [array] + [list])) + ["r" math/random "r/" Monad<Random>] + [meta] + (meta [code]) + [host] + test) + (luxc [";L" host] + (lang ["ls" synthesis] + (translation [";T" expression] + ["@;" eval] + ["@;" runtime] + ["@;" common]))) + (test/luxc common)) + +(host;import java.lang.Integer) + +(def: gen-primitive + (r;Random ls;Synthesis) + (r;either (r;either (r;either (r/wrap (' [])) + (r/map code;bool r;bool)) + (r;either (r/map code;nat r;nat) + (r/map code;int r;int))) + (r;either (r;either (r/map code;deg r;deg) + (r/map code;frac r;frac)) + (r/map code;text (r;text +5))))) + +(def: (corresponds? [prediction sample]) + (-> [ls;Synthesis Top] Bool) + (case prediction + [_ (#;Tuple #;Nil)] + (is hostL;unit (:! Text sample)) + + (^template [<tag> <type> <test>] + [_ (<tag> prediction')] + (case (host;try (<test> prediction' (:! <type> sample))) + (#e;Success result) + result + + (#e;Error error) + false)) + ([#;Bool Bool bool/=] + [#;Nat Nat n.=] + [#;Int Int i.=] + [#;Deg Deg d.=] + [#;Frac Frac f.=] + [#;Text Text text/=]) + + _ + false + )) + +(context: "Tuples." + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + members (r;list size gen-primitive)] + (test "Can generate tuple." + (|> (do meta;Monad<Meta> + [sampleI (expressionT;generate (code;tuple members))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (let [valueT (:! (Array Top) valueT)] + (and (n.= size (array;size valueT)) + (list;every? corresponds? (list;zip2 members (array;to-list valueT))))) + + _ + false)))))) + +(context: "Variants." + (<| (times +100) + (do @ + [num-tags (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tag (|> r;nat (:: @ map (n.% num-tags))) + #let [last? (n.= (n.dec num-tags) tag)] + member gen-primitive] + (test "Can generate variant." + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (expressionT;generate (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ member))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueT) + (let [valueT (:! (Array Top) valueT)] + (and (n.= +3 (array;size valueT)) + (let [_tag (:! Integer (maybe;assume (array;read +0 valueT))) + _last? (array;read +1 valueT) + _value (:! Top (maybe;assume (array;read +2 valueT)))] + (and (n.= tag (|> _tag host;i2l int-to-nat)) + (case _last? + (#;Some _last?') + (and last? (text/= "" (:! Text _last?'))) + + #;None + (not last?)) + (corresponds? [member _value]))))) + + _ + false)))))) |