From 0bc56fdc626ee601ca2c4ba0502f76e76d765fa0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 21 Oct 2017 00:38:55 -0400 Subject: - Updated new compiler to latest version of stdlib. --- new-luxc/source/luxc/analyser/inference.lux | 4 +- .../source/luxc/analyser/procedure/host.jvm.lux | 38 +- new-luxc/source/luxc/module/descriptor/type.lux | 10 +- new-luxc/test/test/luxc/analyser/case.lux | 190 ++--- new-luxc/test/test/luxc/analyser/function.lux | 178 ++--- new-luxc/test/test/luxc/analyser/primitive.lux | 58 +- .../test/test/luxc/analyser/procedure/common.lux | 674 +++++++++-------- .../test/test/luxc/analyser/procedure/host.jvm.lux | 244 +++--- new-luxc/test/test/luxc/analyser/reference.lux | 58 +- new-luxc/test/test/luxc/analyser/structure.lux | 514 ++++++------- new-luxc/test/test/luxc/analyser/type.lux | 78 +- new-luxc/test/test/luxc/generator/case.lux | 56 +- new-luxc/test/test/luxc/generator/function.lux | 110 +-- new-luxc/test/test/luxc/generator/primitive.lux | 72 +- .../test/luxc/generator/procedure/common.jvm.lux | 678 ++++++++--------- .../test/luxc/generator/procedure/host.jvm.lux | 828 +++++++++++---------- new-luxc/test/test/luxc/generator/structure.lux | 80 +- new-luxc/test/test/luxc/parser.lux | 214 +++--- .../test/test/luxc/synthesizer/case/special.lux | 88 ++- new-luxc/test/test/luxc/synthesizer/function.lux | 96 +-- new-luxc/test/test/luxc/synthesizer/loop.lux | 54 +- new-luxc/test/test/luxc/synthesizer/primitive.lux | 48 +- new-luxc/test/test/luxc/synthesizer/procedure.lux | 30 +- new-luxc/test/test/luxc/synthesizer/structure.lux | 56 +- 24 files changed, 2287 insertions(+), 2169 deletions(-) (limited to 'new-luxc') diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux index edb90e73d..86832ae9e 100644 --- a/new-luxc/source/luxc/analyser/inference.lux +++ b/new-luxc/source/luxc/analyser/inference.lux @@ -22,8 +22,8 @@ (def: #export (replace-var var-id bound-idx type) (-> Nat Nat Type Type) (case type - (#;Host name params) - (#;Host name (L/map (replace-var var-id bound-idx) params)) + (#;Primitive name params) + (#;Primitive name (L/map (replace-var var-id bound-idx) params)) (^template [] ( left right) diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index 63931c6f2..e45e7d807 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -30,7 +30,7 @@ (def: #export null-class Text "#Null") (do-template [ ] - [(def: #export Type (#;Host (list)))] + [(def: #export Type (#;Primitive (list)))] ## Boxes [Boolean "java.lang.Boolean"] @@ -186,10 +186,10 @@ #;None (&;fail (invalid-array-type expectedT))) - (^ (#;Host "#Array" (list elemT))) + (^ (#;Primitive "#Array" (list elemT))) (recur elemT (n.inc level)) - (#;Host class _) + (#;Primitive class _) (wrap [level class]) _ @@ -206,7 +206,7 @@ (def: (check-jvm objectT) (-> Type (Meta Text)) (case objectT - (#;Host name _) + (#;Primitive name _) (meta/wrap name) (#;Named name unnamed) @@ -245,13 +245,13 @@ (do meta;Monad [] (case elemT - (#;Host name #;Nil) + (#;Primitive name #;Nil) (let [boxed-name (|> (dict;get name boxes) (maybe;default name))] - (wrap [(#;Host boxed-name #;Nil) + (wrap [(#;Primitive boxed-name #;Nil) boxed-name])) - (#;Host name _) + (#;Primitive name _) (if (dict;contains? name boxes) (&;fail (format "Primitives cannot be parameterized: " name)) (:: meta;Monad wrap [elemT name])) @@ -479,7 +479,7 @@ [_ (#;Text class)] (do meta;Monad [_ (load-class class) - _ (&;infer (#;Host "java.lang.Class" (list (#;Host class (list)))))] + _ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))] (wrap (#la;Procedure proc (list (#la;Text class))))) _ @@ -586,13 +586,13 @@ class-name (Class.getName [] java-type)] (meta/wrap (case (array;size (Class.getTypeParameters [] java-type)) +0 - (#;Host class-name (list)) + (#;Primitive class-name (list)) arity (|> (list;n.range +0 (n.dec arity)) list;reverse (list/map (|>. (n.* +2) n.inc #;Bound)) - (#;Host class-name) + (#;Primitive class-name) (type;univ-q arity))))) (host;instance? ParameterizedType java-type) @@ -604,8 +604,8 @@ (ParameterizedType.getActualTypeArguments []) array;to-list (monad;map @ (java-type-to-lux-type mappings)))] - (meta/wrap (#;Host (Class.getName [] (:! (Class Object) raw)) - paramsT))) + (meta/wrap (#;Primitive (Class.getName [] (:! (Class Object) raw)) + paramsT))) (&;throw JVM-Type-Is-Not-Class (type-descriptor raw)))) (host;instance? GenericArrayType java-type) @@ -613,7 +613,7 @@ [innerT (|> (:! GenericArrayType java-type) (GenericArrayType.getGenericComponentType []) (java-type-to-lux-type mappings))] - (wrap (#;Host "#Array" (list innerT)))) + (wrap (#;Primitive "#Array" (list innerT)))) ## else (&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type)))) @@ -631,7 +631,7 @@ (def: (correspond-type-params class type) (-> (Class Object) Type (Meta Mappings)) (case type - (#;Host name params) + (#;Primitive name params) (let [class-name (Class.getName [] class) class-params (array;to-list (Class.getTypeParameters [] class))] (if (text/= class-name name) @@ -654,13 +654,13 @@ (cond (dict;contains? to-name boxes) (let [box (maybe;assume (dict;get to-name boxes))] (if (text/= box from-name) - (wrap [(choose direction to-name from-name) (#;Host to-name (list))]) + (wrap [(choose direction to-name from-name) (#;Primitive to-name (list))]) (&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name)))) (dict;contains? from-name boxes) (let [box (maybe;assume (dict;get from-name boxes))] (do @ - [[_ castT] (cast direction to (#;Host box (list)))] + [[_ castT] (cast direction to (#;Primitive box (list)))] (wrap [(choose direction to-name from-name) castT]))) (text/= to-name from-name) @@ -748,7 +748,7 @@ (list/map (TypeVariable.getName [])))] mappings (: (Meta Mappings) (case objectT - (#;Host _class-name _class-params) + (#;Primitive _class-name _class-params) (do @ [#let [num-params (list;size _class-params) num-vars (list;size var-names)] @@ -998,7 +998,7 @@ inputsT _ - (list& (#;Host owner-name (list;reverse owner-tvarsT)) + (list& (#;Primitive owner-name (list;reverse owner-tvarsT)) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) @@ -1056,7 +1056,7 @@ exceptionsT (|> (Constructor.getGenericExceptionTypes [] constructor) array;to-list (monad;map @ (java-type-to-lux-type mappings))) - #let [objectT (#;Host owner-name (list;reverse owner-tvarsT)) + #let [objectT (#;Primitive owner-name (list;reverse owner-tvarsT)) constructorT (<| (type;univ-q num-all-tvars) (type;function inputsT) objectT)]] diff --git a/new-luxc/source/luxc/module/descriptor/type.lux b/new-luxc/source/luxc/module/descriptor/type.lux index 6c5501e54..2f5b8667b 100644 --- a/new-luxc/source/luxc/module/descriptor/type.lux +++ b/new-luxc/source/luxc/module/descriptor/type.lux @@ -15,7 +15,7 @@ [(def: &;Signal )] [type-signal "T"] - [host-signal "^"] + [primitive-signal "^"] [void-signal "0"] [unit-signal "1"] [product-signal "*"] @@ -36,8 +36,8 @@ (type/= Type type)) type-signal (case type - (#;Host name params) - (format host-signal name &;stop-signal (&;encode-list encode-type params)) + (#;Primitive name params) + (format primitive-signal name &;stop-signal (&;encode-list encode-type params)) #;Void void-signal @@ -115,11 +115,11 @@ [#;Var var-signal])] ($_ l;either (do l;Monad - [_ (l;text host-signal) + [_ (l;text primitive-signal) name (l;many' (l;none-of &;stop-signal)) _ (l;text &;stop-signal) params (&;decode-list type-decoder)] - (wrap (#;Host name params))) + (wrap (#;Primitive name params))) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index e19ac3a0a..27cc9f6ae 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -129,97 +129,99 @@ (context: "Pattern-matching." ## #seed +9253409297339902486 ## #seed +3793366152923578600 - #seed +5004137551292836565 - [module-name (r;text +5) - variant-name (r;text +5) - record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) - size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - variant-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - record-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - primitivesTC (r;list size gen-primitive) - #let [primitivesT (L/map product;left primitivesTC) - primitivesC (L/map product;right primitivesTC) - variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) - record-tags+ (L/map (|>. [module-name] code;tag) record-tags) - variantTC (list;zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] gen-primitive - [heterogeneousT heterogeneousC] (|> gen-primitive - (r;filter (|>. product;left (tc;checks? outputT) not))) - exhaustive-patterns (exhaustive-branches true variantTC inputC) - redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) - heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) - #let [exhaustive-branchesC (L/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list;take (n.dec (list;size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (L/map (branch outputC)) - list;concat - (list (list;take redundancy-idx redundant-patterns) - (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) - (list;drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) - ]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC (list)))) - check-failure)) - (test "Can analyse exhaustive pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC exhaustive-branchesC))))) - check-success)) - (test "Will reject non-exhaustive pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC non-exhaustive-branchesC))))) - check-failure)) - (test "Will reject redundant pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC redundant-branchesC))))) - check-failure)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC heterogeneous-branchesC))))) - check-failure)) - )) + (<| (seed +5004137551292836565) + ## (times +100) + (do @ + [module-name (r;text +5) + variant-name (r;text +5) + record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) + size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + variant-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + record-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + primitivesTC (r;list size gen-primitive) + #let [primitivesT (L/map product;left primitivesTC) + primitivesC (L/map product;right primitivesTC) + variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) + record-tags+ (L/map (|>. [module-name] code;tag) record-tags) + variantTC (list;zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] gen-primitive + [heterogeneousT heterogeneousC] (|> gen-primitive + (r;filter (|>. product;left (tc;checks? outputT) not))) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) + heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) + #let [exhaustive-branchesC (L/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list;take (n.dec (list;size exhaustive-branchesC)) + exhaustive-branchesC) + redundant-branchesC (<| (L/map (branch outputC)) + list;concat + (list (list;take redundancy-idx redundant-patterns) + (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) + (list;drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) + ]] + ($_ seq + (test "Will reject empty pattern-matching (no branches)." + (|> (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC (list)))) + check-failure)) + (test "Can analyse exhaustive pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC exhaustive-branchesC))))) + check-success)) + (test "Will reject non-exhaustive pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC non-exhaustive-branchesC))))) + check-failure)) + (test "Will reject redundant pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC redundant-branchesC))))) + check-failure)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC heterogeneous-branchesC))))) + check-failure)) + )))) diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux index 4b74db183..baef5c42c 100644 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ b/new-luxc/test/test/luxc/analyser/function.lux @@ -64,92 +64,96 @@ false))) (context: "Function definition." - [func-name (r;text +5) - arg-name (|> (r;text +5) (r;filter (|>. (text/= func-name) not))) - [outputT outputC] gen-primitive - [inputT _] gen-primitive] - ($_ seq - (test "Can analyse function." - (|> (&;with-expected-type (type (All [a] (-> a outputT))) - (@;analyse-function analyse func-name arg-name outputC)) - (meta;run (init-compiler [])) - succeeds?)) - (test "Generic functions can always be specialized." - (and (|> (&;with-expected-type (-> inputT outputT) - (@;analyse-function analyse func-name arg-name outputC)) - (meta;run (init-compiler [])) - succeeds?) - (|> (&;with-expected-type (-> inputT inputT) - (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (meta;run (init-compiler [])) - succeeds?))) - (test "Can infer function (constant output and unused input)." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name outputC)) - (meta;run (init-compiler [])) - (check-type (type (All [a] (-> a outputT)))))) - (test "Can infer function (output = input)." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (meta;run (init-compiler [])) - (check-type (type (All [a] (-> a a)))))) - (test "The function's name is bound to the function's type." - (|> (&;with-expected-type (type (Rec self (-> inputT self))) - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (meta;run (init-compiler [])) - succeeds?)) - (test "Can infer recursive types for functions." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (meta;run (init-compiler [])) - (check-type (type (Rec self (All [a] (-> a self))))))) - )) + (<| (times +100) + (do @ + [func-name (r;text +5) + arg-name (|> (r;text +5) (r;filter (|>. (text/= func-name) not))) + [outputT outputC] gen-primitive + [inputT _] gen-primitive] + ($_ seq + (test "Can analyse function." + (|> (&;with-expected-type (type (All [a] (-> a outputT))) + (@;analyse-function analyse func-name arg-name outputC)) + (meta;run (init-compiler [])) + succeeds?)) + (test "Generic functions can always be specialized." + (and (|> (&;with-expected-type (-> inputT outputT) + (@;analyse-function analyse func-name arg-name outputC)) + (meta;run (init-compiler [])) + succeeds?) + (|> (&;with-expected-type (-> inputT inputT) + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (meta;run (init-compiler [])) + succeeds?))) + (test "Can infer function (constant output and unused input)." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name outputC)) + (meta;run (init-compiler [])) + (check-type (type (All [a] (-> a outputT)))))) + (test "Can infer function (output = input)." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (meta;run (init-compiler [])) + (check-type (type (All [a] (-> a a)))))) + (test "The function's name is bound to the function's type." + (|> (&;with-expected-type (type (Rec self (-> inputT self))) + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (meta;run (init-compiler [])) + succeeds?)) + (test "Can infer recursive types for functions." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (meta;run (init-compiler [])) + (check-type (type (Rec self (All [a] (-> a self))))))) + )))) (context: "Function application." - [full-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - partial-args (|> r;nat (:: @ map (n.% full-args))) - var-idx (|> r;nat (:: @ map (|>. (n.% full-args) (n.max +1)))) - inputsTC (r;list full-args gen-primitive) - #let [inputsT (list/map product;left inputsTC) - inputsC (list/map product;right inputsTC)] - [outputT outputC] gen-primitive - #let [funcT (type;function inputsT outputT) - partialT (type;function (list;drop partial-args inputsT) outputT) - varT (#;Bound +1) - polyT (<| (type;univ-q +1) - (type;function (list;concat (list (list;take var-idx inputsT) - (list varT) - (list;drop (n.inc var-idx) inputsT)))) - varT) - poly-inputT (maybe;assume (list;nth var-idx inputsT)) - partial-poly-inputsT (list;drop (n.inc var-idx) inputsT) - partial-polyT1 (<| (type;function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type;univ-q +1) - (type;function (#;Cons varT partial-poly-inputsT)) - varT)]] - ($_ seq - (test "Can analyse monomorphic type application." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (#la;Unit) inputsC)) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (#la;Unit) - (list;take partial-args inputsC))) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (#la;Unit) inputsC)) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (#la;Unit) - (list;take (n.inc var-idx) inputsC))) - (check-apply partial-polyT1 (n.inc var-idx)))) - (test "Polymorphic partial application preserves quantification for type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (#la;Unit) - (list;take var-idx inputsC))) - (check-apply partial-polyT2 var-idx))) - )) + (<| (times +100) + (do @ + [full-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + partial-args (|> r;nat (:: @ map (n.% full-args))) + var-idx (|> r;nat (:: @ map (|>. (n.% full-args) (n.max +1)))) + inputsTC (r;list full-args gen-primitive) + #let [inputsT (list/map product;left inputsTC) + inputsC (list/map product;right inputsTC)] + [outputT outputC] gen-primitive + #let [funcT (type;function inputsT outputT) + partialT (type;function (list;drop partial-args inputsT) outputT) + varT (#;Bound +1) + polyT (<| (type;univ-q +1) + (type;function (list;concat (list (list;take var-idx inputsT) + (list varT) + (list;drop (n.inc var-idx) inputsT)))) + varT) + poly-inputT (maybe;assume (list;nth var-idx inputsT)) + partial-poly-inputsT (list;drop (n.inc var-idx) inputsT) + partial-polyT1 (<| (type;function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type;univ-q +1) + (type;function (#;Cons varT partial-poly-inputsT)) + varT)]] + ($_ seq + (test "Can analyse monomorphic type application." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (#la;Unit) inputsC)) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (#la;Unit) + (list;take partial-args inputsC))) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) inputsC)) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) + (list;take (n.inc var-idx) inputsC))) + (check-apply partial-polyT1 (n.inc var-idx)))) + (test "Polymorphic partial application preserves quantification for type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) + (list;take var-idx inputsC))) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux index 053587781..3d2e4ada6 100644 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ b/new-luxc/test/test/luxc/analyser/primitive.lux @@ -26,33 +26,35 @@ (test/luxc common)) (context: "Primitives" - [%bool% r;bool - %nat% r;nat - %int% r;int - %deg% r;deg - %frac% r;frac - %text% (r;text +5)] - (with-expansions - [ (do-template [ ] - [(test (format "Can analyse " ".") - (|> (@common;with-unknown-type - ( )) - (meta;run (init-compiler [])) - (case> (#e;Success [_type ( value)]) - (and (type/= _type) - (is value)) + (<| (times +100) + (do @ + [%bool% r;bool + %nat% r;nat + %int% r;int + %deg% r;deg + %frac% r;frac + %text% (r;text +5)] + (with-expansions + [ (do-template [ ] + [(test (format "Can analyse " ".") + (|> (@common;with-unknown-type + ( )) + (meta;run (init-compiler [])) + (case> (#e;Success [_type ( value)]) + (and (type/= _type) + (is value)) - _ - false)) - )] + _ + false)) + )] - ["unit" Unit #~;Unit [] (function [value] @;analyse-unit)] - ["bool" Bool #~;Bool %bool% @;analyse-bool] - ["nat" Nat #~;Nat %nat% @;analyse-nat] - ["int" Int #~;Int %int% @;analyse-int] - ["deg" Deg #~;Deg %deg% @;analyse-deg] - ["frac" Frac #~;Frac %frac% @;analyse-frac] - ["text" Text #~;Text %text% @;analyse-text] - )] - ($_ seq - ))) + ["unit" Unit #~;Unit [] (function [value] @;analyse-unit)] + ["bool" Bool #~;Bool %bool% @;analyse-bool] + ["nat" Nat #~;Nat %nat% @;analyse-nat] + ["int" Int #~;Int %int% @;analyse-int] + ["deg" Deg #~;Deg %deg% @;analyse-deg] + ["frac" Frac #~;Frac %frac% @;analyse-frac] + ["text" Text #~;Text %text% @;analyse-text] + )] + ($_ seq + ))))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux index ee342971b..208076d6e 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/common.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/common.lux @@ -40,358 +40,382 @@ ) (context: "Lux procedures" - [[primT primC] gen-primitive - [antiT antiC] (|> gen-primitive - (r;filter (|>. product;left (type/= primT) not)))] - ($_ seq - (test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) - (type (Either Text primT)))) - )) + (<| (times +100) + (do @ + [[primT primC] gen-primitive + [antiT antiC] (|> gen-primitive + (r;filter (|>. product;left (type/= primT) not)))] + ($_ seq + (test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bool)) + (test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bool)) + (test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + (type (Either Text primT)))) + )))) (context: "Bit procedures" - [subjectC (|> r;nat (:: @ map code;nat)) - signedC (|> r;int (:: @ map code;int)) - paramC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can count the number of 1 bits in a bit pattern." - (check-success+ "lux bit count" (list subjectC) Nat)) - (test "Can perform bit 'and'." - (check-success+ "lux bit and" (list subjectC paramC) Nat)) - (test "Can perform bit 'or'." - (check-success+ "lux bit or" (list subjectC paramC) Nat)) - (test "Can perform bit 'xor'." - (check-success+ "lux bit xor" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the left." - (check-success+ "lux bit shift-left" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the right." - (check-success+ "lux bit unsigned-shift-right" (list subjectC paramC) Nat)) - (test "Can shift signed bit pattern to the right." - (check-success+ "lux bit shift-right" (list signedC paramC) Int)) - )) + (<| (times +100) + (do @ + [subjectC (|> r;nat (:: @ map code;nat)) + signedC (|> r;int (:: @ map code;int)) + paramC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can count the number of 1 bits in a bit pattern." + (check-success+ "lux bit count" (list subjectC) Nat)) + (test "Can perform bit 'and'." + (check-success+ "lux bit and" (list subjectC paramC) Nat)) + (test "Can perform bit 'or'." + (check-success+ "lux bit or" (list subjectC paramC) Nat)) + (test "Can perform bit 'xor'." + (check-success+ "lux bit xor" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the left." + (check-success+ "lux bit shift-left" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the right." + (check-success+ "lux bit unsigned-shift-right" (list subjectC paramC) Nat)) + (test "Can shift signed bit pattern to the right." + (check-success+ "lux bit shift-right" (list signedC paramC) Int)) + )))) (context: "Nat procedures" - [subjectC (|> r;nat (:: @ map code;nat)) - paramC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can add natural numbers." - (check-success+ "lux nat +" (list subjectC paramC) Nat)) - (test "Can subtract natural numbers." - (check-success+ "lux nat -" (list subjectC paramC) Nat)) - (test "Can multiply natural numbers." - (check-success+ "lux nat *" (list subjectC paramC) Nat)) - (test "Can divide natural numbers." - (check-success+ "lux nat /" (list subjectC paramC) Nat)) - (test "Can calculate remainder of natural numbers." - (check-success+ "lux nat %" (list subjectC paramC) Nat)) - (test "Can test equality of natural numbers." - (check-success+ "lux nat =" (list subjectC paramC) Bool)) - (test "Can compare natural numbers." - (check-success+ "lux nat <" (list subjectC paramC) Bool)) - (test "Can obtain minimum natural number." - (check-success+ "lux nat min" (list) Nat)) - (test "Can obtain maximum natural number." - (check-success+ "lux nat max" (list) Nat)) - (test "Can convert natural number to integer." - (check-success+ "lux nat to-int" (list subjectC) Int)) - (test "Can convert natural number to text." - (check-success+ "lux nat to-text" (list subjectC) Text)) - )) + (<| (times +100) + (do @ + [subjectC (|> r;nat (:: @ map code;nat)) + paramC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can add natural numbers." + (check-success+ "lux nat +" (list subjectC paramC) Nat)) + (test "Can subtract natural numbers." + (check-success+ "lux nat -" (list subjectC paramC) Nat)) + (test "Can multiply natural numbers." + (check-success+ "lux nat *" (list subjectC paramC) Nat)) + (test "Can divide natural numbers." + (check-success+ "lux nat /" (list subjectC paramC) Nat)) + (test "Can calculate remainder of natural numbers." + (check-success+ "lux nat %" (list subjectC paramC) Nat)) + (test "Can test equality of natural numbers." + (check-success+ "lux nat =" (list subjectC paramC) Bool)) + (test "Can compare natural numbers." + (check-success+ "lux nat <" (list subjectC paramC) Bool)) + (test "Can obtain minimum natural number." + (check-success+ "lux nat min" (list) Nat)) + (test "Can obtain maximum natural number." + (check-success+ "lux nat max" (list) Nat)) + (test "Can convert natural number to integer." + (check-success+ "lux nat to-int" (list subjectC) Int)) + (test "Can convert natural number to text." + (check-success+ "lux nat to-text" (list subjectC) Text)) + )))) (context: "Int procedures" - [subjectC (|> r;int (:: @ map code;int)) - paramC (|> r;int (:: @ map code;int))] - ($_ seq - (test "Can add integers." - (check-success+ "lux int +" (list subjectC paramC) Int)) - (test "Can subtract integers." - (check-success+ "lux int -" (list subjectC paramC) Int)) - (test "Can multiply integers." - (check-success+ "lux int *" (list subjectC paramC) Int)) - (test "Can divide integers." - (check-success+ "lux int /" (list subjectC paramC) Int)) - (test "Can calculate remainder of integers." - (check-success+ "lux int %" (list subjectC paramC) Int)) - (test "Can test equality of integers." - (check-success+ "lux int =" (list subjectC paramC) Bool)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bool)) - (test "Can obtain minimum integer." - (check-success+ "lux int min" (list) Int)) - (test "Can obtain maximum integer." - (check-success+ "lux int max" (list) Int)) - (test "Can convert integer to natural number." - (check-success+ "lux int to-nat" (list subjectC) Nat)) - (test "Can convert integer to frac number." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - )) + (<| (times +100) + (do @ + [subjectC (|> r;int (:: @ map code;int)) + paramC (|> r;int (:: @ map code;int))] + ($_ seq + (test "Can add integers." + (check-success+ "lux int +" (list subjectC paramC) Int)) + (test "Can subtract integers." + (check-success+ "lux int -" (list subjectC paramC) Int)) + (test "Can multiply integers." + (check-success+ "lux int *" (list subjectC paramC) Int)) + (test "Can divide integers." + (check-success+ "lux int /" (list subjectC paramC) Int)) + (test "Can calculate remainder of integers." + (check-success+ "lux int %" (list subjectC paramC) Int)) + (test "Can test equality of integers." + (check-success+ "lux int =" (list subjectC paramC) Bool)) + (test "Can compare integers." + (check-success+ "lux int <" (list subjectC paramC) Bool)) + (test "Can obtain minimum integer." + (check-success+ "lux int min" (list) Int)) + (test "Can obtain maximum integer." + (check-success+ "lux int max" (list) Int)) + (test "Can convert integer to natural number." + (check-success+ "lux int to-nat" (list subjectC) Nat)) + (test "Can convert integer to frac number." + (check-success+ "lux int to-frac" (list subjectC) Frac)) + )))) (context: "Deg procedures" - [subjectC (|> r;deg (:: @ map code;deg)) - paramC (|> r;deg (:: @ map code;deg)) - natC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can add degrees." - (check-success+ "lux deg +" (list subjectC paramC) Deg)) - (test "Can subtract degrees." - (check-success+ "lux deg -" (list subjectC paramC) Deg)) - (test "Can multiply degrees." - (check-success+ "lux deg *" (list subjectC paramC) Deg)) - (test "Can divide degrees." - (check-success+ "lux deg /" (list subjectC paramC) Deg)) - (test "Can calculate remainder of degrees." - (check-success+ "lux deg %" (list subjectC paramC) Deg)) - (test "Can test equality of degrees." - (check-success+ "lux deg =" (list subjectC paramC) Bool)) - (test "Can compare degrees." - (check-success+ "lux deg <" (list subjectC paramC) Bool)) - (test "Can obtain minimum degree." - (check-success+ "lux deg min" (list) Deg)) - (test "Can obtain maximum degree." - (check-success+ "lux deg max" (list) Deg)) - (test "Can convert degree to frac number." - (check-success+ "lux deg to-frac" (list subjectC) Frac)) - (test "Can scale degree." - (check-success+ "lux deg scale" (list subjectC natC) Deg)) - (test "Can calculate the reciprocal of a natural number." - (check-success+ "lux deg reciprocal" (list natC) Deg)) - )) + (<| (times +100) + (do @ + [subjectC (|> r;deg (:: @ map code;deg)) + paramC (|> r;deg (:: @ map code;deg)) + natC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can add degrees." + (check-success+ "lux deg +" (list subjectC paramC) Deg)) + (test "Can subtract degrees." + (check-success+ "lux deg -" (list subjectC paramC) Deg)) + (test "Can multiply degrees." + (check-success+ "lux deg *" (list subjectC paramC) Deg)) + (test "Can divide degrees." + (check-success+ "lux deg /" (list subjectC paramC) Deg)) + (test "Can calculate remainder of degrees." + (check-success+ "lux deg %" (list subjectC paramC) Deg)) + (test "Can test equality of degrees." + (check-success+ "lux deg =" (list subjectC paramC) Bool)) + (test "Can compare degrees." + (check-success+ "lux deg <" (list subjectC paramC) Bool)) + (test "Can obtain minimum degree." + (check-success+ "lux deg min" (list) Deg)) + (test "Can obtain maximum degree." + (check-success+ "lux deg max" (list) Deg)) + (test "Can convert degree to frac number." + (check-success+ "lux deg to-frac" (list subjectC) Frac)) + (test "Can scale degree." + (check-success+ "lux deg scale" (list subjectC natC) Deg)) + (test "Can calculate the reciprocal of a natural number." + (check-success+ "lux deg reciprocal" (list natC) Deg)) + )))) (context: "Frac procedures" - [subjectC (|> r;frac (:: @ map code;frac)) - paramC (|> r;frac (:: @ map code;frac)) - encodedC (|> (r;text +5) (:: @ map code;text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list subjectC paramC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list subjectC paramC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list subjectC paramC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list subjectC paramC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list subjectC paramC) Frac)) - (test "Can test equality of frac numbers." - (check-success+ "lux frac =" (list subjectC paramC) Bool)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bool)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can obtain not-a-number." - (check-success+ "lux frac not-a-number" (list) Frac)) - (test "Can obtain positive infinity." - (check-success+ "lux frac positive-infinity" (list) Frac)) - (test "Can obtain negative infinity." - (check-success+ "lux frac negative-infinity" (list) Frac)) - (test "Can convert frac number to integer." - (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to degree." - (check-success+ "lux frac to-deg" (list subjectC) Deg)) - (test "Can convert frac number to text." - (check-success+ "lux frac encode" (list subjectC) Text)) - (test "Can convert text to frac number." - (check-success+ "lux frac encode" (list encodedC) (type (Maybe Frac)))) - )) + (<| (times +100) + (do @ + [subjectC (|> r;frac (:: @ map code;frac)) + paramC (|> r;frac (:: @ map code;frac)) + encodedC (|> (r;text +5) (:: @ map code;text))] + ($_ seq + (test "Can add frac numbers." + (check-success+ "lux frac +" (list subjectC paramC) Frac)) + (test "Can subtract frac numbers." + (check-success+ "lux frac -" (list subjectC paramC) Frac)) + (test "Can multiply frac numbers." + (check-success+ "lux frac *" (list subjectC paramC) Frac)) + (test "Can divide frac numbers." + (check-success+ "lux frac /" (list subjectC paramC) Frac)) + (test "Can calculate remainder of frac numbers." + (check-success+ "lux frac %" (list subjectC paramC) Frac)) + (test "Can test equality of frac numbers." + (check-success+ "lux frac =" (list subjectC paramC) Bool)) + (test "Can compare frac numbers." + (check-success+ "lux frac <" (list subjectC paramC) Bool)) + (test "Can obtain minimum frac number." + (check-success+ "lux frac min" (list) Frac)) + (test "Can obtain maximum frac number." + (check-success+ "lux frac max" (list) Frac)) + (test "Can obtain smallest frac number." + (check-success+ "lux frac smallest" (list) Frac)) + (test "Can obtain not-a-number." + (check-success+ "lux frac not-a-number" (list) Frac)) + (test "Can obtain positive infinity." + (check-success+ "lux frac positive-infinity" (list) Frac)) + (test "Can obtain negative infinity." + (check-success+ "lux frac negative-infinity" (list) Frac)) + (test "Can convert frac number to integer." + (check-success+ "lux frac to-int" (list subjectC) Int)) + (test "Can convert frac number to degree." + (check-success+ "lux frac to-deg" (list subjectC) Deg)) + (test "Can convert frac number to text." + (check-success+ "lux frac encode" (list subjectC) Text)) + (test "Can convert text to frac number." + (check-success+ "lux frac encode" (list encodedC) (type (Maybe Frac)))) + )))) (context: "Text procedures" - [subjectC (|> (r;text +5) (:: @ map code;text)) - paramC (|> (r;text +5) (:: @ map code;text)) - replacementC (|> (r;text +5) (:: @ map code;text)) - fromC (|> r;nat (:: @ map code;nat)) - toC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can test text equality." - (check-success+ "lux text =" (list subjectC paramC) Bool)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bool)) - (test "Can prepend one text to another." - (check-success+ "lux text prepend" (list subjectC paramC) Text)) - (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (test "Can calculate a hash code for text." - (check-success+ "lux text hash" (list subjectC) Nat)) - (test "Can replace a text inside of a larger one (once)." - (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) - (test "Can replace a text inside of a larger one (all times)." - (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) - (test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list subjectC fromC) Nat)) - (test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list subjectC fromC toC) Text)) - )) + (<| (times +100) + (do @ + [subjectC (|> (r;text +5) (:: @ map code;text)) + paramC (|> (r;text +5) (:: @ map code;text)) + replacementC (|> (r;text +5) (:: @ map code;text)) + fromC (|> r;nat (:: @ map code;nat)) + toC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can test text equality." + (check-success+ "lux text =" (list subjectC paramC) Bool)) + (test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list subjectC paramC) Bool)) + (test "Can prepend one text to another." + (check-success+ "lux text prepend" (list subjectC paramC) Text)) + (test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (test "Can calculate a hash code for text." + (check-success+ "lux text hash" (list subjectC) Nat)) + (test "Can replace a text inside of a larger one (once)." + (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) + (test "Can replace a text inside of a larger one (all times)." + (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) + (test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list subjectC fromC) Nat)) + (test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list subjectC fromC toC) Text)) + )))) (context: "Array procedures" - [[elemT elemC] gen-primitive - sizeC (|> r;nat (:: @ map code;nat)) - idxC (|> r;nat (:: @ map code;nat)) - var-name (r;text +5) - #let [arrayT (type (Array elemT))]] - ($_ seq - (test "Can create arrays." - (check-success+ "lux array new" (list sizeC) arrayT)) - (test "Can get a value inside an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type elemT - (@;analyse-procedure analyse "lux array get" - (list idxC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + (<| (times +100) + (do @ + [[elemT elemC] gen-primitive + sizeC (|> r;nat (:: @ map code;nat)) + idxC (|> r;nat (:: @ map code;nat)) + var-name (r;text +5) + #let [arrayT (type (Array elemT))]] + ($_ seq + (test "Can create arrays." + (check-success+ "lux array new" (list sizeC) arrayT)) + (test "Can get a value inside an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type elemT + (@;analyse-procedure analyse "lux array get" + (list idxC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error _) - false))) - (test "Can put a value inside an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type arrayT - (@;analyse-procedure analyse "lux array put" - (list idxC - elemC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + (#e;Error _) + false))) + (test "Can put a value inside an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse "lux array put" + (list idxC + elemC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error _) - false))) - (test "Can remove a value from an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type arrayT - (@;analyse-procedure analyse "lux array remove" - (list idxC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + (#e;Error _) + false))) + (test "Can remove a value from an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse "lux array remove" + (list idxC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error _) - false))) - (test "Can query the size of an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-expected-type Nat - (@;analyse-procedure analyse "lux array size" - (list (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + (#e;Error _) + false))) + (test "Can query the size of an array." + (|> (&scope;with-scope "" + (&scope;with-local [var-name arrayT] + (&;with-expected-type Nat + (@;analyse-procedure analyse "lux array size" + (list (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error _) - false))) - )) + (#e;Error _) + false))) + )))) (context: "Math procedures" - [subjectC (|> r;frac (:: @ map code;frac)) - paramC (|> r;frac (:: @ map code;frac))] - (with-expansions [ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] + (<| (times +100) + (do @ + [subjectC (|> r;frac (:: @ map code;frac)) + paramC (|> r;frac (:: @ map code;frac))] + (with-expansions [ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC) Frac))] - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math root2" "square root"] - ["lux math root3" "cubic root"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"]) - (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math root2" "square root"] + ["lux math root3" "cubic root"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"]) + (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"])] - ($_ seq - - ))) + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"])] + ($_ seq + + ))))) (context: "Atom procedures" - [[elemT elemC] gen-primitive - sizeC (|> r;nat (:: @ map code;nat)) - idxC (|> r;nat (:: @ map code;nat)) - var-name (r;text +5) - #let [atomT (type (atom;Atom elemT))]] - ($_ seq - (test "Can create atomic reference." - (check-success+ "lux atom new" (list elemC) atomT)) - (test "Can read the value of an atomic reference." - (|> (&scope;with-scope "" - (&scope;with-local [var-name atomT] - (&;with-expected-type elemT - (@;analyse-procedure analyse "lux atom read" - (list (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + (<| (times +100) + (do @ + [[elemT elemC] gen-primitive + sizeC (|> r;nat (:: @ map code;nat)) + idxC (|> r;nat (:: @ map code;nat)) + var-name (r;text +5) + #let [atomT (type (atom;Atom elemT))]] + ($_ seq + (test "Can create atomic reference." + (check-success+ "lux atom new" (list elemC) atomT)) + (test "Can read the value of an atomic reference." + (|> (&scope;with-scope "" + (&scope;with-local [var-name atomT] + (&;with-expected-type elemT + (@;analyse-procedure analyse "lux atom read" + (list (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error _) - false))) - (test "Can swap the value of an atomic reference." - (|> (&scope;with-scope "" - (&scope;with-local [var-name atomT] - (&;with-expected-type Bool - (@;analyse-procedure analyse "lux atom compare-and-swap" - (list elemC - elemC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + (#e;Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (&scope;with-scope "" + (&scope;with-local [var-name atomT] + (&;with-expected-type Bool + (@;analyse-procedure analyse "lux atom compare-and-swap" + (list elemC + elemC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error _) - false))) - )) + (#e;Error _) + false))) + )))) (context: "Process procedures" - [[primT primC] gen-primitive - timeC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can query the level of concurrency." - (check-success+ "lux process concurrency-level" (list) Nat)) - (test "Can run an IO computation concurrently." - (check-success+ "lux process future" - (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) - Unit)) - (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "lux process schedule" - (list timeC - (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) - Unit)) - )) + (<| (times +100) + (do @ + [[primT primC] gen-primitive + timeC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can query the level of concurrency." + (check-success+ "lux process concurrency-level" (list) Nat)) + (test "Can run an IO computation concurrently." + (check-success+ "lux process future" + (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + Unit)) + (test "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "lux process schedule" + (list timeC + (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + Unit)) + )))) (context: "IO procedures" - [logC (|> (r;text +5) (:: @ map code;text)) - exitC (|> r;nat (:: @ map code;nat))] - ($_ seq - (test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Unit)) - (test "Can log messages to standard output." - (check-success+ "lux io error" (list logC) Bottom)) - (test "Can log messages to standard output." - (check-success+ "lux io exit" (list exitC) Bottom)) - (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - )) + (<| (times +100) + (do @ + [logC (|> (r;text +5) (:: @ map code;text)) + exitC (|> r;nat (:: @ map code;nat))] + ($_ seq + (test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Unit)) + (test "Can log messages to standard output." + (check-success+ "lux io error" (list logC) Bottom)) + (test "Can log messages to standard output." + (check-success+ "lux io exit" (list exitC) Bottom)) + (test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + )))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux index ba59500f4..aa0f2388d 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux @@ -249,47 +249,49 @@ (wrap [unboxed boxed])))) (context: "Array." - [#let [cap (|>. (n.% +10) (n.max +1))] - [unboxed boxed] array-type - size (|> r;nat (:: @ map cap)) - idx (|> r;nat (:: @ map (n.% size))) - level (|> r;nat (:: @ map cap)) - #let [unboxedT (#;Host unboxed (list)) - arrayT (#;Host "#Array" (list unboxedT)) - arrayC (`' (_lux_check (+0 "#Array" (+1 (+0 (~ (code;text unboxed)) (+0)) (+0))) - ("jvm array new" (~ (code;nat size))))) - boxedT (#;Host boxed (list)) - boxedTC (` (+0 (~ (code;text boxed)) (+0))) - multi-arrayT (list/fold (function [_ innerT] - (|> innerT (list) (#;Host "#Array"))) - boxedT - (list;n.range +1 level))]] - ($_ seq - (test "jvm array new" - (success "jvm array new" - (list (code;nat size)) - arrayT)) - (test "jvm array new (no nesting)" - (failure "jvm array new" - (list (code;nat size)) - unboxedT)) - (test "jvm array new (nested/multi-level)" - (success "jvm array new" - (list (code;nat size)) - multi-arrayT)) - (test "jvm array length" - (success "jvm array length" - (list arrayC) - Nat)) - (test "jvm array read" - (success "jvm array read" - (list arrayC (code;nat idx)) - boxedT)) - (test "jvm array write" - (success "jvm array write" - (list arrayC (code;nat idx) (`' (_lux_coerce (~ boxedTC) []))) - arrayT)) - )) + (<| (times +100) + (do @ + [#let [cap (|>. (n.% +10) (n.max +1))] + [unboxed boxed] array-type + size (|> r;nat (:: @ map cap)) + idx (|> r;nat (:: @ map (n.% size))) + level (|> r;nat (:: @ map cap)) + #let [unboxedT (#;Primitive unboxed (list)) + arrayT (#;Primitive "#Array" (list unboxedT)) + arrayC (`' (_lux_check (+0 "#Array" (+1 (+0 (~ (code;text unboxed)) (+0)) (+0))) + ("jvm array new" (~ (code;nat size))))) + boxedT (#;Primitive boxed (list)) + boxedTC (` (+0 (~ (code;text boxed)) (+0))) + multi-arrayT (list/fold (function [_ innerT] + (|> innerT (list) (#;Primitive "#Array"))) + boxedT + (list;n.range +1 level))]] + ($_ seq + (test "jvm array new" + (success "jvm array new" + (list (code;nat size)) + arrayT)) + (test "jvm array new (no nesting)" + (failure "jvm array new" + (list (code;nat size)) + unboxedT)) + (test "jvm array new (nested/multi-level)" + (success "jvm array new" + (list (code;nat size)) + multi-arrayT)) + (test "jvm array length" + (success "jvm array length" + (list arrayC) + Nat)) + (test "jvm array read" + (success "jvm array read" + (list arrayC (code;nat idx)) + boxedT)) + (test "jvm array write" + (success "jvm array write" + (list arrayC (code;nat idx) (`' (_lux_coerce (~ boxedTC) []))) + arrayT)) + )))) (def: throwables (List Text) @@ -302,74 +304,76 @@ "java.lang.RuntimeException")) (context: "Object." - [[unboxed boxed] array-type - [!unboxed !boxed] (|> array-type - (r;filter (function [[!unboxed !boxed]] - (not (text/= boxed !boxed))))) - #let [boxedT (#;Host boxed (list)) - boxedC (`' (_lux_check (+0 (~ (code;text boxed)) (+0)) - ("jvm object null"))) - !boxedC (`' (_lux_check (+0 (~ (code;text !boxed)) (+0)) - ("jvm object null"))) - unboxedC (`' (_lux_check (+0 (~ (code;text unboxed)) (+0)) - ("jvm object null")))] - throwable (|> r;nat - (:: @ map (n.% (n.inc (list;size throwables)))) - (:: @ map (function [idx] - (|> throwables - (list;nth idx) - (maybe;default "java.lang.Object"))))) - #let [throwableC (`' (_lux_check (+0 (~ (code;text throwable)) (+0)) - ("jvm object null")))]] - ($_ seq - (test "jvm object null" - (success "jvm object null" - (list) - (#;Host boxed (list)))) - (test "jvm object null (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object null" - (list) - (#;Host unboxed (list))))) - (test "jvm object null?" - (success "jvm object null?" - (list boxedC) - Bool)) - (test "jvm object synchronized" - (success "jvm object synchronized" - (list boxedC boxedC) - boxedT)) - (test "jvm object synchronized (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object synchronized" - (list unboxedC boxedC) - boxedT))) - (test "jvm object throw" - (or (text/= "java.lang.Object" throwable) - (success "jvm object throw" - (list throwableC) - Bottom))) - (test "jvm object class" - (success "jvm object class" - (list (code;text boxed)) - (#;Host "java.lang.Class" (list boxedT)))) - (test "jvm object instance?" - (success "jvm object instance?" - (list (code;text boxed) - boxedC) - Bool)) - (test "jvm object instance? (lineage)" - (success "jvm object instance?" - (list (' "java.lang.Object") - boxedC) - Bool)) - (test "jvm object instance? (no lineage)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object instance?" - (list (code;text boxed) - !boxedC) - Bool))) - )) + (<| (times +100) + (do @ + [[unboxed boxed] array-type + [!unboxed !boxed] (|> array-type + (r;filter (function [[!unboxed !boxed]] + (not (text/= boxed !boxed))))) + #let [boxedT (#;Primitive boxed (list)) + boxedC (`' (_lux_check (+0 (~ (code;text boxed)) (+0)) + ("jvm object null"))) + !boxedC (`' (_lux_check (+0 (~ (code;text !boxed)) (+0)) + ("jvm object null"))) + unboxedC (`' (_lux_check (+0 (~ (code;text unboxed)) (+0)) + ("jvm object null")))] + throwable (|> r;nat + (:: @ map (n.% (n.inc (list;size throwables)))) + (:: @ map (function [idx] + (|> throwables + (list;nth idx) + (maybe;default "java.lang.Object"))))) + #let [throwableC (`' (_lux_check (+0 (~ (code;text throwable)) (+0)) + ("jvm object null")))]] + ($_ seq + (test "jvm object null" + (success "jvm object null" + (list) + (#;Primitive boxed (list)))) + (test "jvm object null (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object null" + (list) + (#;Primitive unboxed (list))))) + (test "jvm object null?" + (success "jvm object null?" + (list boxedC) + Bool)) + (test "jvm object synchronized" + (success "jvm object synchronized" + (list boxedC boxedC) + boxedT)) + (test "jvm object synchronized (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object synchronized" + (list unboxedC boxedC) + boxedT))) + (test "jvm object throw" + (or (text/= "java.lang.Object" throwable) + (success "jvm object throw" + (list throwableC) + Bottom))) + (test "jvm object class" + (success "jvm object class" + (list (code;text boxed)) + (#;Primitive "java.lang.Class" (list boxedT)))) + (test "jvm object instance?" + (success "jvm object instance?" + (list (code;text boxed) + boxedC) + Bool)) + (test "jvm object instance? (lineage)" + (success "jvm object instance?" + (list (' "java.lang.Object") + boxedC) + Bool)) + (test "jvm object instance? (no lineage)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object instance?" + (list (code;text boxed) + !boxedC) + Bool))) + )))) (context: "Member [Static Field]." ($_ seq @@ -377,12 +381,12 @@ (success "jvm member static get" (list (code;text "java.lang.System") (code;text "out")) - (#;Host "java.io.PrintStream" (list)))) + (#;Primitive "java.io.PrintStream" (list)))) (test "jvm member static get (inheritance out)" (success "jvm member static get" (list (code;text "java.lang.System") (code;text "out")) - (#;Host "java.lang.Object" (list)))) + (#;Primitive "java.lang.Object" (list)))) (test "jvm member static put" (success "jvm member static put" (list (code;text "java.awt.datatransfer.DataFlavor") @@ -414,14 +418,14 @@ (code;text "id") (`' (_lux_check (+0 "org.omg.CORBA.ValueMember" (+0)) ("jvm object null")))) - (#;Host "java.lang.String" (list)))) + (#;Primitive "java.lang.String" (list)))) (test "jvm member virtual get (inheritance out)" (success "jvm member virtual get" (list (code;text "org.omg.CORBA.ValueMember") (code;text "id") (`' (_lux_check (+0 "org.omg.CORBA.ValueMember" (+0)) ("jvm object null")))) - (#;Host "java.lang.Object" (list)))) + (#;Primitive "java.lang.Object" (list)))) (test "jvm member virtual put" (success "jvm member virtual put" (list (code;text "org.omg.CORBA.ValueMember") @@ -457,14 +461,14 @@ (success "jvm member static get" (list (code;text "java.util.GregorianCalendar") (code;text "AD")) - (#;Host "java.lang.Integer" (list)))) + (#;Primitive "java.lang.Integer" (list)))) (test "jvm member virtual get" (success "jvm member virtual get" (list (code;text "javax.accessibility.AccessibleAttributeSequence") (code;text "startIndex") (`' (_lux_check (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) ("jvm object null")))) - (#;Host "java.lang.Integer" (list)))) + (#;Primitive "java.lang.Integer" (list)))) (test "jvm member virtual put" (success "jvm member virtual put" (list (code;text "javax.accessibility.AccessibleAttributeSequence") @@ -491,7 +495,7 @@ (code;tuple (list (' "java.lang.String") (' (_lux_coerce (+0 "java.lang.String" (+0)) "YOLO"))))) - (#;Host "java.lang.Long" (list)))) + (#;Primitive "java.lang.Long" (list)))) (test "jvm member invoke virtual" (success "jvm member invoke virtual" (list (code;text "java.lang.Object") @@ -499,7 +503,7 @@ longC (code;tuple (list (' "java.lang.Object") longC))) - (#;Host "java.lang.Boolean" (list)))) + (#;Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke special" (success "jvm member invoke special" (list (code;text "java.lang.Long") @@ -507,7 +511,7 @@ longC (code;tuple (list (' "java.lang.Object") longC))) - (#;Host "java.lang.Boolean" (list)))) + (#;Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke interface" (success "jvm member invoke interface" (list (code;text "java.util.Collection") @@ -515,10 +519,10 @@ objectC (code;tuple (list (' "java.lang.Object") longC))) - (#;Host "java.lang.Boolean" (list)))) + (#;Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke constructor" (success "jvm member invoke constructor" (list (code;text "java.util.ArrayList") (code;tuple (list (' "int") intC))) - (All [a] (#;Host "java.util.ArrayList" (list a))))) + (All [a] (#;Primitive "java.util.ArrayList" (list a))))) ))) diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux index 8ffdf15b7..89d68484f 100644 --- a/new-luxc/test/test/luxc/analyser/reference.lux +++ b/new-luxc/test/test/luxc/analyser/reference.lux @@ -18,33 +18,35 @@ (test/luxc common)) (context: "References" - [[ref-type _] gen-primitive - module-name (r;text +5) - scope-name (r;text +5) - var-name (r;text +5)] - ($_ seq - (test "Can analyse variable." - (|> (&scope;with-scope scope-name - (&scope;with-local [var-name ref-type] - (@common;with-unknown-type - (@;analyse-reference ["" var-name])))) - (meta;run (init-compiler [])) - (case> (#e;Success [_type (#~;Variable idx)]) - (type/= ref-type _type) + (<| (times +100) + (do @ + [[ref-type _] gen-primitive + module-name (r;text +5) + scope-name (r;text +5) + var-name (r;text +5)] + ($_ seq + (test "Can analyse variable." + (|> (&scope;with-scope scope-name + (&scope;with-local [var-name ref-type] + (@common;with-unknown-type + (@;analyse-reference ["" var-name])))) + (meta;run (init-compiler [])) + (case> (#e;Success [_type (#~;Variable idx)]) + (type/= ref-type _type) - _ - false))) - (test "Can analyse definition." - (|> (do Monad - [_ (&module;create +0 module-name) - _ (&module;define [module-name var-name] - [ref-type (' {}) (:! Void [])])] - (@common;with-unknown-type - (@;analyse-reference [module-name var-name]))) - (meta;run (init-compiler [])) - (case> (#e;Success [_type (#~;Definition idx)]) - (type/= ref-type _type) + _ + false))) + (test "Can analyse definition." + (|> (do Monad + [_ (&module;create +0 module-name) + _ (&module;define [module-name var-name] + [ref-type (' {}) (:! Void [])])] + (@common;with-unknown-type + (@;analyse-reference [module-name var-name]))) + (meta;run (init-compiler [])) + (case> (#e;Success [_type (#~;Definition idx)]) + (type/= ref-type _type) - _ - false))) - )) + _ + false))) + )))) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux index 7ac9c29c9..40896c334 100644 --- a/new-luxc/test/test/luxc/analyser/structure.lux +++ b/new-luxc/test/test/luxc/analyser/structure.lux @@ -57,161 +57,165 @@ #;None)) (context: "Sums" - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - choice (|> r;nat (:: @ map (n.% size))) - primitives (r;list size gen-primitive) - +choice (|> r;nat (:: @ map (n.% (n.inc size)))) - [_ +valueC] gen-primitive - #let [variantT (type;variant (list/map product;left primitives)) - [valueT valueC] (maybe;assume (list;nth choice primitives)) - +size (n.inc size) - +primitives (list;concat (list (list;take choice primitives) - (list [(#;Bound +1) +valueC]) - (list;drop choice primitives))) - [+valueT +valueC] (maybe;assume (list;nth +choice +primitives)) - +variantT (type;variant (list/map product;left +primitives))]] - ($_ seq - (test "Can analyse sum." - (|> (&;with-scope - (&;with-expected-type variantT - (@;analyse-sum analyse choice valueC))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ sumA]) - [(flatten-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + choice (|> r;nat (:: @ map (n.% size))) + primitives (r;list size gen-primitive) + +choice (|> r;nat (:: @ map (n.% (n.inc size)))) + [_ +valueC] gen-primitive + #let [variantT (type;variant (list/map product;left primitives)) + [valueT valueC] (maybe;assume (list;nth choice primitives)) + +size (n.inc size) + +primitives (list;concat (list (list;take choice primitives) + (list [(#;Bound +1) +valueC]) + (list;drop choice primitives))) + [+valueT +valueC] (maybe;assume (list;nth +choice +primitives)) + +variantT (type;variant (list/map product;left +primitives))]] + ($_ seq + (test "Can analyse sum." + (|> (&;with-scope + (&;with-expected-type variantT + (@;analyse-sum analyse choice valueC))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) - _ - false))) - (test "Can analyse sum through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do meta;Monad - [_ (&;with-type-env - (tc;check varT variantT))] - (&;with-expected-type varT - (@;analyse-sum analyse choice valueC)))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ sumA]) - [(flatten-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) + _ + false))) + (test "Can analyse sum through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do meta;Monad + [_ (&;with-type-env + (tc;check varT variantT))] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC)))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) - _ - false))) - (test "Cannot analyse sum through unbound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (&;with-expected-type varT - (@;analyse-sum analyse choice valueC))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - false + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + false - _ - true))) - (test "Can analyse sum through existential quantification." - (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + _ + true))) + (test "Can analyse sum through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error error) - false))) - (test "Can analyse sum through universal quantification." - (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - (not (n.= choice +choice)) + (#e;Error error) + false))) + (test "Can analyse sum through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + (not (n.= choice +choice)) - (#e;Error error) - (n.= choice +choice)))) - )) + (#e;Error error) + (n.= choice +choice)))) + )))) (context: "Products" - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - primitives (r;list size gen-primitive) - choice (|> r;nat (:: @ map (n.% size))) - [_ +valueC] gen-primitive - #let [[singletonT singletonC] (|> primitives (list;nth choice) maybe;assume) - +primitives (list;concat (list (list;take choice primitives) - (list [(#;Bound +1) +valueC]) - (list;drop choice primitives))) - +tupleT (type;tuple (list/map product;left +primitives))]] - ($_ seq - (test "Can analyse product." - (|> (&;with-expected-type (type;tuple (list/map product;left primitives)) - (@;analyse-product analyse (list/map product;right primitives))) - (meta;run (init-compiler [])) - (case> (#e;Success tupleA) - (n.= size (list;size (flatten-tuple tupleA))) + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + primitives (r;list size gen-primitive) + choice (|> r;nat (:: @ map (n.% size))) + [_ +valueC] gen-primitive + #let [[singletonT singletonC] (|> primitives (list;nth choice) maybe;assume) + +primitives (list;concat (list (list;take choice primitives) + (list [(#;Bound +1) +valueC]) + (list;drop choice primitives))) + +tupleT (type;tuple (list/map product;left +primitives))]] + ($_ seq + (test "Can analyse product." + (|> (&;with-expected-type (type;tuple (list/map product;left primitives)) + (@;analyse-product analyse (list/map product;right primitives))) + (meta;run (init-compiler [])) + (case> (#e;Success tupleA) + (n.= size (list;size (flatten-tuple tupleA))) - _ - false))) - (test "Can infer product." - (|> (@common;with-unknown-type - (@;analyse-product analyse (list/map product;right primitives))) - (meta;run (init-compiler [])) - (case> (#e;Success [_type tupleA]) - (and (type/= (type;tuple (list/map product;left primitives)) - _type) - (n.= size (list;size (flatten-tuple tupleA)))) + _ + false))) + (test "Can infer product." + (|> (@common;with-unknown-type + (@;analyse-product analyse (list/map product;right primitives))) + (meta;run (init-compiler [])) + (case> (#e;Success [_type tupleA]) + (and (type/= (type;tuple (list/map product;left primitives)) + _type) + (n.= size (list;size (flatten-tuple tupleA)))) - _ - false))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (&;with-expected-type singletonT - (analyse (` [(~ singletonC)]))) - (meta;run (init-compiler [])) - (case> (#e;Success singletonA) - true + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (&;with-expected-type singletonT + (analyse (` [(~ singletonC)]))) + (meta;run (init-compiler [])) + (case> (#e;Success singletonA) + true - (#e;Error error) - false))) - (test "Can analyse product through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do meta;Monad - [_ (&;with-type-env - (tc;check varT (type;tuple (list/map product;left primitives))))] - (&;with-expected-type varT - (@;analyse-product analyse (list/map product;right primitives))))))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ tupleA]) - (n.= size (list;size (flatten-tuple tupleA))) + (#e;Error error) + false))) + (test "Can analyse product through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do meta;Monad + [_ (&;with-type-env + (tc;check varT (type;tuple (list/map product;left primitives))))] + (&;with-expected-type varT + (@;analyse-product analyse (list/map product;right primitives))))))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ tupleA]) + (n.= size (list;size (flatten-tuple tupleA))) - _ - false))) - (test "Can analyse product through existential quantification." - (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +tupleT) - (@;analyse-product analyse (list/map product;right +primitives)))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true + _ + false))) + (test "Can analyse product through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +tupleT) + (@;analyse-product analyse (list/map product;right +primitives)))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true - (#e;Error error) - false))) - (test "Cannot analyse product through universal quantification." - (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +tupleT) - (@;analyse-product analyse (list/map product;right +primitives)))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - false + (#e;Error error) + false))) + (test "Cannot analyse product through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +tupleT) + (@;analyse-product analyse (list/map product;right +primitives)))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + false - (#e;Error error) - true))) - )) + (#e;Error error) + true))) + )))) (def: (check-variant-inference variantT choice size analysis) (-> Type Nat Nat (Meta [Module Scope Type la;Analysis]) Bool) @@ -241,118 +245,122 @@ false))) (context: "Tagged Sums" - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - choice (|> r;nat (:: @ map (n.% size))) - other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - #let [varT (#;Bound +1) - primitivesT (list/map product;left primitives) - [choiceT choiceC] (maybe;assume (list;nth choice primitives)) - [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) - variantT (type;variant primitivesT) - namedT (#;Named [module-name type-name] variantT) - polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) - (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT) - choice-tag (maybe;assume (list;nth choice tags)) - other-choice-tag (maybe;assume (list;nth other-choice tags))]] - ($_ seq - (test "Can infer tagged sum." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) - (test "Tagged sums specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) - (test "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (check-variant-inference polyT other-choice size))) - (test "Can specialize generic tagged sums." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type variantT - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ sumA]) - [(flatten-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag other-choice) - (bool/= last? (n.= (n.dec size) other-choice))) + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + choice (|> r;nat (:: @ map (n.% size))) + other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) + primitives (r;list size gen-primitive) + module-name (r;text +5) + type-name (r;text +5) + #let [varT (#;Bound +1) + primitivesT (list/map product;left primitives) + [choiceT choiceC] (maybe;assume (list;nth choice primitives)) + [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) + variantT (type;variant primitivesT) + namedT (#;Named [module-name type-name] variantT) + polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT) + choice-tag (maybe;assume (list;nth choice tags)) + other-choice-tag (maybe;assume (list;nth other-choice tags))]] + ($_ seq + (test "Can infer tagged sum." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (test "Tagged sums specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (check-variant-inference polyT other-choice size))) + (test "Can specialize generic tagged sums." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type variantT + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag other-choice) + (bool/= last? (n.= (n.dec size) other-choice))) - _ - false))) - )) + _ + false))) + )))) (context: "Records" - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - choice (|> r;nat (:: @ map (n.% size))) - #let [varT (#;Bound +1) - tagsC (list/map (|>. [module-name] code;tag) tags) - primitivesT (list/map product;left primitives) - primitivesC (list/map product;right primitives) - tupleT (type;tuple primitivesT) - namedT (#;Named [module-name type-name] tupleT) - recordC (list;zip2 tagsC primitivesC) - polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) - (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT)]] - ($_ seq - (test "Can infer record." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (test "Records specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (test "Can specialize generic records." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type tupleT - (@;analyse-record analyse recordC))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productA]) - [(flatten-tuple productA) - membersA]) - (n.= size (list;size membersA)) + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + primitives (r;list size gen-primitive) + module-name (r;text +5) + type-name (r;text +5) + choice (|> r;nat (:: @ map (n.% size))) + #let [varT (#;Bound +1) + tagsC (list/map (|>. [module-name] code;tag) tags) + primitivesT (list/map product;left primitives) + primitivesC (list/map product;right primitives) + tupleT (type;tuple primitivesT) + namedT (#;Named [module-name type-name] tupleT) + recordC (list;zip2 tagsC primitivesC) + polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT)]] + ($_ seq + (test "Can infer record." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Records specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Can specialize generic records." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type tupleT + (@;analyse-record analyse recordC))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ productA]) + [(flatten-tuple productA) + membersA]) + (n.= size (list;size membersA)) - _ - false))) - )) + _ + false))) + )))) diff --git a/new-luxc/test/test/luxc/analyser/type.lux b/new-luxc/test/test/luxc/analyser/type.lux index 87def3dad..eb414bf04 100644 --- a/new-luxc/test/test/luxc/analyser/type.lux +++ b/new-luxc/test/test/luxc/analyser/type.lux @@ -47,43 +47,45 @@ ))) (context: "Type checking/coercion." - [[typeC codeT exprC] check] - ($_ seq - (test (format "Can analyse type-checking.") - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-check analyse eval;eval typeC exprC)))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) - (and (type/= codeT analysisT) - (case [exprC analysisA] - (^template [ ] - [[_ ( expected)] ( actual)] - ( expected actual)) - ([#;Bool #~;Bool bool/=] - [#;Nat #~;Nat n.=] - [#;Int #~;Int i.=] - [#;Deg #~;Deg d.=] - [#;Frac #~;Frac f.=] - [#;Text #~;Text text/=]) - - _ - false)) + (<| (times +100) + (do @ + [[typeC codeT exprC] check] + ($_ seq + (test (format "Can analyse type-checking.") + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (@common;with-unknown-type + (@;analyse-check analyse eval;eval typeC exprC)))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ [analysisT analysisA]]) + (and (type/= codeT analysisT) + (case [exprC analysisA] + (^template [ ] + [[_ ( expected)] ( actual)] + ( expected actual)) + ([#;Bool #~;Bool bool/=] + [#;Nat #~;Nat n.=] + [#;Int #~;Int i.=] + [#;Deg #~;Deg d.=] + [#;Frac #~;Frac f.=] + [#;Text #~;Text text/=]) + + _ + false)) - (#e;Error error) - false))) - (test (format "Can analyse type-coercion.") - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-coerce analyse eval;eval typeC exprC)))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) - (type/= codeT analysisT) + (#e;Error error) + false))) + (test (format "Can analyse type-coercion.") + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (@common;with-unknown-type + (@;analyse-coerce analyse eval;eval typeC exprC)))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ [analysisT analysisA]]) + (type/= codeT analysisT) - (#e;Error error) - false))) - )) + (#e;Error error) + false))) + )))) diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux index ab6c0f189..86319259c 100644 --- a/new-luxc/test/test/luxc/generator/case.lux +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -74,32 +74,34 @@ )))) (context: "Pattern-matching." - #seed +17952275935008918762 - [[valueS path] gen-case - to-bind r;nat] - ($_ seq - (test "Can generate pattern-matching." - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate valueS - (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) - (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (:! Bool valueG) + (<| (seed +17952275935008918762) + ## (times +100) + (do @ + [[valueS path] gen-case + to-bind r;nat] + ($_ seq + (test "Can generate pattern-matching." + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate valueS + (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) + (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (:! Bool valueG) - _ - false))) - (test "Can bind values." - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Nat to-bind) - (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= to-bind (:! Nat valueG)) + _ + false))) + (test "Can bind values." + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Nat to-bind) + (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= to-bind (:! Nat valueG)) - _ - false))))) + _ + false))))))) diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux index 9ce59c037..dfc1230be 100644 --- a/new-luxc/test/test/luxc/generator/function.lux +++ b/new-luxc/test/test/luxc/generator/function.lux @@ -37,60 +37,62 @@ (wrap [arity arg functionS]))) (context: "Function." - [[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 (|>. #ls;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 - [runtime-bytecode @runtime;generate - sampleI (@expr;generate (#ls;Call argsS functionS))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= arg-value (:! Nat valueG)) + (<| (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 (|>. #ls;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 + [runtime-bytecode @runtime;generate + sampleI (@expr;generate (#ls;Call argsS functionS))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= arg-value (:! Nat valueG)) - (#e;Error error) - false))) - (test "Can partially apply functions." - (or (n.= +1 arity) - (|> (do meta;Monad - [#let [partial-arity (n.inc cut-off) - preS (list;take partial-arity argsS) - postS (list;drop partial-arity argsS)] - runtime-bytecode @runtime;generate - sampleI (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= arg-value (:! Nat valueG)) + (#e;Error error) + false))) + (test "Can partially apply functions." + (or (n.= +1 arity) + (|> (do meta;Monad + [#let [partial-arity (n.inc cut-off) + preS (list;take partial-arity argsS) + postS (list;drop partial-arity argsS)] + runtime-bytecode @runtime;generate + sampleI (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= arg-value (:! Nat valueG)) - (#e;Error error) - false)))) - (test "Can read environment." - (or (n.= +1 arity) - (|> (do meta;Monad - [#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 (<| (#ls;Function super-arity (list)) - (#ls;Function sub-arity env) - (#ls;Variable arg-var))] - runtime-bytecode @runtime;generate - sampleI (@expr;generate (#ls;Call argsS functionS))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= arg-value (:! Nat valueG)) + (#e;Error error) + false)))) + (test "Can read environment." + (or (n.= +1 arity) + (|> (do meta;Monad + [#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 (<| (#ls;Function super-arity (list)) + (#ls;Function sub-arity env) + (#ls;Variable arg-var))] + runtime-bytecode @runtime;generate + sampleI (@expr;generate (#ls;Call argsS functionS))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= arg-value (:! Nat valueG)) - (#e;Error error) - false)))) - )) + (#e;Error error) + false)))) + )))) diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index e8470bf5a..2e909dd7e 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -20,41 +20,43 @@ (test/luxc common)) (context: "Primitives." - [%bool% r;bool - %nat% r;nat - %int% r;int - %deg% r;deg - %frac% r;frac - %text% (r;text +5)] - (with-expansions - [ (do-template [ ] - [(test (format "Can generate " ".") - (|> (do meta;Monad - [sampleI (@;generate ( ))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) + (<| (times +100) + (do @ + [%bool% r;bool + %nat% r;nat + %int% r;int + %deg% r;deg + %frac% r;frac + %text% (r;text +5)] + (with-expansions + [ (do-template [ ] + [(test (format "Can generate " ".") + (|> (do meta;Monad + [sampleI (@;generate ( ))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( (:! valueG)) - _ - false)))] + _ + false)))] - ["bool" Bool #ls;Bool %bool% B/=] - ["nat" Nat #ls;Nat %nat% n.=] - ["int" Int #ls;Int %int% i.=] - ["deg" Deg #ls;Deg %deg% d.=] - ["frac" Frac #ls;Frac %frac% f.=] - ["text" Text #ls;Text %text% T/=])] - ($_ seq - (test "Can generate unit." - (|> (do meta;Monad - [sampleI (@;generate #ls;Unit)] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (is @runtime;unit (:! Text valueG)) + ["bool" Bool #ls;Bool %bool% B/=] + ["nat" Nat #ls;Nat %nat% n.=] + ["int" Int #ls;Int %int% i.=] + ["deg" Deg #ls;Deg %deg% d.=] + ["frac" Frac #ls;Frac %frac% f.=] + ["text" Text #ls;Text %text% T/=])] + ($_ seq + (test "Can generate unit." + (|> (do meta;Monad + [sampleI (@;generate #ls;Unit)] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (is @runtime;unit (:! Text valueG)) - _ - false))) - - ))) + _ + false))) + + ))))) 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 f617aba1e..00cfd601b 100644 --- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux @@ -25,346 +25,358 @@ (test/luxc common)) (context: "Bit procedures" - [param r;nat - subject r;nat] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure - (list (#ls;Nat subject) - (#ls;Nat param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= ( param subject) (:! Nat valueG)) - - _ - 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 - [sampleI (@;generate (#ls;Procedure "bit count" (list (#ls;Nat subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= (bit;count subject) (:! Nat valueG)) - - _ - false))) - - - (test "bit shift-right" - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure "bit shift-right" - (list (#ls;Int (nat-to-int subject)) - (#ls;Nat param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (i.= (bit;signed-shift-right param (nat-to-int subject)) - (:! Int valueG)) - - _ - false))) - ))) + (<| (times +100) + (do @ + [param r;nat + subject r;nat] + (with-expansions [ (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure + (list (#ls;Nat subject) + (#ls;Nat param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= ( param subject) (:! Nat valueG)) + + _ + 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 + [sampleI (@;generate (#ls;Procedure "bit count" (list (#ls;Nat subject))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= (bit;count subject) (:! Nat valueG)) + + _ + false))) + + + (test "bit shift-right" + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure "bit shift-right" + (list (#ls;Int (nat-to-int subject)) + (#ls;Nat param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (i.= (bit;signed-shift-right param (nat-to-int subject)) + (:! Int valueG)) + + _ + false))) + ))))) (context: "Nat procedures" - [param (|> r;nat (r;filter (|>. (n.= +0) not))) - subject r;nat] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= (:! Nat valueG)) - - _ - false)))] - - ["nat min" n/bottom] - ["nat max" n/top] - ) - (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list (#ls;Nat subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["nat to-int" Int nat-to-int i.=] - ["nat to-char" Text text;from-code text/=] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Nat subject) - (#ls;Nat param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - 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/=] - )] - ($_ seq - - - - ))) + (<| (times +100) + (do @ + [param (|> r;nat (r;filter (|>. (n.= +0) not))) + subject r;nat] + (with-expansions [ (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= (:! Nat valueG)) + + _ + false)))] + + ["nat min" n/bottom] + ["nat max" n/top] + ) + (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list (#ls;Nat subject))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( subject) (:! valueG)) + + _ + false)))] + + ["nat to-int" Int nat-to-int i.=] + ["nat to-char" Text text;from-code text/=] + ) + (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Nat subject) + (#ls;Nat param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( param subject) (:! valueG)) + + _ + 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/=] + )] + ($_ seq + + + + ))))) (context: "Int procedures" - [param (|> r;int (r;filter (|>. (i.= 0) not))) - subject r;int] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (i.= (:! Int valueG)) - - _ - false)))] - - ["int min" i/bottom] - ["int max" i/top] - ) - (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list (#ls;Int subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["int to-nat" Nat int-to-nat n.=] - ["int to-frac" Frac int-to-frac f.=] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Int subject) - (#ls;Int param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - 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 - - - - ))) + (<| (times +100) + (do @ + [param (|> r;int (r;filter (|>. (i.= 0) not))) + subject r;int] + (with-expansions [ (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (i.= (:! Int valueG)) + + _ + false)))] + + ["int min" i/bottom] + ["int max" i/top] + ) + (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list (#ls;Int subject))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( subject) (:! valueG)) + + _ + false)))] + + ["int to-nat" Nat int-to-nat n.=] + ["int to-frac" Frac int-to-frac f.=] + ) + (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Int subject) + (#ls;Int param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( param subject) (:! valueG)) + + _ + 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 + + + + ))))) (context: "Frac procedures [Part 1]" - [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) - subject r;frac] - (with-expansions [ (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Frac subject) - (#ls;Frac param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! valueG)) - - _ - 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 - - ))) + (<| (times +100) + (do @ + [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) + subject r;frac] + (with-expansions [ (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Frac subject) + (#ls;Frac param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( param subject) (:! valueG)) + + _ + 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 + + ))))) (context: "Frac procedures [Part 2]" - [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) - subject r;frac] - (with-expansions [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! Frac valueG)) - - _ - false)))] - - ["frac min" (f.= r/bottom)] - ["frac max" (f.= r/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"] []))] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure (list (#ls;Frac subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["frac to-int" Int frac-to-int i.=] - ["frac to-deg" Deg frac-to-deg d.=] - )] - ($_ seq - - - (test "frac encode|decode" - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (|> (#ls;Frac subject) - (list) (#ls;Procedure "frac encode") - (list) (#ls;Procedure "frac decode")))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success valueG) - [(:! (Maybe Frac) valueG) (#;Some value)]) - (f.= subject value) - - _ - false))) - ))) + (<| (times +100) + (do @ + [param (|> r;frac (r;filter (|>. (f.= 0.0) not))) + subject r;frac] + (with-expansions [ (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( (:! Frac valueG)) + + _ + false)))] + + ["frac min" (f.= r/bottom)] + ["frac max" (f.= r/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"] []))] + ) + (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure (list (#ls;Frac subject))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( subject) (:! valueG)) + + _ + false)))] + + ["frac to-int" Int frac-to-int i.=] + ["frac to-deg" Deg frac-to-deg d.=] + )] + ($_ seq + + + (test "frac encode|decode" + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (|> (#ls;Frac subject) + (list) (#ls;Procedure "frac encode") + (list) (#ls;Procedure "frac decode")))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success valueG) + [(:! (Maybe Frac) valueG) (#;Some value)]) + (f.= subject value) + + _ + false))) + ))))) (context: "Deg procedures" - #seed +1021167468900 - [param (|> r;deg (r;filter (|>. (d.= .0) not))) - 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 - - - - - ))) + (<| (seed +1021167468900) + ## (times +100) + (do @ + [param (|> r;deg (r;filter (|>. (d.= .0) not))) + 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 + + + + + ))))) 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 ba90a00e3..5b22bc2a1 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -25,84 +25,88 @@ (test/luxc common)) (context: "Conversions [Part 1]" - [int-sample (|> r;int (:: @ map (i.% 128))) - #let [frac-sample (int-to-frac int-sample)]] - (with-expansions [<2step> (do-template [ ] - [(test (format " / " ) - (|> (do meta;Monad - [sampleI (@;generate (|> ( ) - (list) (#ls;Procedure ) - (list) (#ls;Procedure )))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - (#e;Error error) - false)))] - - ["jvm convert double-to-float" "jvm convert float-to-double" #ls;Frac frac-sample Frac f.=] - ["jvm convert double-to-int" "jvm convert int-to-double" #ls;Frac frac-sample Frac f.=] - ["jvm convert double-to-long" "jvm convert long-to-double" #ls;Frac frac-sample Frac f.=] - - ["jvm convert long-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] - )] - ($_ seq - <2step> - ))) + (<| (times +100) + (do @ + [int-sample (|> r;int (:: @ map (i.% 128))) + #let [frac-sample (int-to-frac int-sample)]] + (with-expansions [<2step> (do-template [ ] + [(test (format " / " ) + (|> (do meta;Monad + [sampleI (@;generate (|> ( ) + (list) (#ls;Procedure ) + (list) (#ls;Procedure )))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( (:! valueG)) + + (#e;Error error) + false)))] + + ["jvm convert double-to-float" "jvm convert float-to-double" #ls;Frac frac-sample Frac f.=] + ["jvm convert double-to-int" "jvm convert int-to-double" #ls;Frac frac-sample Frac f.=] + ["jvm convert double-to-long" "jvm convert long-to-double" #ls;Frac frac-sample Frac f.=] + + ["jvm convert long-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] + )] + ($_ seq + <2step> + ))))) (context: "Conversions [Part 2]" - [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) - #let [frac-sample (int-to-frac int-sample)]] - (with-expansions [<3step> (do-template [ ] - [(test (format " / " " / " ) - (|> (do meta;Monad - [sampleI (@;generate (|> ( ) - (list) (#ls;Procedure ) - (list) (#ls;Procedure ) - (list) (#ls;Procedure )))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - (#e;Error error) - false)))] - - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=] - ) - <4step> (do-template [ ] - [(test (format " / " " / " ) - (|> (do meta;Monad - [sampleI (@;generate (|> ( ) - (list) (#ls;Procedure ) - (list) (#ls;Procedure ) - (list) (#ls;Procedure ) - (list) (#ls;Procedure )))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( (:! valueG)) - - (#e;Error error) - false)))] - - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" #ls;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" #ls;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" #ls;Int int-sample Int i.=] - ) - ] - ($_ seq - <3step> - <4step> - ))) + (<| (times +100) + (do @ + [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) + #let [frac-sample (int-to-frac int-sample)]] + (with-expansions [<3step> (do-template [ ] + [(test (format " / " " / " ) + (|> (do meta;Monad + [sampleI (@;generate (|> ( ) + (list) (#ls;Procedure ) + (list) (#ls;Procedure ) + (list) (#ls;Procedure )))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( (:! valueG)) + + (#e;Error error) + false)))] + + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=] + ) + <4step> (do-template [ ] + [(test (format " / " " / " ) + (|> (do meta;Monad + [sampleI (@;generate (|> ( ) + (list) (#ls;Procedure ) + (list) (#ls;Procedure ) + (list) (#ls;Procedure ) + (list) (#ls;Procedure )))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( (:! valueG)) + + (#e;Error error) + false)))] + + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" #ls;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" #ls;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" #ls;Int int-sample Int i.=] + ) + ] + ($_ seq + <3step> + <4step> + ))))) (def: gen-nat (r;Random Nat) @@ -120,31 +124,33 @@ (do-template [ <+> <-> <*> <%> 
 ]
   [(context: (format "Arithmetic ["  "]")
-     [param 
-      #let [subject ( param)]]
-     (with-expansions [ (do-template [ ]
-                                 [(test 
-                                        (|> (do meta;Monad
-                                              [sampleI (@;generate ( (#ls;Procedure  (list (
 ( subject))
-                                                                                                            (
 ( param))))))]
-                                              (@eval;eval sampleI))
-                                            (meta;run (init-compiler []))
-                                            (case> (#e;Success valueG)
-                                                   ( ( param subject)
-                                                           (:!  valueG))
-
-                                                   (#e;Error error)
-                                                   false)))]
-
-                                 [(format "jvm "  " +") <+>]
-                                 [(format "jvm "  " -") <->]
-                                 [(format "jvm "  " *") <*>]
-                                 [(format "jvm "  " /") ]
-                                 [(format "jvm "  " %") <%>]
-                                 )]
-       ($_ seq
-           
-           )))]
+     (<| (times +100)
+         (do @
+           [param 
+            #let [subject ( param)]]
+           (with-expansions [ (do-template [ ]
+                                       [(test 
+                                              (|> (do meta;Monad
+                                                    [sampleI (@;generate ( (#ls;Procedure  (list (
 ( subject))
+                                                                                                                  (
 ( param))))))]
+                                                    (@eval;eval sampleI))
+                                                  (meta;run (init-compiler []))
+                                                  (case> (#e;Success valueG)
+                                                         ( ( param subject)
+                                                                 (:!  valueG))
+
+                                                         (#e;Error error)
+                                                         false)))]
+
+                                       [(format "jvm "  " +") <+>]
+                                       [(format "jvm "  " -") <->]
+                                       [(format "jvm "  " *") <*>]
+                                       [(format "jvm "  " /") ]
+                                       [(format "jvm "  " %") <%>]
+                                       )]
+             ($_ seq
+                 
+                 )))))]
 
   ["int" gen-int #ls;Int Int i.= (i.* 10) i.+ i.- i.* i./ i.% (|>. (list) (#ls;Procedure "jvm convert long-to-int")) (|>. (list) (#ls;Procedure "jvm convert int-to-long"))]
   ["long" gen-int #ls;Int Int i.= (i.* 10) i.+ i.- i.* i./ i.% id id]
@@ -154,51 +160,53 @@
 
 (do-template [  ]
   [(context: (format "Bit-wise ["  "]")
-     [param gen-nat
-      subject gen-nat
-      #let [shift (n.% +10 param)]]
-     (with-expansions [ (do-template [ ]
-                                     [(test 
-                                            (|> (do meta;Monad
-                                                  [sampleI (@;generate ( (#ls;Procedure  (list ( (#ls;Nat subject))
-                                                                                                                ( (#ls;Nat param))))))]
-                                                  (@eval;eval sampleI))
-                                                (meta;run (init-compiler []))
-                                                (case> (#e;Success valueG)
-                                                       (n.= ( param subject)
-                                                            (:! Nat valueG))
-
-                                                       (#e;Error error)
-                                                       false)))]
-
-                                     [(format "jvm "  " and") bit;and]
-                                     [(format "jvm "  " or") bit;or]
-                                     [(format "jvm "  " xor") bit;xor]
-                                     )
-                        (do-template [     
]
-                                    [(test 
-                                           (|> (do meta;Monad
-                                                 [sampleI (@;generate ( (#ls;Procedure  (list ( (
 subject))
-                                                                                                               (|> (#ls;Nat shift)
-                                                                                                                   (list)
-                                                                                                                   (#ls;Procedure "jvm convert long-to-int"))))))]
-                                                 (@eval;eval sampleI))
-                                               (meta;run (init-compiler []))
-                                               (case> (#e;Success valueG)
-                                                      ( ( shift ( subject))
-                                                              (:!  valueG))
-
-                                                      (#e;Error error)
-                                                      false)))]
-
-                                    [(format "jvm "  " shl") bit;shift-left Nat n.= id #ls;Nat]
-                                    [(format "jvm "  " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int #ls;Int)]
-                                    [(format "jvm "  " ushr") bit;shift-right Nat n.= id #ls;Nat]
-                                    )]
-       ($_ seq
-           
-           
-           )))]
+     (<| (times +100)
+         (do @
+           [param gen-nat
+            subject gen-nat
+            #let [shift (n.% +10 param)]]
+           (with-expansions [ (do-template [ ]
+                                           [(test 
+                                                  (|> (do meta;Monad
+                                                        [sampleI (@;generate ( (#ls;Procedure  (list ( (#ls;Nat subject))
+                                                                                                                      ( (#ls;Nat param))))))]
+                                                        (@eval;eval sampleI))
+                                                      (meta;run (init-compiler []))
+                                                      (case> (#e;Success valueG)
+                                                             (n.= ( param subject)
+                                                                  (:! Nat valueG))
+
+                                                             (#e;Error error)
+                                                             false)))]
+
+                                           [(format "jvm "  " and") bit;and]
+                                           [(format "jvm "  " or") bit;or]
+                                           [(format "jvm "  " xor") bit;xor]
+                                           )
+                              (do-template [     
]
+                                          [(test 
+                                                 (|> (do meta;Monad
+                                                       [sampleI (@;generate ( (#ls;Procedure  (list ( (
 subject))
+                                                                                                                     (|> (#ls;Nat shift)
+                                                                                                                         (list)
+                                                                                                                         (#ls;Procedure "jvm convert long-to-int"))))))]
+                                                       (@eval;eval sampleI))
+                                                     (meta;run (init-compiler []))
+                                                     (case> (#e;Success valueG)
+                                                            ( ( shift ( subject))
+                                                                    (:!  valueG))
+
+                                                            (#e;Error error)
+                                                            false)))]
+
+                                          [(format "jvm "  " shl") bit;shift-left Nat n.= id #ls;Nat]
+                                          [(format "jvm "  " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int #ls;Int)]
+                                          [(format "jvm "  " ushr") bit;shift-right Nat n.= id #ls;Nat]
+                                          )]
+             ($_ seq
+                 
+                 
+                 )))))]
 
   ["int" (|>. (list) (#ls;Procedure "jvm convert int-to-long")) (|>. (list) (#ls;Procedure "jvm convert long-to-int"))]
   ["long" id id]
@@ -206,28 +214,30 @@
 
 (do-template [   <=> <<> 
]
   [(context: (format "Order ["  "]")
-     [param 
-      subject ]
-     (with-expansions [ (do-template [ ]
-                                 [(test 
-                                        (|> (do meta;Monad
-                                              [sampleI (@;generate (#ls;Procedure  (list (
 ( subject))
-                                                                                                    (
 ( param)))))]
-                                              (@eval;eval sampleI))
-                                            (meta;run (init-compiler []))
-                                            (case> (#e;Success valueG)
-                                                   (bool/= ( param subject)
-                                                           (:! Bool valueG))
-
-                                                   (#e;Error error)
-                                                   false)))]
-
-                                 [(format "jvm "  " =") <=>]
-                                 [(format "jvm "  " <") <<>]
-                                 )]
-       ($_ seq
-           
-           )))]
+     (<| (times +100)
+         (do @
+           [param 
+            subject ]
+           (with-expansions [ (do-template [ ]
+                                       [(test 
+                                              (|> (do meta;Monad
+                                                    [sampleI (@;generate (#ls;Procedure  (list (
 ( subject))
+                                                                                                          (
 ( param)))))]
+                                                    (@eval;eval sampleI))
+                                                  (meta;run (init-compiler []))
+                                                  (case> (#e;Success valueG)
+                                                         (bool/= ( param subject)
+                                                                 (:! Bool valueG))
+
+                                                         (#e;Error error)
+                                                         false)))]
+
+                                       [(format "jvm "  " =") <=>]
+                                       [(format "jvm "  " <") <<>]
+                                       )]
+             ($_ seq
+                 
+                 )))))]
 
   ["int" gen-int #ls;Int i.= i.< (|>. (list) (#ls;Procedure "jvm convert long-to-int"))]
   ["long" gen-int #ls;Int i.= i.< id]
@@ -238,112 +248,116 @@
   )
 
 (context: "Array [Part 1]"
-  [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 [ (do-template [     ]
-                              [(test 
-                                     (|> (do meta;Monad
-                                           [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text ) (#ls;Nat size)))
-                                                                    (list (#ls;Text ) (#ls;Nat idx) ) (#ls;Procedure "jvm array write")
-                                                                    (list (#ls;Text ) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
-                                                                    ))]
-                                           (@eval;eval sampleI))
-                                         (meta;run (init-compiler []))
-                                         (case> (#e;Success outputZ)
-                                                (  (:!  outputZ))
-
-                                                (#e;Error error)
-                                                false)))]
-
-                              ["boolean" Bool valueZ bool/= (#ls;Bool valueZ) id]
-                              ["byte" Int valueB i.= (|> (#ls;Int valueB)
-                                                         (list) (#ls;Procedure "jvm convert long-to-byte"))
-                               (<| (#ls;Procedure "jvm convert byte-to-long") (list))]
-                              ["short" Int valueS i.= (|> (#ls;Int valueS)
-                                                          (list) (#ls;Procedure "jvm convert long-to-short"))
-                               (<| (#ls;Procedure "jvm convert short-to-long") (list))]
-                              ["int" Int valueI i.= (|> (#ls;Int valueI)
-                                                        (list) (#ls;Procedure "jvm convert long-to-int"))
-                               (<| (#ls;Procedure "jvm convert int-to-long") (list))]
-                              ["long" Int valueL i.= (#ls;Int valueL) id]
-                              ["float" Frac valueF f.= (|> (#ls;Frac valueF)
-                                                           (list) (#ls;Procedure "jvm convert double-to-float"))
-                               (<| (#ls;Procedure "jvm convert float-to-double") (list))]
-                              ["double" Frac valueD f.= (#ls;Frac valueD) id]
-                              )]
-    ($_ seq
-        
-        )))
+  (<| (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 [ (do-template [     ]
+                                    [(test 
+                                           (|> (do meta;Monad
+                                                 [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text ) (#ls;Nat size)))
+                                                                          (list (#ls;Text ) (#ls;Nat idx) ) (#ls;Procedure "jvm array write")
+                                                                          (list (#ls;Text ) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
+                                                                          ))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success outputZ)
+                                                      (  (:!  outputZ))
+
+                                                      (#e;Error error)
+                                                      false)))]
+
+                                    ["boolean" Bool valueZ bool/= (#ls;Bool valueZ) id]
+                                    ["byte" Int valueB i.= (|> (#ls;Int valueB)
+                                                               (list) (#ls;Procedure "jvm convert long-to-byte"))
+                                     (<| (#ls;Procedure "jvm convert byte-to-long") (list))]
+                                    ["short" Int valueS i.= (|> (#ls;Int valueS)
+                                                                (list) (#ls;Procedure "jvm convert long-to-short"))
+                                     (<| (#ls;Procedure "jvm convert short-to-long") (list))]
+                                    ["int" Int valueI i.= (|> (#ls;Int valueI)
+                                                              (list) (#ls;Procedure "jvm convert long-to-int"))
+                                     (<| (#ls;Procedure "jvm convert int-to-long") (list))]
+                                    ["long" Int valueL i.= (#ls;Int valueL) id]
+                                    ["float" Frac valueF f.= (|> (#ls;Frac valueF)
+                                                                 (list) (#ls;Procedure "jvm convert double-to-float"))
+                                     (<| (#ls;Procedure "jvm convert float-to-double") (list))]
+                                    ["double" Frac valueD f.= (#ls;Frac valueD) id]
+                                    )]
+          ($_ seq
+              
+              )))))
 
 (context: "Array [Part 2]"
-  [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 [ (do-template [     ]
-                              [(test 
-                                     (|> (do meta;Monad
-                                           [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text ) (#ls;Nat size)))
-                                                                    (list (#ls;Text ) (#ls;Nat idx) ) (#ls;Procedure "jvm array write")
-                                                                    (list (#ls;Text ) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
-                                                                    ))]
-                                           (@eval;eval sampleI))
-                                         (meta;run (init-compiler []))
-                                         (case> (#e;Success outputG)
-                                                (  (:!  outputG))
-
-                                                (#e;Error error)
-                                                false)))]
-
-                              ["char" Int valueC i.= (|> (#ls;Int valueC)
-                                                         (list) (#ls;Procedure "jvm convert long-to-int")
-                                                         (list) (#ls;Procedure "jvm convert int-to-char"))
-                               (<| (#ls;Procedure "jvm convert char-to-long") (list))]
-                              ["java.lang.Long" Int valueL i.= (#ls;Int valueL) id]
-                              )]
-    ($_ seq
-        
-        (test "java.lang.Double (level 1)"
-              (|> (do meta;Monad
-                    [#let [inner (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Double") (#ls;Nat size)))
-                                     (list (#ls;Text "java.lang.Double") (#ls;Nat idx) (#ls;Frac valueD)) (#ls;Procedure "jvm array write"))]
-                     sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +1) (#ls;Text "java.lang.Double") (#ls;Nat size)))
-                                             (list (#ls;Text "#Array") (#ls;Nat idx) inner) (#ls;Procedure "jvm array write")
-                                             (list (#ls;Text "#Array") (#ls;Nat idx)) (#ls;Procedure "jvm array read")
-                                             (list (#ls;Text "java.lang.Double") (#ls;Nat idx)) (#ls;Procedure "jvm array read")))]
-                    (@eval;eval sampleI))
-                  (meta;run (init-compiler []))
-                  (case> (#e;Success outputG)
-                         (f.= valueD (:! Frac outputG))
-
-                         (#e;Error error)
-                         false)))
-        (test "jvm array length"
-              (|> (do meta;Monad
-                    [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Object") (#ls;Nat size)))
-                                             (list) (#ls;Procedure "jvm array length")))]
-                    (@eval;eval sampleI))
-                  (meta;run (init-compiler []))
-                  (case> (#e;Success outputG)
-                         (n.= size (:! Nat outputG))
-
-                         (#e;Error error)
-                         false)))
-        )))
+  (<| (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 [ (do-template [     ]
+                                    [(test 
+                                           (|> (do meta;Monad
+                                                 [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text ) (#ls;Nat size)))
+                                                                          (list (#ls;Text ) (#ls;Nat idx) ) (#ls;Procedure "jvm array write")
+                                                                          (list (#ls;Text ) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
+                                                                          ))]
+                                                 (@eval;eval sampleI))
+                                               (meta;run (init-compiler []))
+                                               (case> (#e;Success outputG)
+                                                      (  (:!  outputG))
+
+                                                      (#e;Error error)
+                                                      false)))]
+
+                                    ["char" Int valueC i.= (|> (#ls;Int valueC)
+                                                               (list) (#ls;Procedure "jvm convert long-to-int")
+                                                               (list) (#ls;Procedure "jvm convert int-to-char"))
+                                     (<| (#ls;Procedure "jvm convert char-to-long") (list))]
+                                    ["java.lang.Long" Int valueL i.= (#ls;Int valueL) id]
+                                    )]
+          ($_ seq
+              
+              (test "java.lang.Double (level 1)"
+                    (|> (do meta;Monad
+                          [#let [inner (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Double") (#ls;Nat size)))
+                                           (list (#ls;Text "java.lang.Double") (#ls;Nat idx) (#ls;Frac valueD)) (#ls;Procedure "jvm array write"))]
+                           sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +1) (#ls;Text "java.lang.Double") (#ls;Nat size)))
+                                                   (list (#ls;Text "#Array") (#ls;Nat idx) inner) (#ls;Procedure "jvm array write")
+                                                   (list (#ls;Text "#Array") (#ls;Nat idx)) (#ls;Procedure "jvm array read")
+                                                   (list (#ls;Text "java.lang.Double") (#ls;Nat idx)) (#ls;Procedure "jvm array read")))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success outputG)
+                               (f.= valueD (:! Frac outputG))
+
+                               (#e;Error error)
+                               false)))
+              (test "jvm array length"
+                    (|> (do meta;Monad
+                          [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Object") (#ls;Nat size)))
+                                                   (list) (#ls;Procedure "jvm array length")))]
+                          (@eval;eval sampleI))
+                        (meta;run (init-compiler []))
+                        (case> (#e;Success outputG)
+                               (n.= size (:! Nat outputG))
+
+                               (#e;Error error)
+                               false)))
+              )))))
 
 (host;import java.lang.Class
   (getName [] String))
@@ -369,74 +383,76 @@
                                                   gen-string))])))
 
 (context: "Object."
-  [#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)))
-   #let [class (maybe;assume (list;nth class-idx classes))
-         [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))]
-   sample r;int
-   monitor r;int
-   instance instance-gen]
-  ($_ seq
-      (test "jvm object null"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (|> (#ls;Procedure "jvm object null" (list))
-                                           (list) (#ls;Procedure "jvm object null?")))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (:! Bool outputG)
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm object null?"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (|> (#ls;Int sample)
-                                           (list) (#ls;Procedure "jvm object null?")))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (not (:! Bool outputG))
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm object synchronized"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (#ls;Procedure "jvm object synchronized"
-                                                      (list (#ls;Int monitor)
-                                                            (#ls;Int sample))))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (i.= sample (:! Int outputG))
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm object throw"
-            false)
-      (test "jvm object class"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (|> outputG (:! Class) (Class.getName []) (text/= class))
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm object instance?"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (#ls;Procedure "jvm object instance?" (list (#ls;Text instance-class)
-                                                                                   instance)))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (:! Bool outputG)
-
-                       (#e;Error error)
-                       false)))
-      ))
+  (<| (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)))
+         #let [class (maybe;assume (list;nth class-idx classes))
+               [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))]
+         sample r;int
+         monitor r;int
+         instance instance-gen]
+        ($_ seq
+            (test "jvm object null"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (|> (#ls;Procedure "jvm object null" (list))
+                                                 (list) (#ls;Procedure "jvm object null?")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (:! Bool outputG)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object null?"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (|> (#ls;Int sample)
+                                                 (list) (#ls;Procedure "jvm object null?")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (not (:! Bool outputG))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object synchronized"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (#ls;Procedure "jvm object synchronized"
+                                                            (list (#ls;Int monitor)
+                                                                  (#ls;Int sample))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (i.= sample (:! Int outputG))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object throw"
+                  false)
+            (test "jvm object class"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (|> outputG (:! Class) (Class.getName []) (text/= class))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm object instance?"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (#ls;Procedure "jvm object instance?" (list (#ls;Text instance-class)
+                                                                                         instance)))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (:! Bool outputG)
+
+                             (#e;Error error)
+                             false)))
+            ))))
 
 (host;import java.util.GregorianCalendar
   (#static AD int))
@@ -476,68 +492,70 @@
 (host;import (java.util.ArrayList a))
 
 (context: "Member [Method]"
-  [sample (|> r;int (:: @ map (|>. int/abs (i.% 100))))
-   #let [object-longS (|> (#ls;Int sample)
-                          (list (#ls;Text "java.lang.Object")) #ls;Tuple)
-         intS (|> (#ls;Int sample)
-                  (list) (#ls;Procedure "jvm convert long-to-int")
-                  (list (#ls;Text "int")) #ls;Tuple)
-         coded-intS (|> (#ls;Text (int/encode sample))
-                        (list (#ls;Text "java.lang.String")) #ls;Tuple)
-         array-listS (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.util.ArrayList") intS))]]
-  ($_ seq
-      (test "jvm member invoke static"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (#ls;Procedure "jvm member invoke static"
-                                                      (list (#ls;Text "java.lang.Long")
-                                                            (#ls;Text "decode")
-                                                            (#ls;Text "java.lang.Long")
-                                                            coded-intS)))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (i.= sample (:! Int outputG))
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm member invoke virtual"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (|> object-longS
-                                           (list (#ls;Text "java.lang.Object")
-                                                 (#ls;Text "equals")
-                                                 (#ls;Text "boolean")
-                                                 (#ls;Int sample))
-                                           (#ls;Procedure "jvm member invoke virtual")))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (:! Bool outputG)
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm member invoke interface"
-            (|> (do meta;Monad
-                  [sampleI (@;generate (#ls;Procedure "jvm member invoke interface"
-                                                      (list (#ls;Text "java.util.Collection")
-                                                            (#ls;Text "add")
-                                                            (#ls;Text "boolean")
-                                                            array-listS
-                                                            object-longS)))]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (:! Bool outputG)
-
-                       (#e;Error error)
-                       false)))
-      (test "jvm member invoke constructor"
-            (|> (do meta;Monad
-                  [sampleI (@;generate array-listS)]
-                  (@eval;eval sampleI))
-                (meta;run (init-compiler []))
-                (case> (#e;Success outputG)
-                       (host;instance? ArrayList (:! Object outputG))
-
-                       (#e;Error error)
-                       false)))
-      ))
+  (<| (times +100)
+      (do @
+        [sample (|> r;int (:: @ map (|>. int/abs (i.% 100))))
+         #let [object-longS (|> (#ls;Int sample)
+                                (list (#ls;Text "java.lang.Object")) #ls;Tuple)
+               intS (|> (#ls;Int sample)
+                        (list) (#ls;Procedure "jvm convert long-to-int")
+                        (list (#ls;Text "int")) #ls;Tuple)
+               coded-intS (|> (#ls;Text (int/encode sample))
+                              (list (#ls;Text "java.lang.String")) #ls;Tuple)
+               array-listS (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.util.ArrayList") intS))]]
+        ($_ seq
+            (test "jvm member invoke static"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (#ls;Procedure "jvm member invoke static"
+                                                            (list (#ls;Text "java.lang.Long")
+                                                                  (#ls;Text "decode")
+                                                                  (#ls;Text "java.lang.Long")
+                                                                  coded-intS)))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (i.= sample (:! Int outputG))
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member invoke virtual"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (|> object-longS
+                                                 (list (#ls;Text "java.lang.Object")
+                                                       (#ls;Text "equals")
+                                                       (#ls;Text "boolean")
+                                                       (#ls;Int sample))
+                                                 (#ls;Procedure "jvm member invoke virtual")))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (:! Bool outputG)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member invoke interface"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate (#ls;Procedure "jvm member invoke interface"
+                                                            (list (#ls;Text "java.util.Collection")
+                                                                  (#ls;Text "add")
+                                                                  (#ls;Text "boolean")
+                                                                  array-listS
+                                                                  object-longS)))]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (:! Bool outputG)
+
+                             (#e;Error error)
+                             false)))
+            (test "jvm member invoke constructor"
+                  (|> (do meta;Monad
+                        [sampleI (@;generate array-listS)]
+                        (@eval;eval sampleI))
+                      (meta;run (init-compiler []))
+                      (case> (#e;Success outputG)
+                             (host;instance? ArrayList (:! Object outputG))
+
+                             (#e;Error error)
+                             false)))
+            ))))
diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux
index a5a3e66a9..927ff9ec8 100644
--- a/new-luxc/test/test/luxc/generator/structure.lux
+++ b/new-luxc/test/test/luxc/generator/structure.lux
@@ -61,46 +61,50 @@
     ))
 
 (context: "Tuples."
-  [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
-   members (r;list size gen-primitive)]
-  (test "Can generate tuple."
-        (|> (do meta;Monad
-              [sampleI (@;generate (#ls;Tuple members))]
-              (@eval;eval sampleI))
-            (meta;run (init-compiler []))
-            (case> (#e;Success valueG)
-                   (let [valueG (:! (Array Top) valueG)]
-                     (and (n.= size (array;size valueG))
-                          (list;every? corresponds? (list;zip2 members (array;to-list valueG)))))
+  (<| (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
+                    [sampleI (@;generate (#ls;Tuple members))]
+                    (@eval;eval sampleI))
+                  (meta;run (init-compiler []))
+                  (case> (#e;Success valueG)
+                         (let [valueG (:! (Array Top) valueG)]
+                           (and (n.= size (array;size valueG))
+                                (list;every? corresponds? (list;zip2 members (array;to-list valueG)))))
 
-                   _
-                   false))))
+                         _
+                         false))))))
 
 (context: "Variants."
-  [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 Monad
-              [runtime-bytecode @runtime;generate
-               sampleI (@;generate (#ls;Variant tag last? member))]
-              (@eval;eval sampleI))
-            (meta;run (init-compiler []))
-            (case> (#e;Success valueG)
-                   (let [valueG (:! (Array Top) valueG)]
-                     (and (n.= +3 (array;size valueG))
-                          (let [_tag (:! Integer (maybe;assume (array;read +0 valueG)))
-                                _last? (array;read +1 valueG)
-                                _value (:! Top (maybe;assume (array;read +2 valueG)))]
-                            (and (n.= tag (|> _tag host;i2l int-to-nat))
-                                 (case _last?
-                                   (#;Some _last?')
-                                   (and last? (text/= "" (:! Text _last?')))
+  (<| (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 Monad
+                    [runtime-bytecode @runtime;generate
+                     sampleI (@;generate (#ls;Variant tag last? member))]
+                    (@eval;eval sampleI))
+                  (meta;run (init-compiler []))
+                  (case> (#e;Success valueG)
+                         (let [valueG (:! (Array Top) valueG)]
+                           (and (n.= +3 (array;size valueG))
+                                (let [_tag (:! Integer (maybe;assume (array;read +0 valueG)))
+                                      _last? (array;read +1 valueG)
+                                      _value (:! Top (maybe;assume (array;read +2 valueG)))]
+                                  (and (n.= tag (|> _tag host;i2l int-to-nat))
+                                       (case _last?
+                                         (#;Some _last?')
+                                         (and last? (text/= "" (:! Text _last?')))
 
-                                   #;None
-                                   (not last?))
-                                 (corresponds? [member _value])))))
+                                         #;None
+                                         (not last?))
+                                       (corresponds? [member _value])))))
 
-                   _
-                   false))))
+                         _
+                         false))))))
diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux
index ca980aa87..576a48ea3 100644
--- a/new-luxc/test/test/luxc/parser.lux
+++ b/new-luxc/test/test/luxc/parser.lux
@@ -74,51 +74,57 @@
                    composite^))))))
 
 (context: "Lux code parser."
-  #seed +15545773516740647407
-  [sample code^]
-  (test "Can parse Lux code."
-        (case (&;parse [default-cursor (code;to-text sample)])
-          (#e;Error error)
-          false
+  (<| (seed +15545773516740647407)
+      ## (times +100)
+      (do @
+        [sample code^]
+        (test "Can parse Lux code."
+              (case (&;parse [default-cursor (code;to-text sample)])
+                (#e;Error error)
+                false
 
-          (#e;Success [_ parsed])
-          (:: code;Eq = parsed sample))
-        ))
+                (#e;Success [_ parsed])
+                (:: code;Eq = parsed sample))
+              ))))
 
 (def: nat-to-frac
   (-> Nat Frac)
   (|>. nat-to-int int-to-frac))
 
 (context: "Frac special syntax."
-  [numerator (|> r;nat (:: @ map (|>. (n.% +100) nat-to-frac)))
-   denominator (|> r;nat (:: @ map (|>. (n.% +100) (n.max +1) nat-to-frac)))
-   signed? r;bool
-   #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]]
-  (test "Can parse frac ratio syntax."
-        (case (&;parse [default-cursor
-                        (format (if signed? "-" "")
-                                (%i (frac-to-int numerator))
-                                "/"
-                                (%i (frac-to-int denominator)))])
-          (#e;Success [_ [_ (#;Frac actual)]])
-          (f.= expected actual)
-
-          _
-          false)
-        ))
+  (<| (times +100)
+      (do @
+        [numerator (|> r;nat (:: @ map (|>. (n.% +100) nat-to-frac)))
+         denominator (|> r;nat (:: @ map (|>. (n.% +100) (n.max +1) nat-to-frac)))
+         signed? r;bool
+         #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]]
+        (test "Can parse frac ratio syntax."
+              (case (&;parse [default-cursor
+                              (format (if signed? "-" "")
+                                      (%i (frac-to-int numerator))
+                                      "/"
+                                      (%i (frac-to-int denominator)))])
+                (#e;Success [_ [_ (#;Frac actual)]])
+                (f.= expected actual)
+
+                _
+                false)
+              ))))
 
 (context: "Nat special syntax."
-  #seed +8051810494442953019
-  [expected (|> r;nat (:: @ map (n.% +1_000)))]
-  (test "Can parse nat char syntax."
-        (case (&;parse [default-cursor
-                        (format "#\"" (text;from-code expected) "\"")])
-          (#e;Success [_ [_ (#;Nat actual)]])
-          (n.= expected actual)
-
-          _
-          false)
-        ))
+  (<| (seed +8051810494442953019)
+      ## (times +100)
+      (do @
+        [expected (|> r;nat (:: @ map (n.% +1_000)))]
+        (test "Can parse nat char syntax."
+              (case (&;parse [default-cursor
+                              (format "#\"" (text;from-code expected) "\"")])
+                (#e;Success [_ [_ (#;Nat actual)]])
+                (n.= expected actual)
+
+                _
+                false)
+              ))))
 
 (def: comment-text^
   (r;Random Text)
@@ -143,70 +149,72 @@
                        (wrap (format "#( " comment " )#")))))))
 
 (context: "Multi-line text & comments."
-  #seed +709318929887591337
-  [#let [char-gen (|> r;nat (r;filter (function [value]
-                                        (not (or (text;space? value)
-                                                 (n.= (char "\"") value))))))]
-   x char-gen
-   y char-gen
-   z char-gen
-   offset-size (|> r;nat (r/map (|>. (n.% +10) (n.max +1))))
-   #let [offset (text;join-with "" (list;repeat offset-size " "))]
-   sample code^
-   comment comment^
-   unbalanced-comment comment-text^]
-  ($_ seq
-      (test "Will reject invalid multi-line text."
-            (let [bad-match (format (text;from-code x) "\n"
-                                    (text;from-code y) "\n"
-                                    (text;from-code z))]
-              (case (&;parse [default-cursor
-                              (format "\"" bad-match "\"")])
-                (#e;Error error)
-                true
-
-                (#e;Success [_ parsed])
-                false)))
-      (test "Will accept valid multi-line text"
-            (let [good-input (format (text;from-code x) "\n"
-                                     offset (text;from-code y) "\n"
-                                     offset (text;from-code z))
-                  good-output (format (text;from-code x) "\n"
-                                      (text;from-code y) "\n"
-                                      (text;from-code z))]
-              (case (&;parse [(|> default-cursor
-                                  (update@ #;column (n.+ (n.dec offset-size))))
-                              (format "\"" good-input "\"")])
-                (#e;Error error)
-                false
-
-                (#e;Success [_ parsed])
-                (:: code;Eq =
-                    parsed
-                    (code;text good-output)))))
-      (test "Can handle comments."
-            (case (&;parse [default-cursor
-                            (format comment (code;to-text sample))])
-              (#e;Error error)
-              false
-
-              (#e;Success [_ parsed])
-              (:: code;Eq = parsed sample)))
-      (test "Will reject unbalanced multi-line comments."
-            (and (case (&;parse [default-cursor
-                                 (format "#(" "#(" unbalanced-comment ")#"
-                                         (code;to-text sample))])
-                   (#e;Error error)
-                   true
-
-                   (#e;Success [_ parsed])
-                   false)
-                 (case (&;parse [default-cursor
-                                 (format "#(" unbalanced-comment ")#" ")#"
-                                         (code;to-text sample))])
-                   (#e;Error error)
-                   true
-
-                   (#e;Success [_ parsed])
-                   false)))
-      ))
+  (<| (seed +709318929887591337)
+      ## (times +100)
+      (do @
+        [#let [char-gen (|> r;nat (r;filter (function [value]
+                                              (not (or (text;space? value)
+                                                       (n.= (char "\"") value))))))]
+         x char-gen
+         y char-gen
+         z char-gen
+         offset-size (|> r;nat (r/map (|>. (n.% +10) (n.max +1))))
+         #let [offset (text;join-with "" (list;repeat offset-size " "))]
+         sample code^
+         comment comment^
+         unbalanced-comment comment-text^]
+        ($_ seq
+            (test "Will reject invalid multi-line text."
+                  (let [bad-match (format (text;from-code x) "\n"
+                                          (text;from-code y) "\n"
+                                          (text;from-code z))]
+                    (case (&;parse [default-cursor
+                                    (format "\"" bad-match "\"")])
+                      (#e;Error error)
+                      true
+
+                      (#e;Success [_ parsed])
+                      false)))
+            (test "Will accept valid multi-line text"
+                  (let [good-input (format (text;from-code x) "\n"
+                                           offset (text;from-code y) "\n"
+                                           offset (text;from-code z))
+                        good-output (format (text;from-code x) "\n"
+                                            (text;from-code y) "\n"
+                                            (text;from-code z))]
+                    (case (&;parse [(|> default-cursor
+                                        (update@ #;column (n.+ (n.dec offset-size))))
+                                    (format "\"" good-input "\"")])
+                      (#e;Error error)
+                      false
+
+                      (#e;Success [_ parsed])
+                      (:: code;Eq =
+                          parsed
+                          (code;text good-output)))))
+            (test "Can handle comments."
+                  (case (&;parse [default-cursor
+                                  (format comment (code;to-text sample))])
+                    (#e;Error error)
+                    false
+
+                    (#e;Success [_ parsed])
+                    (:: code;Eq = parsed sample)))
+            (test "Will reject unbalanced multi-line comments."
+                  (and (case (&;parse [default-cursor
+                                       (format "#(" "#(" unbalanced-comment ")#"
+                                               (code;to-text sample))])
+                         (#e;Error error)
+                         true
+
+                         (#e;Success [_ parsed])
+                         false)
+                       (case (&;parse [default-cursor
+                                       (format "#(" unbalanced-comment ")#" ")#"
+                                               (code;to-text sample))])
+                         (#e;Error error)
+                         true
+
+                         (#e;Success [_ parsed])
+                         false)))
+            ))))
diff --git a/new-luxc/test/test/luxc/synthesizer/case/special.lux b/new-luxc/test/test/luxc/synthesizer/case/special.lux
index 112546883..b369eb532 100644
--- a/new-luxc/test/test/luxc/synthesizer/case/special.lux
+++ b/new-luxc/test/test/luxc/synthesizer/case/special.lux
@@ -17,50 +17,56 @@
   (../.. common))
 
 (context: "Dummy variables."
-  [maskedA gen-primitive
-   temp r;nat
-   #let [maskA (#la;Case maskedA
-                         (list [(#la;BindP temp)
-                                (#la;Variable (#;Local temp))]))]]
-  (test "Dummy variables created to mask expressions get eliminated during synthesis."
-        (|> (synthesizer;synthesize maskA)
-            (corresponds? maskedA))))
+  (<| (times +100)
+      (do @
+        [maskedA gen-primitive
+         temp r;nat
+         #let [maskA (#la;Case maskedA
+                               (list [(#la;BindP temp)
+                                      (#la;Variable (#;Local temp))]))]]
+        (test "Dummy variables created to mask expressions get eliminated during synthesis."
+              (|> (synthesizer;synthesize maskA)
+                  (corresponds? maskedA))))))
 
 (context: "Let expressions."
-  [registerA r;nat
-   inputA gen-primitive
-   outputA gen-primitive
-   #let [letA (#la;Case inputA
-                        (list [(#la;BindP registerA)
-                               outputA]))]]
-  (test "Can detect and reify simple 'let' expressions."
-        (|> (synthesizer;synthesize letA)
-            (case> (#ls;Let registerS inputS outputS)
-                   (and (n.= registerA registerS)
-                        (corresponds? inputA inputS)
-                        (corresponds? outputA outputS))
+  (<| (times +100)
+      (do @
+        [registerA r;nat
+         inputA gen-primitive
+         outputA gen-primitive
+         #let [letA (#la;Case inputA
+                              (list [(#la;BindP registerA)
+                                     outputA]))]]
+        (test "Can detect and reify simple 'let' expressions."
+              (|> (synthesizer;synthesize letA)
+                  (case> (#ls;Let registerS inputS outputS)
+                         (and (n.= registerA registerS)
+                              (corresponds? inputA inputS)
+                              (corresponds? outputA outputS))
 
-                   _
-                   false))))
+                         _
+                         false))))))
 
 (context: "If expressions."
-  [then|else r;bool
-   inputA gen-primitive
-   thenA gen-primitive
-   elseA gen-primitive
-   #let [ifA (if then|else
-               (#la;Case inputA
-                         (list [(#la;BoolP true) thenA]
-                               [(#la;BoolP false) elseA]))
-               (#la;Case inputA
-                         (list [(#la;BoolP false) elseA]
-                               [(#la;BoolP true) thenA])))]]
-  (test "Can detect and reify simple 'if' expressions."
-        (|> (synthesizer;synthesize ifA)
-            (case> (#ls;If inputS thenS elseS)
-                   (and (corresponds? inputA inputS)
-                        (corresponds? thenA thenS)
-                        (corresponds? elseA elseS))
+  (<| (times +100)
+      (do @
+        [then|else r;bool
+         inputA gen-primitive
+         thenA gen-primitive
+         elseA gen-primitive
+         #let [ifA (if then|else
+                     (#la;Case inputA
+                               (list [(#la;BoolP true) thenA]
+                                     [(#la;BoolP false) elseA]))
+                     (#la;Case inputA
+                               (list [(#la;BoolP false) elseA]
+                                     [(#la;BoolP true) thenA])))]]
+        (test "Can detect and reify simple 'if' expressions."
+              (|> (synthesizer;synthesize ifA)
+                  (case> (#ls;If inputS thenS elseS)
+                         (and (corresponds? inputA inputS)
+                              (corresponds? thenA thenS)
+                              (corresponds? elseA elseS))
 
-                   _
-                   false))))
+                         _
+                         false))))))
diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux
index c97f2f0fc..40aef8c3b 100644
--- a/new-luxc/test/test/luxc/synthesizer/function.lux
+++ b/new-luxc/test/test/luxc/synthesizer/function.lux
@@ -106,51 +106,55 @@
                (#la;Variable (#;Local chosen))])))))
 
 (context: "Function definition."
-  [[args1 prediction1 function1] gen-function//constant
-   [args2 prediction2 function2] gen-function//captured
-   [args3 prediction3 function3] gen-function//local]
-  ($_ seq
-      (test "Nested functions will get folded together."
-            (|> (synthesizer;synthesize function1)
-                (case> (#ls;Function args captured output)
-                       (and (n.= args1 args)
-                            (corresponds? prediction1 output))
-                       
-                       _
-                       (n.= +0 args1))))
-      (test "Folded functions provide direct access to captured variables."
-            (|> (synthesizer;synthesize function2)
-                (case> (#ls;Function args captured (#ls;Variable output))
-                       (and (n.= args2 args)
-                            (i.= prediction2 output))
-                       
-                       _
-                       false)))
-      (test "Folded functions properly offset local variables."
-            (|> (synthesizer;synthesize function3)
-                (case> (#ls;Function args captured (#ls;Variable output))
-                       (and (n.= args3 args)
-                            (i.= prediction3 output))
-                       
-                       _
-                       false)))
-      ))
+  (<| (times +100)
+      (do @
+        [[args1 prediction1 function1] gen-function//constant
+         [args2 prediction2 function2] gen-function//captured
+         [args3 prediction3 function3] gen-function//local]
+        ($_ seq
+            (test "Nested functions will get folded together."
+                  (|> (synthesizer;synthesize function1)
+                      (case> (#ls;Function args captured output)
+                             (and (n.= args1 args)
+                                  (corresponds? prediction1 output))
+                             
+                             _
+                             (n.= +0 args1))))
+            (test "Folded functions provide direct access to captured variables."
+                  (|> (synthesizer;synthesize function2)
+                      (case> (#ls;Function args captured (#ls;Variable output))
+                             (and (n.= args2 args)
+                                  (i.= prediction2 output))
+                             
+                             _
+                             false)))
+            (test "Folded functions properly offset local variables."
+                  (|> (synthesizer;synthesize function3)
+                      (case> (#ls;Function args captured (#ls;Variable output))
+                             (and (n.= args3 args)
+                                  (i.= prediction3 output))
+                             
+                             _
+                             false)))
+            ))))
 
 (context: "Function application."
-  [num-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
-   funcA gen-primitive
-   argsA (r;list num-args gen-primitive)]
-  ($_ seq
-      (test "Can synthesize function application."
-            (|> (synthesizer;synthesize (la;apply argsA funcA))
-                (case> (#ls;Call argsS funcS)
-                       (and (corresponds? funcA funcS)
-                            (list;every? (product;uncurry corresponds?)
-                                         (list;zip2 argsA argsS)))
-                       
-                       _
-                       false)))
-      (test "Function application on no arguments just synthesizes to the function itself."
-            (|> (synthesizer;synthesize (la;apply (list) funcA))
-                (corresponds? funcA)))
-      ))
+  (<| (times +100)
+      (do @
+        [num-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+         funcA gen-primitive
+         argsA (r;list num-args gen-primitive)]
+        ($_ seq
+            (test "Can synthesize function application."
+                  (|> (synthesizer;synthesize (la;apply argsA funcA))
+                      (case> (#ls;Call argsS funcS)
+                             (and (corresponds? funcA funcS)
+                                  (list;every? (product;uncurry corresponds?)
+                                               (list;zip2 argsA argsS)))
+                             
+                             _
+                             false)))
+            (test "Function application on no arguments just synthesizes to the function itself."
+                  (|> (synthesizer;synthesize (la;apply (list) funcA))
+                      (corresponds? funcA)))
+            ))))
diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux
index 849df78d4..9b048242d 100644
--- a/new-luxc/test/test/luxc/synthesizer/loop.lux
+++ b/new-luxc/test/test/luxc/synthesizer/loop.lux
@@ -135,30 +135,34 @@
            (make-function arity bodyS)])))
 
 (context: "Recursion."
-  [[prediction arity analysis] gen-recursion]
-  ($_ seq
-      (test "Can accurately identify (and then reify) tail recursion."
-            (case (synthesizer;synthesize analysis)
-              (#ls;Function _arity _env _body)
-              (|> _body
-                  (does-recursion? arity)
-                  (B/= prediction)
-                  (and (n.= arity _arity)))
-
-              _
-              false))))
+  (<| (times +100)
+      (do @
+        [[prediction arity analysis] gen-recursion]
+        ($_ seq
+            (test "Can accurately identify (and then reify) tail recursion."
+                  (case (synthesizer;synthesize analysis)
+                    (#ls;Function _arity _env _body)
+                    (|> _body
+                        (does-recursion? arity)
+                        (B/= prediction)
+                        (and (n.= arity _arity)))
+
+                    _
+                    false))))))
 
 (context: "Loop."
-  [[prediction arity analysis] gen-recursion]
-  ($_ seq
-      (test "Can reify loops."
-            (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit)))
-              (#ls;Loop _register _inits _body)
-              (and (n.= arity (list;size _inits))
-                   (not (&&loop;contains-self-reference? _body)))
-
-              (#ls;Call argsS (#ls;Function _arity _env _bodyS))
-              (&&loop;contains-self-reference? _bodyS)
-
-              _
-              false))))
+  (<| (times +100)
+      (do @
+        [[prediction arity analysis] gen-recursion]
+        ($_ seq
+            (test "Can reify loops."
+                  (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit)))
+                    (#ls;Loop _register _inits _body)
+                    (and (n.= arity (list;size _inits))
+                         (not (&&loop;contains-self-reference? _body)))
+
+                    (#ls;Call argsS (#ls;Function _arity _env _bodyS))
+                    (&&loop;contains-self-reference? _bodyS)
+
+                    _
+                    false))))))
diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux
index 713e28cd1..a7fb6913e 100644
--- a/new-luxc/test/test/luxc/synthesizer/primitive.lux
+++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux
@@ -12,28 +12,30 @@
         [synthesizer]))
 
 (context: "Primitives"
-  [%bool% r;bool
-   %nat% r;nat
-   %int% r;int
-   %deg% r;deg
-   %frac% r;frac
-   %text% (r;text +5)]
-  (with-expansions
-    [ (do-template [   ]
-               [(test (format "Can synthesize "  ".")
-                      (|> (synthesizer;synthesize ( ))
-                          (case> ( value)
-                                 (is  value)
+  (<| (times +100)
+      (do @
+        [%bool% r;bool
+         %nat% r;nat
+         %int% r;int
+         %deg% r;deg
+         %frac% r;frac
+         %text% (r;text +5)]
+        (with-expansions
+          [ (do-template [   ]
+                     [(test (format "Can synthesize "  ".")
+                            (|> (synthesizer;synthesize ( ))
+                                (case> ( value)
+                                       (is  value)
 
-                                 _
-                                 false)))]
+                                       _
+                                       false)))]
 
-               ["unit" #la;Unit #ls;Unit []]
-               ["bool" #la;Bool #ls;Bool %bool%]
-               ["nat"  #la;Nat  #ls;Nat  %nat%]
-               ["int"  #la;Int  #ls;Int  %int%]
-               ["deg"  #la;Deg  #ls;Deg  %deg%]
-               ["frac" #la;Frac #ls;Frac %frac%]
-               ["text" #la;Text #ls;Text %text%])]
-    ($_ seq
-        )))
+                     ["unit" #la;Unit #ls;Unit []]
+                     ["bool" #la;Bool #ls;Bool %bool%]
+                     ["nat"  #la;Nat  #ls;Nat  %nat%]
+                     ["int"  #la;Int  #ls;Int  %int%]
+                     ["deg"  #la;Deg  #ls;Deg  %deg%]
+                     ["frac" #la;Frac #ls;Frac %frac%]
+                     ["text" #la;Text #ls;Text %text%])]
+          ($_ seq
+              )))))
diff --git a/new-luxc/test/test/luxc/synthesizer/procedure.lux b/new-luxc/test/test/luxc/synthesizer/procedure.lux
index b7560ec1c..54f1b1f27 100644
--- a/new-luxc/test/test/luxc/synthesizer/procedure.lux
+++ b/new-luxc/test/test/luxc/synthesizer/procedure.lux
@@ -16,17 +16,19 @@
   (.. common))
 
 (context: "Procedures"
-  [num-args (|> r;nat (:: @ map (n.% +10)))
-   nameA (r;text +5)
-   argsA (r;list num-args gen-primitive)]
-  ($_ seq
-      (test "Can synthesize procedure calls."
-            (|> (synthesizer;synthesize (#la;Procedure nameA argsA))
-                (case> (#ls;Procedure nameS argsS)
-                       (and (T/= nameA nameS)
-                            (list;every? (product;uncurry corresponds?)
-                                         (list;zip2 argsA argsS)))
-                       
-                       _
-                       false)))
-      ))
+  (<| (times +100)
+      (do @
+        [num-args (|> r;nat (:: @ map (n.% +10)))
+         nameA (r;text +5)
+         argsA (r;list num-args gen-primitive)]
+        ($_ seq
+            (test "Can synthesize procedure calls."
+                  (|> (synthesizer;synthesize (#la;Procedure nameA argsA))
+                      (case> (#ls;Procedure nameS argsS)
+                             (and (T/= nameA nameS)
+                                  (list;every? (product;uncurry corresponds?)
+                                               (list;zip2 argsA argsS)))
+                             
+                             _
+                             false)))
+            ))))
diff --git a/new-luxc/test/test/luxc/synthesizer/structure.lux b/new-luxc/test/test/luxc/synthesizer/structure.lux
index 8cc61d02f..441f422bb 100644
--- a/new-luxc/test/test/luxc/synthesizer/structure.lux
+++ b/new-luxc/test/test/luxc/synthesizer/structure.lux
@@ -14,32 +14,36 @@
   (.. common))
 
 (context: "Variants"
-  [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
-   tagA (|> r;nat (:: @ map (n.% size)))
-   memberA gen-primitive]
-  ($_ seq
-      (test "Can synthesize variants."
-            (|> (synthesizer;synthesize (la;sum tagA size +0 memberA))
-                (case> (#ls;Variant tagS last?S memberS)
-                       (and (n.= tagA tagS)
-                            (B/= (n.= (n.dec size) tagA)
-                                 last?S)
-                            (corresponds? memberA memberS))
-                       
-                       _
-                       false)))
-      ))
+  (<| (times +100)
+      (do @
+        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
+         tagA (|> r;nat (:: @ map (n.% size)))
+         memberA gen-primitive]
+        ($_ seq
+            (test "Can synthesize variants."
+                  (|> (synthesizer;synthesize (la;sum tagA size +0 memberA))
+                      (case> (#ls;Variant tagS last?S memberS)
+                             (and (n.= tagA tagS)
+                                  (B/= (n.= (n.dec size) tagA)
+                                       last?S)
+                                  (corresponds? memberA memberS))
+                             
+                             _
+                             false)))
+            ))))
 
 (context: "Tuples"
-  [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
-   membersA (r;list size gen-primitive)]
-  ($_ seq
-      (test "Can synthesize tuple."
-            (|> (synthesizer;synthesize (la;product membersA))
-                (case> (#ls;Tuple membersS)
-                       (and (n.= size (list;size membersS))
-                            (list;every? (product;uncurry corresponds?) (list;zip2 membersA membersS)))
+  (<| (times +100)
+      (do @
+        [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
+         membersA (r;list size gen-primitive)]
+        ($_ seq
+            (test "Can synthesize tuple."
+                  (|> (synthesizer;synthesize (la;product membersA))
+                      (case> (#ls;Tuple membersS)
+                             (and (n.= size (list;size membersS))
+                                  (list;every? (product;uncurry corresponds?) (list;zip2 membersA membersS)))
 
-                       _
-                       false)))
-      ))
+                             _
+                             false)))
+            ))))
-- 
cgit v1.2.3