aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
authorEduardo Julian2017-10-21 00:38:55 -0400
committerEduardo Julian2017-10-21 00:38:55 -0400
commit0bc56fdc626ee601ca2c4ba0502f76e76d765fa0 (patch)
tree7abc9bfda606a0b861c9f2b33d9d949f217d8458 /new-luxc
parenta564de58ec5c91c8069abc3848649a4a0cfd7956 (diff)
- Updated new compiler to latest version of stdlib.
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/analyser/inference.lux4
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux38
-rw-r--r--new-luxc/source/luxc/module/descriptor/type.lux10
-rw-r--r--new-luxc/test/test/luxc/analyser/case.lux190
-rw-r--r--new-luxc/test/test/luxc/analyser/function.lux178
-rw-r--r--new-luxc/test/test/luxc/analyser/primitive.lux58
-rw-r--r--new-luxc/test/test/luxc/analyser/procedure/common.lux674
-rw-r--r--new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux244
-rw-r--r--new-luxc/test/test/luxc/analyser/reference.lux58
-rw-r--r--new-luxc/test/test/luxc/analyser/structure.lux514
-rw-r--r--new-luxc/test/test/luxc/analyser/type.lux78
-rw-r--r--new-luxc/test/test/luxc/generator/case.lux56
-rw-r--r--new-luxc/test/test/luxc/generator/function.lux110
-rw-r--r--new-luxc/test/test/luxc/generator/primitive.lux72
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/common.jvm.lux678
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/host.jvm.lux828
-rw-r--r--new-luxc/test/test/luxc/generator/structure.lux80
-rw-r--r--new-luxc/test/test/luxc/parser.lux214
-rw-r--r--new-luxc/test/test/luxc/synthesizer/case/special.lux88
-rw-r--r--new-luxc/test/test/luxc/synthesizer/function.lux96
-rw-r--r--new-luxc/test/test/luxc/synthesizer/loop.lux54
-rw-r--r--new-luxc/test/test/luxc/synthesizer/primitive.lux48
-rw-r--r--new-luxc/test/test/luxc/synthesizer/procedure.lux30
-rw-r--r--new-luxc/test/test/luxc/synthesizer/structure.lux56
24 files changed, 2287 insertions, 2169 deletions
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 [<tag>]
(<tag> 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 [<name> <class>]
- [(def: #export <name> Type (#;Host <class> (list)))]
+ [(def: #export <name> Type (#;Primitive <class> (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<Meta>
[]
(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<Meta> wrap [elemT name]))
@@ -479,7 +479,7 @@
[_ (#;Text class)]
(do meta;Monad<Meta>
[_ (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: <name> &;Signal <code>)]
[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<Lexer>
- [_ (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)))
<simple>
<combinators>
<abstractions>
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<Text> size (r;text +5)) (:: @ map S;to-list))
- record-tags (|> (r;set text;Hash<Text> 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<Meta>
- [_ (@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<Meta>
- [_ (@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<Meta>
- [_ (@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<Meta>
- [_ (@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<Text> size (r;text +5)) (:: @ map S;to-list))
+ record-tags (|> (r;set text;Hash<Text> 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<Meta>
+ [_ (@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<Meta>
+ [_ (@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<Meta>
+ [_ (@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<Meta>
+ [_ (@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
- [<tests> (do-template [<desc> <type> <tag> <value> <analyser>]
- [(test (format "Can analyse " <desc> ".")
- (|> (@common;with-unknown-type
- (<analyser> <value>))
- (meta;run (init-compiler []))
- (case> (#e;Success [_type (<tag> value)])
- (and (type/= <type> _type)
- (is <value> 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
+ [<tests> (do-template [<desc> <type> <tag> <value> <analyser>]
+ [(test (format "Can analyse " <desc> ".")
+ (|> (@common;with-unknown-type
+ (<analyser> <value>))
+ (meta;run (init-compiler []))
+ (case> (#e;Success [_type (<tag> value)])
+ (and (type/= <type> _type)
+ (is <value> 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
- <tests>)))
+ ["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
+ <tests>)))))
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 [<unary> (do-template [<proc> <desc>]
- [(test (format "Can calculate " <desc> ".")
- (check-success+ <proc> (list subjectC) Frac))]
+ (<| (times +100)
+ (do @
+ [subjectC (|> r;frac (:: @ map code;frac))
+ paramC (|> r;frac (:: @ map code;frac))]
+ (with-expansions [<unary> (do-template [<proc> <desc>]
+ [(test (format "Can calculate " <desc> ".")
+ (check-success+ <proc> (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"])
- <binary> (do-template [<proc> <desc>]
- [(test (format "Can calculate " <desc> ".")
- (check-success+ <proc> (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"])
+ <binary> (do-template [<proc> <desc>]
+ [(test (format "Can calculate " <desc> ".")
+ (check-success+ <proc> (list subjectC paramC) Frac))]
- ["lux math atan2" "inverse/arc tangent (with 2 arguments)"]
- ["lux math pow" "power"])]
- ($_ seq
- <unary>
- <binary>)))
+ ["lux math atan2" "inverse/arc tangent (with 2 arguments)"]
+ ["lux math pow" "power"])]
+ ($_ seq
+ <unary>
+ <binary>)))))
(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<Meta>
- [_ (&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<Meta>
+ [_ (&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<Meta>
- [_ (&;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<Meta>
+ [_ (&;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<Meta>
- [_ (&;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<Meta>
+ [_ (&;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<Text> 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<Meta>
- [_ (@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<Meta>
- [_ (@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<Meta>
- [_ (@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<Meta>
- [_ (@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<Text> 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<Meta>
+ [_ (@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<Meta>
+ [_ (@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<Meta>
+ [_ (@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<Meta>
+ [_ (@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<Text> 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<Meta>
- [_ (@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<Meta>
- [_ (@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<Meta>
- [_ (@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<Text> 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<Meta>
+ [_ (@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<Meta>
+ [_ (@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<Meta>
+ [_ (@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 @@
<triples>)))
(context: "Type checking/coercion."
- [[typeC codeT exprC] check]
- ($_ seq
- (test (format "Can analyse type-checking.")
- (|> (do Monad<Meta>
- [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> <test>]
- [[_ (<expected> expected)] (<actual> actual)]
- (<test> 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<Meta>
+ [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> <test>]
+ [[_ (<expected> expected)] (<actual> actual)]
+ (<test> 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<Meta>
- [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<Meta>
+ [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<Meta>
- [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<Meta>
+ [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<Meta>
- [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<Meta>
+ [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<Meta>
- [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<Meta>
+ [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<Meta>
- [#let [partial-arity (n.inc cut-off)
- preS (list;take partial-arity argsS)
- postS (list;drop partial-arity argsS)]
- runtime-bytecode @runtime;generate
- sampleI (@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<Meta>
+ [#let [partial-arity (n.inc cut-off)
+ preS (list;take partial-arity argsS)
+ postS (list;drop partial-arity argsS)]
+ runtime-bytecode @runtime;generate
+ sampleI (@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<Meta>
- [#let [env (|> (list;n.range +0 cut-off)
- (list/map (|>. n.inc nat-to-int)))
- super-arity (n.inc cut-off)
- arg-var (if (n.<= cut-off arg)
- (|> arg n.inc nat-to-int (i.* -1))
- (|> arg n.inc (n.- super-arity) nat-to-int))
- sub-arity (|> arity (n.- super-arity))
- functionS (<| (#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<Meta>
+ [#let [env (|> (list;n.range +0 cut-off)
+ (list/map (|>. n.inc nat-to-int)))
+ super-arity (n.inc cut-off)
+ arg-var (if (n.<= cut-off arg)
+ (|> arg n.inc nat-to-int (i.* -1))
+ (|> arg n.inc (n.- super-arity) nat-to-int))
+ sub-arity (|> arity (n.- super-arity))
+ functionS (<| (#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
- [<tests> (do-template [<desc> <type> <synthesis> <sample> <test>]
- [(test (format "Can generate " <desc> ".")
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (<synthesis> <sample>))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> <sample> (:! <type> 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
+ [<tests> (do-template [<desc> <type> <synthesis> <sample> <test>]
+ [(test (format "Can generate " <desc> ".")
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (<synthesis> <sample>))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> <sample> (:! <type> 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<Meta>
- [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<Meta>
+ [sampleI (@;generate #ls;Unit)]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (is @runtime;unit (:! Text valueG))
- _
- false)))
- <tests>
- )))
+ _
+ false)))
+ <tests>
+ )))))
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 [<binary> (do-template [<name> <reference>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Nat subject)
- (#ls;Nat param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (n.= (<reference> 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<Meta>
- [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)))
-
- <binary>
- (test "bit shift-right"
- (|> (do meta;Monad<Meta>
- [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 [<binary> (do-template [<name> <reference>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Nat subject)
+ (#ls;Nat param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (n.= (<reference> 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<Meta>
+ [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)))
+
+ <binary>
+ (test "bit shift-right"
+ (|> (do meta;Monad<Meta>
+ [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 [<nullary> (do-template [<name> <reference>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (n.= <reference> (:! Nat valueG))
-
- _
- false)))]
-
- ["nat min" n/bottom]
- ["nat max" n/top]
- )
- <unary> (do-template [<name> <type> <prepare> <comp>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list (#ls;Nat subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<prepare> subject) (:! <type> valueG))
-
- _
- false)))]
-
- ["nat to-int" Int nat-to-int i.=]
- ["nat to-char" Text text;from-code text/=]
- )
- <binary> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Nat subject)
- (#ls;Nat param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> param subject) (:! <outputT> 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
- <nullary>
- <unary>
- <binary>
- )))
+ (<| (times +100)
+ (do @
+ [param (|> r;nat (r;filter (|>. (n.= +0) not)))
+ subject r;nat]
+ (with-expansions [<nullary> (do-template [<name> <reference>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (n.= <reference> (:! Nat valueG))
+
+ _
+ false)))]
+
+ ["nat min" n/bottom]
+ ["nat max" n/top]
+ )
+ <unary> (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list (#ls;Nat subject))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["nat to-int" Int nat-to-int i.=]
+ ["nat to-char" Text text;from-code text/=]
+ )
+ <binary> (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Nat subject)
+ (#ls;Nat param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> 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
+ <nullary>
+ <unary>
+ <binary>
+ )))))
(context: "Int procedures"
- [param (|> r;int (r;filter (|>. (i.= 0) not)))
- subject r;int]
- (with-expansions [<nullary> (do-template [<name> <reference>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (i.= <reference> (:! Int valueG))
-
- _
- false)))]
-
- ["int min" i/bottom]
- ["int max" i/top]
- )
- <unary> (do-template [<name> <type> <prepare> <comp>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list (#ls;Int subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<prepare> subject) (:! <type> valueG))
-
- _
- false)))]
-
- ["int to-nat" Nat int-to-nat n.=]
- ["int to-frac" Frac int-to-frac f.=]
- )
- <binary> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Int subject)
- (#ls;Int param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> param subject) (:! <outputT> 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
- <nullary>
- <unary>
- <binary>
- )))
+ (<| (times +100)
+ (do @
+ [param (|> r;int (r;filter (|>. (i.= 0) not)))
+ subject r;int]
+ (with-expansions [<nullary> (do-template [<name> <reference>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (i.= <reference> (:! Int valueG))
+
+ _
+ false)))]
+
+ ["int min" i/bottom]
+ ["int max" i/top]
+ )
+ <unary> (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list (#ls;Int subject))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["int to-nat" Nat int-to-nat n.=]
+ ["int to-frac" Frac int-to-frac f.=]
+ )
+ <binary> (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Int subject)
+ (#ls;Int param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> 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
+ <nullary>
+ <unary>
+ <binary>
+ )))))
(context: "Frac procedures [Part 1]"
- [param (|> r;frac (r;filter (|>. (f.= 0.0) not)))
- subject r;frac]
- (with-expansions [<binary> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Frac subject)
- (#ls;Frac param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> param subject) (:! <outputT> 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
- <binary>
- )))
+ (<| (times +100)
+ (do @
+ [param (|> r;frac (r;filter (|>. (f.= 0.0) not)))
+ subject r;frac]
+ (with-expansions [<binary> (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Frac subject)
+ (#ls;Frac param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> 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
+ <binary>
+ )))))
(context: "Frac procedures [Part 2]"
- [param (|> r;frac (r;filter (|>. (f.= 0.0) not)))
- subject r;frac]
- (with-expansions [<nullary> (do-template [<name> <test>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> (:! 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"] []))]
- )
- <unary> (do-template [<name> <type> <prepare> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name> (list (#ls;Frac subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<prepare> subject) (:! <type> valueG))
-
- _
- false)))]
-
- ["frac to-int" Int frac-to-int i.=]
- ["frac to-deg" Deg frac-to-deg d.=]
- )]
- ($_ seq
- <nullary>
- <unary>
- (test "frac encode|decode"
- (|> (do Monad<Meta>
- [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 [<nullary> (do-template [<name> <test>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> (:! 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"] []))]
+ )
+ <unary> (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name> (list (#ls;Frac subject))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["frac to-int" Int frac-to-int i.=]
+ ["frac to-deg" Deg frac-to-deg d.=]
+ )]
+ ($_ seq
+ <nullary>
+ <unary>
+ (test "frac encode|decode"
+ (|> (do Monad<Meta>
+ [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 [<nullary> (do-template [<name> <reference>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (d.= <reference> (:! Deg valueG))
-
- _
- false)))]
-
- ["deg min" d/bottom]
- ["deg max" d/top]
- )
- <unary> (do-template [<name> <type> <prepare> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<prepare> subject) (:! <type> valueG))
-
- _
- false)))]
-
- ["deg to-frac" Frac deg-to-frac f.=]
- )
- <binary> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Deg subject)
- (#ls;Deg param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> param subject) (:! <outputT> valueG))
-
- _
- false)))]
-
- ["deg +" d.+ Deg d.=]
- ["deg -" d.- Deg d.=]
- ["deg *" d.* Deg d.=]
- ["deg /" d./ Deg d.=]
- ["deg %" d.% Deg d.=]
- ["deg =" d.= Bool bool/=]
- ["deg <" d.< Bool bool/=]
- )
- <special> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Deg subject)
- (#ls;Nat special))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> special subject) (:! <outputT> valueG))
-
- _
- false)))]
-
- ["deg scale" d.scale Deg d.=]
- ["deg reciprocal" d.reciprocal Deg d.=]
- )]
- ($_ seq
- <nullary>
- <unary>
- <binary>
- <special>
- )))
+ (<| (seed +1021167468900)
+ ## (times +100)
+ (do @
+ [param (|> r;deg (r;filter (|>. (d.= .0) not)))
+ special r;nat
+ subject r;deg]
+ (with-expansions [<nullary> (do-template [<name> <reference>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (d.= <reference> (:! Deg valueG))
+
+ _
+ false)))]
+
+ ["deg min" d/bottom]
+ ["deg max" d/top]
+ )
+ <unary> (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["deg to-frac" Frac deg-to-frac f.=]
+ )
+ <binary> (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Deg subject)
+ (#ls;Deg param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["deg +" d.+ Deg d.=]
+ ["deg -" d.- Deg d.=]
+ ["deg *" d.* Deg d.=]
+ ["deg /" d./ Deg d.=]
+ ["deg %" d.% Deg d.=]
+ ["deg =" d.= Bool bool/=]
+ ["deg <" d.< Bool bool/=]
+ )
+ <special> (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Deg subject)
+ (#ls;Nat special))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> special subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["deg scale" d.scale Deg d.=]
+ ["deg reciprocal" d.reciprocal Deg d.=]
+ )]
+ ($_ seq
+ <nullary>
+ <unary>
+ <binary>
+ <special>
+ )))))
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 [<step1> <step2> <tag> <sample> <cast> <test>]
- [(test (format <step1> " / " <step2>)
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (|> (<tag> <sample>)
- (list) (#ls;Procedure <step1>)
- (list) (#ls;Procedure <step2>)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> <sample> (:! <cast> 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 [<step1> <step2> <tag> <sample> <cast> <test>]
+ [(test (format <step1> " / " <step2>)
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (|> (<tag> <sample>)
+ (list) (#ls;Procedure <step1>)
+ (list) (#ls;Procedure <step2>)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> <sample> (:! <cast> 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 [<step1> <step2> <step3> <tag> <sample> <cast> <test>]
- [(test (format <step1> " / " <step2> " / " <step3>)
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (|> (<tag> <sample>)
- (list) (#ls;Procedure <step1>)
- (list) (#ls;Procedure <step2>)
- (list) (#ls;Procedure <step3>)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> <sample> (:! <cast> 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 [<step1> <step2> <step3> <step4> <tag> <sample> <cast> <test>]
- [(test (format <step1> " / " <step2> " / " <step3>)
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (|> (<tag> <sample>)
- (list) (#ls;Procedure <step1>)
- (list) (#ls;Procedure <step2>)
- (list) (#ls;Procedure <step3>)
- (list) (#ls;Procedure <step4>)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> <sample> (:! <cast> 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 [<step1> <step2> <step3> <tag> <sample> <cast> <test>]
+ [(test (format <step1> " / " <step2> " / " <step3>)
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (|> (<tag> <sample>)
+ (list) (#ls;Procedure <step1>)
+ (list) (#ls;Procedure <step2>)
+ (list) (#ls;Procedure <step3>)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> <sample> (:! <cast> 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 [<step1> <step2> <step3> <step4> <tag> <sample> <cast> <test>]
+ [(test (format <step1> " / " <step2> " / " <step3>)
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (|> (<tag> <sample>)
+ (list) (#ls;Procedure <step1>)
+ (list) (#ls;Procedure <step2>)
+ (list) (#ls;Procedure <step3>)
+ (list) (#ls;Procedure <step4>)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> <sample> (:! <cast> 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 [<domain> <generator> <tag> <type> <test> <augmentation> <+> <-> <*> </> <%> <pre> <post>]
[(context: (format "Arithmetic [" <domain> "]")
- [param <generator>
- #let [subject (<augmentation> param)]]
- (with-expansions [<tests> (do-template [<procedure> <reference>]
- [(test <procedure>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<pre> (<tag> subject))
- (<pre> (<tag> param))))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> (<reference> param subject)
- (:! <type> valueG))
-
- (#e;Error error)
- false)))]
-
- [(format "jvm " <domain> " +") <+>]
- [(format "jvm " <domain> " -") <->]
- [(format "jvm " <domain> " *") <*>]
- [(format "jvm " <domain> " /") </>]
- [(format "jvm " <domain> " %") <%>]
- )]
- ($_ seq
- <tests>
- )))]
+ (<| (times +100)
+ (do @
+ [param <generator>
+ #let [subject (<augmentation> param)]]
+ (with-expansions [<tests> (do-template [<procedure> <reference>]
+ [(test <procedure>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<pre> (<tag> subject))
+ (<pre> (<tag> param))))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> (<reference> param subject)
+ (:! <type> valueG))
+
+ (#e;Error error)
+ false)))]
+
+ [(format "jvm " <domain> " +") <+>]
+ [(format "jvm " <domain> " -") <->]
+ [(format "jvm " <domain> " *") <*>]
+ [(format "jvm " <domain> " /") </>]
+ [(format "jvm " <domain> " %") <%>]
+ )]
+ ($_ seq
+ <tests>
+ )))))]
["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 [<domain> <post> <convert>]
[(context: (format "Bit-wise [" <domain> "]")
- [param gen-nat
- subject gen-nat
- #let [shift (n.% +10 param)]]
- (with-expansions [<combiners> (do-template [<procedure> <reference>]
- [(test <procedure>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (#ls;Nat subject))
- (<convert> (#ls;Nat param))))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (n.= (<reference> param subject)
- (:! Nat valueG))
-
- (#e;Error error)
- false)))]
-
- [(format "jvm " <domain> " and") bit;and]
- [(format "jvm " <domain> " or") bit;or]
- [(format "jvm " <domain> " xor") bit;xor]
- )
- <shifters> (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>]
- [(test <procedure>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (<pre> subject))
- (|> (#ls;Nat shift)
- (list)
- (#ls;Procedure "jvm convert long-to-int"))))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<test> (<reference> shift (<pre-subject> subject))
- (:! <type> valueG))
-
- (#e;Error error)
- false)))]
-
- [(format "jvm " <domain> " shl") bit;shift-left Nat n.= id #ls;Nat]
- [(format "jvm " <domain> " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int #ls;Int)]
- [(format "jvm " <domain> " ushr") bit;shift-right Nat n.= id #ls;Nat]
- )]
- ($_ seq
- <combiners>
- <shifters>
- )))]
+ (<| (times +100)
+ (do @
+ [param gen-nat
+ subject gen-nat
+ #let [shift (n.% +10 param)]]
+ (with-expansions [<combiners> (do-template [<procedure> <reference>]
+ [(test <procedure>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (#ls;Nat subject))
+ (<convert> (#ls;Nat param))))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (n.= (<reference> param subject)
+ (:! Nat valueG))
+
+ (#e;Error error)
+ false)))]
+
+ [(format "jvm " <domain> " and") bit;and]
+ [(format "jvm " <domain> " or") bit;or]
+ [(format "jvm " <domain> " xor") bit;xor]
+ )
+ <shifters> (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>]
+ [(test <procedure>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (<pre> subject))
+ (|> (#ls;Nat shift)
+ (list)
+ (#ls;Procedure "jvm convert long-to-int"))))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<test> (<reference> shift (<pre-subject> subject))
+ (:! <type> valueG))
+
+ (#e;Error error)
+ false)))]
+
+ [(format "jvm " <domain> " shl") bit;shift-left Nat n.= id #ls;Nat]
+ [(format "jvm " <domain> " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int #ls;Int)]
+ [(format "jvm " <domain> " ushr") bit;shift-right Nat n.= id #ls;Nat]
+ )]
+ ($_ seq
+ <combiners>
+ <shifters>
+ )))))]
["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 [<domain> <generator> <tag> <=> <<> <pre>]
[(context: (format "Order [" <domain> "]")
- [param <generator>
- subject <generator>]
- (with-expansions [<tests> (do-template [<procedure> <reference>]
- [(test <procedure>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <procedure> (list (<pre> (<tag> subject))
- (<pre> (<tag> param)))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (bool/= (<reference> param subject)
- (:! Bool valueG))
-
- (#e;Error error)
- false)))]
-
- [(format "jvm " <domain> " =") <=>]
- [(format "jvm " <domain> " <") <<>]
- )]
- ($_ seq
- <tests>
- )))]
+ (<| (times +100)
+ (do @
+ [param <generator>
+ subject <generator>]
+ (with-expansions [<tests> (do-template [<procedure> <reference>]
+ [(test <procedure>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <procedure> (list (<pre> (<tag> subject))
+ (<pre> (<tag> param)))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (bool/= (<reference> param subject)
+ (:! Bool valueG))
+
+ (#e;Error error)
+ false)))]
+
+ [(format "jvm " <domain> " =") <=>]
+ [(format "jvm " <domain> " <") <<>]
+ )]
+ ($_ seq
+ <tests>
+ )))))]
["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 [<array> (do-template [<class> <type> <value> <test> <input> <post>]
- [(test <class>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size)))
- (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write")
- (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
- <post>))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success outputZ)
- (<test> <value> (:! <type> 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
- <array>
- )))
+ (<| (times +100)
+ (do @
+ [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
+ idx (|> r;nat (:: @ map (n.% size)))
+ valueZ r;bool
+ valueB gen-int
+ valueS gen-int
+ valueI gen-int
+ valueL r;int
+ valueF gen-frac
+ valueD r;frac
+ valueC gen-int]
+ (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>]
+ [(test <class>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size)))
+ (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write")
+ (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
+ <post>))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputZ)
+ (<test> <value> (:! <type> 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
+ <array>
+ )))))
(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 [<array> (do-template [<class> <type> <value> <test> <input> <post>]
- [(test <class>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size)))
- (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write")
- (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
- <post>))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success outputG)
- (<test> <value> (:! <type> 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
- <array>
- (test "java.lang.Double (level 1)"
- (|> (do meta;Monad<Meta>
- [#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<Meta>
- [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 [<array> (do-template [<class> <type> <value> <test> <input> <post>]
+ [(test <class>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size)))
+ (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write")
+ (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read")
+ <post>))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (<test> <value> (:! <type> 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
+ <array>
+ (test "java.lang.Double (level 1)"
+ (|> (do meta;Monad<Meta>
+ [#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<Meta>
+ [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<Meta>
- [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<Meta>
- [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<Meta>
- [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<Meta>
- [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<Meta>
- [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<Meta>
+ [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<Meta>
+ [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<Meta>
+ [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<Meta>
+ [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<Meta>
+ [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<Meta>
- [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<Meta>
- [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<Meta>
- [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<Meta>
- [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<Meta>
+ [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<Meta>
+ [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<Meta>
+ [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<Meta>
+ [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<Meta>
- [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<Meta>
+ [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<Meta>
- [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<Meta>
+ [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<Code> = parsed sample))
- ))
+ (#e;Success [_ parsed])
+ (:: code;Eq<Code> = 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<Code> =
- 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<Code> = 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<Code> =
+ 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<Code> = 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
- [<tests> (do-template [<desc> <analysis> <synthesis> <sample>]
- [(test (format "Can synthesize " <desc> ".")
- (|> (synthesizer;synthesize (<analysis> <sample>))
- (case> (<synthesis> value)
- (is <sample> 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
+ [<tests> (do-template [<desc> <analysis> <synthesis> <sample>]
+ [(test (format "Can synthesize " <desc> ".")
+ (|> (synthesizer;synthesize (<analysis> <sample>))
+ (case> (<synthesis> value)
+ (is <sample> 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
- <tests>)))
+ ["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
+ <tests>)))))
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)))
+ ))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-16 08:57:16 +0000