From 15121222d570f8fe3c5a326208e4f0bad737e63c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 31 Oct 2017 23:39:49 -0400 Subject: - Re-organized analysis. --- new-luxc/test/test/luxc/analyser/case.lux | 227 --------- new-luxc/test/test/luxc/analyser/common.lux | 52 -- new-luxc/test/test/luxc/analyser/function.lux | 154 ------ new-luxc/test/test/luxc/analyser/primitive.lux | 67 --- .../test/test/luxc/analyser/procedure/common.lux | 423 ---------------- .../test/test/luxc/analyser/procedure/host.jvm.lux | 529 --------------------- new-luxc/test/test/luxc/analyser/reference.lux | 52 -- new-luxc/test/test/luxc/analyser/structure.lux | 336 ------------- new-luxc/test/test/luxc/analyser/type.lux | 91 ---- new-luxc/test/test/luxc/generator/case.lux | 1 - new-luxc/test/test/luxc/generator/function.lux | 1 - new-luxc/test/test/luxc/generator/primitive.lux | 1 - .../test/luxc/generator/procedure/common.jvm.lux | 1 - .../test/luxc/generator/procedure/host.jvm.lux | 1 - new-luxc/test/test/luxc/generator/structure.lux | 1 - new-luxc/test/test/luxc/lang/analysis/case.lux | 227 +++++++++ new-luxc/test/test/luxc/lang/analysis/common.lux | 52 ++ new-luxc/test/test/luxc/lang/analysis/function.lux | 154 ++++++ .../test/test/luxc/lang/analysis/primitive.lux | 67 +++ .../test/luxc/lang/analysis/procedure/common.lux | 423 ++++++++++++++++ .../test/luxc/lang/analysis/procedure/host.jvm.lux | 529 +++++++++++++++++++++ .../test/test/luxc/lang/analysis/reference.lux | 52 ++ .../test/test/luxc/lang/analysis/structure.lux | 336 +++++++++++++ new-luxc/test/test/luxc/lang/analysis/type.lux | 91 ++++ new-luxc/test/test/luxc/lang/parser.lux | 233 +++++++++ new-luxc/test/test/luxc/parser.lux | 233 --------- new-luxc/test/test/luxc/synthesizer/primitive.lux | 1 - new-luxc/test/test/luxc/synthesizer/procedure.lux | 1 - new-luxc/test/tests.lux | 18 +- 29 files changed, 2173 insertions(+), 2181 deletions(-) delete mode 100644 new-luxc/test/test/luxc/analyser/case.lux delete mode 100644 new-luxc/test/test/luxc/analyser/common.lux delete mode 100644 new-luxc/test/test/luxc/analyser/function.lux delete mode 100644 new-luxc/test/test/luxc/analyser/primitive.lux delete mode 100644 new-luxc/test/test/luxc/analyser/procedure/common.lux delete mode 100644 new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux delete mode 100644 new-luxc/test/test/luxc/analyser/reference.lux delete mode 100644 new-luxc/test/test/luxc/analyser/structure.lux delete mode 100644 new-luxc/test/test/luxc/analyser/type.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/case.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/common.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/function.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/primitive.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/procedure/common.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/reference.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/structure.lux create mode 100644 new-luxc/test/test/luxc/lang/analysis/type.lux create mode 100644 new-luxc/test/test/luxc/lang/parser.lux delete mode 100644 new-luxc/test/test/luxc/parser.lux (limited to 'new-luxc/test') diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux deleted file mode 100644 index 27cc9f6ae..000000000 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ /dev/null @@ -1,227 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq] - ["R" error] - [product] - [maybe] - [text "T/" Eq] - text/format - (coll [list "L/" Monad] - ["S" set])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type "type/" Eq] - (type ["tc" check])) - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" case] - ["@;" common]) - ["@;" module]) - (.. common) - (test/luxc common)) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #;Nil - #;Nil - - (#;Cons head+ #;Nil) - (L/map (|>. list) head+) - - (#;Cons head+ tail++) - (do list;Monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#;Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bool (List [Code Code]) Code (r;Random (List Code))) - (case inputC - [_ (#;Bool _)] - (r/wrap (list (' true) (' false))) - - (^template [ ] - [_ ( _)] - (if allow-literals? - (do r;Monad - [?sample (r;maybe )] - (case ?sample - (#;Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& ( sample) else))) - - #;None - (wrap (list (' _))))) - (r/wrap (list (' _))))) - ([#;Nat r;nat code;nat] - [#;Int r;int code;int] - [#;Deg r;deg code;deg] - [#;Frac r;frac code;frac] - [#;Text (r;text +5) code;text]) - - (^ [_ (#;Tuple (list))]) - (r/wrap (list (' []))) - - (^ [_ (#;Record (list))]) - (r/wrap (list (' {}))) - - [_ (#;Tuple members)] - (do r;Monad - [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (L/map code;tuple)))) - - [_ (#;Record kvs)] - (do r;Monad - [#let [ks (L/map product;left kvs) - vs (L/map product;right kvs)] - member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (L/map (|>. (list;zip2 ks) code;record))))) - - (^ [_ (#;Form (list [_ (#;Tag _)] _))]) - (do r;Monad - [bundles (monad;map @ - (function [[_tag _code]] - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (L/join bundles))) - - _ - (r/wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r;Random Code)) - (r;rec - (function [input] - ($_ r;either - (r/map product;right gen-primitive) - (do r;Monad - [choice (|> r;nat (:: @ map (n.% (list;size variant-tags)))) - #let [choiceT (maybe;assume (list;nth choice variant-tags)) - choiceC (maybe;assume (list;nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do r;Monad - [size (|> r;nat (:: @ map (n.% +3))) - elems (r;list size input)] - (wrap (code;tuple elems))) - (r/wrap (code;record (list;zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(context: "Pattern-matching." - ## #seed +9253409297339902486 - ## #seed +3793366152923578600 - (<| (seed +5004137551292836565) - ## (times +100) - (do @ - [module-name (r;text +5) - variant-name (r;text +5) - record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) - size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - variant-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - record-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - primitivesTC (r;list size gen-primitive) - #let [primitivesT (L/map product;left primitivesTC) - primitivesC (L/map product;right primitivesTC) - variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) - record-tags+ (L/map (|>. [module-name] code;tag) record-tags) - variantTC (list;zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] gen-primitive - [heterogeneousT heterogeneousC] (|> gen-primitive - (r;filter (|>. product;left (tc;checks? outputT) not))) - exhaustive-patterns (exhaustive-branches true variantTC inputC) - redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) - heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) - #let [exhaustive-branchesC (L/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list;take (n.dec (list;size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (L/map (branch outputC)) - list;concat - (list (list;take redundancy-idx redundant-patterns) - (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) - (list;drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) - ]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC (list)))) - check-failure)) - (test "Can analyse exhaustive pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC exhaustive-branchesC))))) - check-success)) - (test "Will reject non-exhaustive pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC non-exhaustive-branchesC))))) - check-failure)) - (test "Will reject redundant pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC redundant-branchesC))))) - check-failure)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (@module;with-module +0 module-name - (do Monad - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC heterogeneous-branchesC))))) - check-failure)) - )))) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux deleted file mode 100644 index 99090777b..000000000 --- a/new-luxc/test/test/luxc/analyser/common.lux +++ /dev/null @@ -1,52 +0,0 @@ -(;module: - lux - (lux (control pipe) - ["r" math/random "r/" Monad] - (data ["e" error]) - [meta] - (meta [code])) - (luxc ["&" base] - [analyser] - [eval]) - (test/luxc common)) - -(def: gen-unit - (r;Random Code) - (r/wrap (' []))) - -(def: #export gen-primitive - (r;Random [Type Code]) - (with-expansions - [ (do-template [ ] - [(r;seq (r/wrap ) (r/map ))] - - [Unit code;tuple (r;list +0 gen-unit)] - [Bool code;bool r;bool] - [Nat code;nat r;nat] - [Int code;int r;int] - [Deg code;deg r;deg] - [Frac code;frac r;frac] - [Text code;text (r;text +5)] - )] - ($_ r;either - - ))) - -(def: #export analyse - &;Analyser - (analyser;analyser eval;eval)) - -(do-template [ ] - [(def: #export ( analysis) - (All [a] (-> (Meta a) Bool)) - (|> analysis - (meta;run (init-compiler [])) - (case> (#e;Success _) - - - (#e;Error error) - )))] - - [check-success true false] - [check-failure false true] - ) diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux deleted file mode 100644 index 379c4acf4..000000000 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ /dev/null @@ -1,154 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [maybe] - [product] - [text "text/" Eq] - text/format - (coll [list "list/" Functor])) - ["r" math/random "r/" Monad] - [meta] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" function] - ["@;" common]) - ["@;" module]) - (.. common) - (test/luxc common)) - -(def: (check-type expectedT error) - (-> Type (e;Error [Type la;Analysis]) Bool) - (case error - (#e;Success [exprT exprA]) - (type/= expectedT exprT) - - _ - false)) - -(def: (succeeds? error) - (All [a] (-> (e;Error a) Bool)) - (case error - (#e;Success _) - true - - (#e;Error _) - false)) - -(def: (flatten-apply analysis) - (-> la;Analysis [la;Analysis (List la;Analysis)]) - (case analysis - (^code ("lux apply" (~ head) (~ func))) - (let [[func' tail] (flatten-apply func)] - [func' (#;Cons head tail)]) - - _ - [analysis (list)])) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta [Type la;Analysis]) Bool) - (|> analysis - (meta;run (init-compiler [])) - (case> (#e;Success [applyT applyA]) - (let [[funcA argsA] (flatten-apply applyA)] - (and (type/= expectedT applyT) - (n.= num-args (list;size argsA)))) - - (#e;Error error) - false))) - -(context: "Function definition." - (<| (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?)) - )))) - -(context: "Function application." - (<| (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 (' []) inputsC)) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (' []) - (list;take partial-args inputsC))) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (' []) inputsC)) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (' []) - (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 (' []) - (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 deleted file mode 100644 index 8c483428b..000000000 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ /dev/null @@ -1,67 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq] - [text "T/" Eq] - (text format - ["l" lexer]) - [number] - ["e" error] - [product] - (coll [list "L/" Functor Fold])) - ["r" math/random] - [meta #+ Monad] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" primitive] - ["@;" common])) - (.. common) - (test/luxc common)) - -(context: "Primitives" - (<| (times +100) - (do @ - [%bool% r;bool - %nat% r;nat - %int% r;int - %deg% r;deg - %frac% r;frac - %text% (r;text +5)] - (`` ($_ seq - (test "Can analyse unit." - (|> (@common;with-unknown-type - @;analyse-unit) - (meta;run (init-compiler [])) - (case> (^ (#e;Success [_type (^code [])])) - (type/= Unit _type) - - _ - false)) - ) - (~~ (do-template [ ] - [(test (format "Can analyse " ".") - (|> (@common;with-unknown-type - ( )) - (meta;run (init-compiler [])) - (case> (#e;Success [_type [_ ( value)]]) - (and (type/= _type) - (is value)) - - _ - false)) - )] - - ["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] - ))))))) diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux deleted file mode 100644 index 5e1619d38..000000000 --- a/new-luxc/test/test/luxc/analyser/procedure/common.lux +++ /dev/null @@ -1,423 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data text/format - ["e" error] - [product] - (coll [array])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - ["&;" scope] - ["&;" module] - [";L" eval] - (lang ["~" analysis]) - [analyser] - (analyser ["@" procedure] - ["@;" common])) - (../.. common) - (test/luxc common)) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (&;with-scope - (&;with-expected-type output-type - (@;analyse-procedure analyse evalL;eval procedure params))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - - - (#e;Error error) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(context: "Lux procedures" - (<| (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" - (<| (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" - (<| (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" - (<| (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" - (<| (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 subjectC natC) Deg)) - )))) - -(context: "Frac procedures" - (<| (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 decode" (list encodedC) (type (Maybe Frac)))) - )))) - -(context: "Text procedures" - (<| (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" - (<| (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 evalL;eval "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 evalL;eval "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 evalL;eval "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 evalL;eval "lux array size" - (list (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - )))) - -(context: "Math procedures" - (<| (times +100) - (do @ - [subjectC (|> r;frac (:: @ map code;frac)) - paramC (|> r;frac (:: @ map code;frac))] - (with-expansions [ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math root2" "square root"] - ["lux math root3" "cubic root"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"]) - (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"])] - ($_ seq - - ))))) - -(context: "Atom procedures" - (<| (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 evalL;eval "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 evalL;eval "lux atom compare-and-swap" - (list elemC - elemC - (code;symbol ["" var-name])))))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - true - - (#e;Error _) - false))) - )))) - -(context: "Process procedures" - (<| (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" - (<| (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 deleted file mode 100644 index 3cee1b160..000000000 --- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux +++ /dev/null @@ -1,529 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data ["e" error] - [product] - [maybe] - [text "text/" Eq] - text/format - (coll [array] - [list "list/" Fold] - [dict])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type]) - test) - (luxc ["&" base] - ["&;" scope] - ["&;" module] - [";L" eval] - (lang ["~" analysis]) - [analyser] - (analyser ["@" procedure] - ["@;" common] - (procedure ["@;" host])) - (generator ["@;" runtime])) - (../.. common) - (test/luxc common)) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (&;with-expected-type output-type - (@;analyse-procedure analyse evalL;eval procedure params)))) - (meta;run (init-compiler [])) - (case> (#e;Success _) - - - (#e;Error error) - )))] - - [success true false] - [failure false true] - ) - -(context: "Conversions [double + float]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert double-to-float" "java.lang.Double" @host;Float] - ["jvm convert double-to-int" "java.lang.Double" @host;Integer] - ["jvm convert double-to-long" "java.lang.Double" @host;Long] - ["jvm convert float-to-double" "java.lang.Float" @host;Double] - ["jvm convert float-to-int" "java.lang.Float" @host;Integer] - ["jvm convert float-to-long" "java.lang.Float" @host;Long] - )] - ($_ seq - - ))) - -(context: "Conversions [int]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert int-to-byte" "java.lang.Integer" @host;Byte] - ["jvm convert int-to-char" "java.lang.Integer" @host;Character] - ["jvm convert int-to-double" "java.lang.Integer" @host;Double] - ["jvm convert int-to-float" "java.lang.Integer" @host;Float] - ["jvm convert int-to-long" "java.lang.Integer" @host;Long] - ["jvm convert int-to-short" "java.lang.Integer" @host;Short] - )] - ($_ seq - - ))) - -(context: "Conversions [long]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert long-to-double" "java.lang.Long" @host;Double] - ["jvm convert long-to-float" "java.lang.Long" @host;Float] - ["jvm convert long-to-int" "java.lang.Long" @host;Integer] - ["jvm convert long-to-short" "java.lang.Long" @host;Short] - ["jvm convert long-to-byte" "java.lang.Long" @host;Byte] - )] - ($_ seq - - ))) - -(context: "Conversions [char + byte + short]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert char-to-byte" "java.lang.Character" @host;Byte] - ["jvm convert char-to-short" "java.lang.Character" @host;Short] - ["jvm convert char-to-int" "java.lang.Character" @host;Integer] - ["jvm convert char-to-long" "java.lang.Character" @host;Long] - ["jvm convert byte-to-long" "java.lang.Byte" @host;Long] - ["jvm convert short-to-long" "java.lang.Short" @host;Long] - )] - ($_ seq - - ))) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") @host;Boolean] - [(format "jvm " " <") @host;Boolean] - )] - ($_ seq - - ))) - - (context: (format "Bitwise " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " and") ] - [(format "jvm " " or") ] - [(format "jvm " " xor") ] - [(format "jvm " " shl") "java.lang.Integer" ] - [(format "jvm " " shr") "java.lang.Integer" ] - [(format "jvm " " ushr") "java.lang.Integer" ] - )] - ($_ seq - - )))] - - - ["int" "java.lang.Integer" @host;Integer] - ["long" "java.lang.Long" @host;Long] - ) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") @host;Boolean] - [(format "jvm " " <") @host;Boolean] - )] - ($_ seq - - )))] - - - ["float" "java.lang.Float" @host;Float] - ["double" "java.lang.Double" @host;Double] - ) - -(do-template [ ] - [(context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") @host;Boolean] - [(format "jvm " " <") @host;Boolean] - )] - ($_ seq - - )))] - - - ["char" "java.lang.Character" @host;Character] - ) - -(def: array-type - (r;Random [Text Text]) - (let [entries (dict;entries @host;boxes) - num-entries (list;size entries)] - (do r;Monad - [choice (|> r;nat (:: @ map (n.% (n.inc num-entries)))) - #let [[unboxed boxed] (: [Text Text] - (|> entries - (list;nth choice) - (maybe;default ["java.lang.Object" "java.lang.Object"])))]] - (wrap [unboxed boxed])))) - -(context: "Array." - (<| (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) - (list "java.lang.Throwable" - "java.lang.Error" - "java.io.IOError" - "java.lang.VirtualMachineError" - "java.lang.Exception" - "java.io.IOException" - "java.lang.RuntimeException")) - -(context: "Object." - (<| (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 - (test "jvm member static get" - (success "jvm member static get" - (list (code;text "java.lang.System") - (code;text "out")) - (#;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")) - (#;Primitive "java.lang.Object" (list)))) - (test "jvm member static put" - (success "jvm member static put" - (list (code;text "java.awt.datatransfer.DataFlavor") - (code;text "allHtmlFlavor") - (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) - ("jvm object null")))) - Unit)) - (test "jvm member static put (final)" - (failure "jvm member static put" - (list (code;text "java.lang.System") - (code;text "out") - (`' ("lux check" (+0 "java.io.PrintStream" (+0)) - ("jvm object null")))) - Unit)) - (test "jvm member static put (inheritance in)" - (success "jvm member static put" - (list (code;text "java.awt.datatransfer.DataFlavor") - (code;text "allHtmlFlavor") - (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null")))) - Unit)) - )) - -(context: "Member [Virtual Field]." - ($_ seq - (test "jvm member virtual get" - (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")))) - (#;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")))) - (#;Primitive "java.lang.Object" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code;text "org.omg.CORBA.ValueMember") - (code;text "id") - (`' ("lux check" (+0 "java.lang.String" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (primitive org.omg.CORBA.ValueMember))) - (test "jvm member virtual put (final)" - (failure "jvm member virtual put" - (list (code;text "javax.swing.text.html.parser.DTD") - (code;text "applet") - (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) - ("jvm object null")))) - (primitive javax.swing.text.html.parser.DTD))) - (test "jvm member virtual put (inheritance in)" - (success "jvm member virtual put" - (list (code;text "java.awt.GridBagConstraints") - (code;text "insets") - (`' ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) - ("jvm object null")))) - (primitive java.awt.GridBagConstraints))) - )) - -(context: "Boxing/Unboxing." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code;text "java.util.GregorianCalendar") - (code;text "AD")) - (#;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")))) - (#;Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code;text "javax.accessibility.AccessibleAttributeSequence") - (code;text "startIndex") - (`' ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (primitive javax.accessibility.AccessibleAttributeSequence))) - )) - -(context: "Member [Method]." - (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) - +123)) - intC (`' ("jvm convert long-to-int" (~ longC))) - objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) - ("jvm member invoke constructor" "java.util.ArrayList" - ["int" (~ intC)])))] - ($_ seq - (test "jvm member invoke static" - (success "jvm member invoke static" - (list (code;text "java.lang.Long") - (code;text "decode") - (code;tuple (list (' "java.lang.String") - (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO"))))) - (#;Primitive "java.lang.Long" (list)))) - (test "jvm member invoke virtual" - (success "jvm member invoke virtual" - (list (code;text "java.lang.Object") - (code;text "equals") - longC - (code;tuple (list (' "java.lang.Object") - longC))) - (#;Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke special" - (success "jvm member invoke special" - (list (code;text "java.lang.Long") - (code;text "equals") - longC - (code;tuple (list (' "java.lang.Object") - longC))) - (#;Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke interface" - (success "jvm member invoke interface" - (list (code;text "java.util.Collection") - (code;text "add") - objectC - (code;tuple (list (' "java.lang.Object") - longC))) - (#;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] (#;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 deleted file mode 100644 index e9d66838a..000000000 --- a/new-luxc/test/test/luxc/analyser/reference.lux +++ /dev/null @@ -1,52 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error]) - ["r" math/random] - [meta #+ Monad] - (meta [type "type/" Eq]) - test) - (luxc ["&;" scope] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" reference] - ["@;" common])) - (.. common) - (test/luxc common)) - -(context: "References" - (<| (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 (^code ((~ [_ (#;Int var)])))])) - (type/= ref-type _type) - - _ - false))) - (test "Can analyse definition." - (|> (do Monad - [_ (&module;create +0 module-name) - _ (&module;define [module-name var-name] - [ref-type (' {}) (:! Void [])])] - (@common;with-unknown-type - (@;analyse-reference [module-name var-name]))) - (meta;run (init-compiler [])) - (case> (#e;Success [_type [_ (#;Symbol def-name)]]) - (type/= ref-type _type) - - _ - false))) - )))) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux deleted file mode 100644 index 5f88aea37..000000000 --- a/new-luxc/test/test/luxc/analyser/structure.lux +++ /dev/null @@ -1,336 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - ["e" error] - [product] - [maybe] - [text] - text/format - (coll [list "list/" Functor] - ["S" set])) - ["r" math/random "r/" Monad] - [meta] - (meta [code] - [type "type/" Eq] - (type ["tc" check])) - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" structure] - ["@;" common]) - ["@;" module]) - (.. common) - (test/luxc common)) - -(context: "Sums" - (<| (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]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) - - _ - false))) - (test "Can analyse sum through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do meta;Monad - [_ (&;with-type-env - (tc;check varT variantT))] - (&;with-expected-type varT - (@;analyse-sum analyse choice valueC)))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ sumA]) - [(la;unfold-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 - - _ - 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) - (n.= choice +choice)))) - )))) - -(context: "Products" - (<| (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 (la;unfold-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 (la;unfold-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 - - (#e;Error error) - false))) - (test "Can analyse product through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do meta;Monad - [_ (&;with-type-env - (tc;check varT (type;tuple (list/map product;left primitives))))] - (&;with-expected-type varT - (@;analyse-product analyse (list/map product;right primitives))))))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ tupleA]) - (n.= size (list;size (la;unfold-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 - - (#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))) - )))) - -(def: (check-variant-inference variantT choice size analysis) - (-> Type Nat Nat (Meta [Module Scope Type la;Analysis]) Bool) - (|> analysis - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ sumT sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (type/= variantT sumT) - (n.= tag choice) - (bool/= last? (n.= (n.dec size) choice))) - - _ - false))) - -(def: (check-record-inference tupleT size analysis) - (-> Type Nat (Meta [Module Scope Type la;Analysis]) Bool) - (|> analysis - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productT productA]) - [(la;unfold-tuple productA) - membersA]) - (and (type/= tupleT productT) - (n.= size (list;size membersA))) - - _ - false))) - -(context: "Tagged Sums" - (<| (times +100) - (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - choice (|> r;nat (:: @ map (n.% size))) - other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - #let [varT (#;Bound +1) - primitivesT (list/map product;left primitives) - [choiceT choiceC] (maybe;assume (list;nth choice primitives)) - [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) - variantT (type;variant primitivesT) - namedT (#;Named [module-name type-name] variantT) - polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) - (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT) - choice-tag (maybe;assume (list;nth choice tags)) - other-choice-tag (maybe;assume (list;nth other-choice tags))]] - ($_ seq - (test "Can infer tagged sum." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) - (test "Tagged sums specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) - (test "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (check-variant-inference polyT other-choice size))) - (test "Can specialize generic tagged sums." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type variantT - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag other-choice) - (bool/= last? (n.= (n.dec size) other-choice))) - - _ - false))) - )))) - -(context: "Records" - (<| (times +100) - (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - choice (|> r;nat (:: @ map (n.% size))) - #let [varT (#;Bound +1) - tagsC (list/map (|>. [module-name] code;tag) tags) - primitivesT (list/map product;left primitives) - primitivesC (list/map product;right primitives) - tupleT (type;tuple primitivesT) - namedT (#;Named [module-name type-name] tupleT) - recordC (list;zip2 tagsC primitivesC) - polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) - (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT)]] - ($_ seq - (test "Can infer record." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (test "Records specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (test "Can specialize generic records." - (|> (@module;with-module +0 module-name - (do meta;Monad - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type tupleT - (@;analyse-record analyse recordC))))) - (meta;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productA]) - [(la;unfold-tuple productA) - membersA]) - (n.= size (list;size membersA)) - - _ - false))) - )))) diff --git a/new-luxc/test/test/luxc/analyser/type.lux b/new-luxc/test/test/luxc/analyser/type.lux deleted file mode 100644 index 978e450b6..000000000 --- a/new-luxc/test/test/luxc/analyser/type.lux +++ /dev/null @@ -1,91 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - [text "text/" Eq] - (text format - ["l" lexer]) - [number] - ["e" error] - [product] - (coll [list "list/" Functor Fold])) - ["r" math/random "r/" Monad] - [meta #+ Monad] - (meta [code] - [type "type/" Eq]) - test) - (luxc ["&" base] - ["&;" module] - (lang ["~" analysis]) - [analyser] - (analyser ["@" type] - ["@;" common]) - (generator ["@;" runtime]) - [eval]) - (.. common) - (test/luxc common)) - -(def: check - (r;Random [Code Type Code]) - (with-expansions [ (do-template [ ] - [(do r;Monad - [value ] - (wrap [(` ) - - ( value)]))] - - [r;bool (+0 "#Bool" (+0)) code;bool] - [r;nat (+0 "#Nat" (+0)) code;nat] - [r;int (+0 "#Int" (+0)) code;int] - [r;deg (+0 "#Deg" (+0)) code;deg] - [r;frac (+0 "#Frac" (+0)) code;frac] - [(r;text +5) (+0 "#Text" (+0)) code;text] - )] - ($_ r;either - ))) - -(context: "Type checking/coercion." - (<| (times +100) - (do @ - [[typeC codeT exprC] check] - ($_ seq - (test (format "Can analyse type-checking.") - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-check analyse eval;eval typeC exprC)))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) - (and (type/= codeT analysisT) - (case [exprC analysisA] - (^template [ ] - [[_ ( expected)] [_ ( actual)]] - ( expected actual)) - ([#;Bool bool/=] - [#;Nat n.=] - [#;Int i.=] - [#;Deg d.=] - [#;Frac f.=] - [#;Text text/=]) - - _ - false)) - - (#e;Error error) - false))) - (test (format "Can analyse type-coercion.") - (|> (do Monad - [runtime-bytecode @runtime;generate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-coerce analyse eval;eval typeC exprC)))) - (meta;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) - (type/= codeT analysisT) - - (#e;Error error) - false))) - )))) diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux index cfbe31de8..7763cd852 100644 --- a/new-luxc/test/test/luxc/generator/case.lux +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -11,7 +11,6 @@ (meta [code]) test) (luxc (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator ["@" case] [";G" expression] diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux index 5620996b5..e7a0e7d61 100644 --- a/new-luxc/test/test/luxc/generator/function.lux +++ b/new-luxc/test/test/luxc/generator/function.lux @@ -14,7 +14,6 @@ [host] test) (luxc (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index 84f47f146..6de14d0e5 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -13,7 +13,6 @@ test) (luxc [";L" host] (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" runtime] 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 79829672d..5e3c07bea 100644 --- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux @@ -17,7 +17,6 @@ [host] test) (luxc (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] 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 8db98ed37..d571c578b 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -18,7 +18,6 @@ test) (luxc [";L" host] (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 9143ba5c8..37320fa99 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -17,7 +17,6 @@ test) (luxc [";L" host] (lang ["ls" synthesis]) - [analyser] [synthesizer] (generator [";G" expression] ["@;" eval] diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/new-luxc/test/test/luxc/lang/analysis/case.lux new file mode 100644 index 000000000..66646754e --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/case.lux @@ -0,0 +1,227 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + ["R" error] + [product] + [maybe] + [text "T/" Eq] + text/format + (coll [list "L/" Monad] + ["S" set])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type "type/" Eq] + (type ["tc" check])) + test) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" expression] + ["@" case] + ["@;" common])) + ["@;" module]) + (.. common) + (test/luxc common)) + +(def: (exhaustive-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #;Nil + #;Nil + + (#;Cons head+ #;Nil) + (L/map (|>. list) head+) + + (#;Cons head+ tail++) + (do list;Monad + [tail+ (exhaustive-weaving tail++) + head head+] + (wrap (#;Cons head tail+))))) + +(def: #export (exhaustive-branches allow-literals? variantTC inputC) + (-> Bool (List [Code Code]) Code (r;Random (List Code))) + (case inputC + [_ (#;Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do r;Monad + [?sample (r;maybe )] + (case ?sample + (#;Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( sample) else))) + + #;None + (wrap (list (' _))))) + (r/wrap (list (' _))))) + ([#;Nat r;nat code;nat] + [#;Int r;int code;int] + [#;Deg r;deg code;deg] + [#;Frac r;frac code;frac] + [#;Text (r;text +5) code;text]) + + (^ [_ (#;Tuple (list))]) + (r/wrap (list (' []))) + + (^ [_ (#;Record (list))]) + (r/wrap (list (' {}))) + + [_ (#;Tuple members)] + (do r;Monad + [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (L/map code;tuple)))) + + [_ (#;Record kvs)] + (do r;Monad + [#let [ks (L/map product;left kvs) + vs (L/map product;right kvs)] + member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (L/map (|>. (list;zip2 ks) code;record))))) + + (^ [_ (#;Form (list [_ (#;Tag _)] _))]) + (do r;Monad + [bundles (monad;map @ + (function [[_tag _code]] + (do @ + [v-branches (exhaustive-branches allow-literals? variantTC _code)] + (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (L/join bundles))) + + _ + (r/wrap (list)) + )) + +(def: #export (input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (r;Random Code)) + (r;rec + (function [input] + ($_ r;either + (r/map product;right gen-primitive) + (do r;Monad + [choice (|> r;nat (:: @ map (n.% (list;size variant-tags)))) + #let [choiceT (maybe;assume (list;nth choice variant-tags)) + choiceC (maybe;assume (list;nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do r;Monad + [size (|> r;nat (:: @ map (n.% +3))) + elems (r;list size input)] + (wrap (code;tuple elems))) + (r/wrap (code;record (list;zip2 record-tags primitivesC))) + )))) + +(def: (branch body pattern) + (-> Code Code [Code Code]) + [pattern body]) + +(context: "Pattern-matching." + ## #seed +9253409297339902486 + ## #seed +3793366152923578600 + (<| (seed +5004137551292836565) + ## (times +100) + (do @ + [module-name (r;text +5) + variant-name (r;text +5) + record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) + size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + variant-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + record-tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + primitivesTC (r;list size gen-primitive) + #let [primitivesT (L/map product;left primitivesTC) + primitivesC (L/map product;right primitivesTC) + variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) + record-tags+ (L/map (|>. [module-name] code;tag) record-tags) + variantTC (list;zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] gen-primitive + [heterogeneousT heterogeneousC] (|> gen-primitive + (r;filter (|>. product;left (tc;checks? outputT) not))) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) + heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) + #let [exhaustive-branchesC (L/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list;take (n.dec (list;size exhaustive-branchesC)) + exhaustive-branchesC) + redundant-branchesC (<| (L/map (branch outputC)) + list;concat + (list (list;take redundancy-idx redundant-patterns) + (list (maybe;assume (list;nth redundancy-idx redundant-patterns))) + (list;drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe;assume (list;nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list;drop (n.inc heterogeneous-idx) exhaustive-branchesC))) + ]] + ($_ seq + (test "Will reject empty pattern-matching (no branches)." + (|> (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC (list)))) + check-failure)) + (test "Can analyse exhaustive pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC exhaustive-branchesC))))) + check-success)) + (test "Will reject non-exhaustive pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC non-exhaustive-branchesC))))) + check-failure)) + (test "Will reject redundant pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC redundant-branchesC))))) + check-failure)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (@module;with-module +0 module-name + (do Monad + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC heterogeneous-branchesC))))) + check-failure)) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/common.lux b/new-luxc/test/test/luxc/lang/analysis/common.lux new file mode 100644 index 000000000..937ed4cda --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/common.lux @@ -0,0 +1,52 @@ +(;module: + lux + (lux (control pipe) + ["r" math/random "r/" Monad] + (data ["e" error]) + [meta] + (meta [code])) + (luxc ["&" base] + (lang (analysis [";A" expression])) + [eval]) + (test/luxc common)) + +(def: gen-unit + (r;Random Code) + (r/wrap (' []))) + +(def: #export gen-primitive + (r;Random [Type Code]) + (with-expansions + [ (do-template [ ] + [(r;seq (r/wrap ) (r/map ))] + + [Unit code;tuple (r;list +0 gen-unit)] + [Bool code;bool r;bool] + [Nat code;nat r;nat] + [Int code;int r;int] + [Deg code;deg r;deg] + [Frac code;frac r;frac] + [Text code;text (r;text +5)] + )] + ($_ r;either + + ))) + +(def: #export analyse + &;Analyser + (expressionA;analyser eval;eval)) + +(do-template [ ] + [(def: #export ( analysis) + (All [a] (-> (Meta a) Bool)) + (|> analysis + (meta;run (init-compiler [])) + (case> (#e;Success _) + + + (#e;Error error) + )))] + + [check-success true false] + [check-failure false true] + ) diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux new file mode 100644 index 000000000..1a2f13458 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/function.lux @@ -0,0 +1,154 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [product] + [text "text/" Eq] + text/format + (coll [list "list/" Functor])) + ["r" math/random "r/" Monad] + [meta] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" expression] + ["@" function] + ["@;" common])) + ["@;" module]) + (.. common) + (test/luxc common)) + +(def: (check-type expectedT error) + (-> Type (e;Error [Type la;Analysis]) Bool) + (case error + (#e;Success [exprT exprA]) + (type/= expectedT exprT) + + _ + false)) + +(def: (succeeds? error) + (All [a] (-> (e;Error a) Bool)) + (case error + (#e;Success _) + true + + (#e;Error _) + false)) + +(def: (flatten-apply analysis) + (-> la;Analysis [la;Analysis (List la;Analysis)]) + (case analysis + (^code ("lux apply" (~ head) (~ func))) + (let [[func' tail] (flatten-apply func)] + [func' (#;Cons head tail)]) + + _ + [analysis (list)])) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Meta [Type la;Analysis]) Bool) + (|> analysis + (meta;run (init-compiler [])) + (case> (#e;Success [applyT applyA]) + (let [[funcA argsA] (flatten-apply applyA)] + (and (type/= expectedT applyT) + (n.= num-args (list;size argsA)))) + + (#e;Error error) + false))) + +(context: "Function definition." + (<| (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?)) + )))) + +(context: "Function application." + (<| (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 (' []) inputsC)) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (' []) + (list;take partial-args inputsC))) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (' []) inputsC)) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (' []) + (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 (' []) + (list;take var-idx inputsC))) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/primitive.lux b/new-luxc/test/test/luxc/lang/analysis/primitive.lux new file mode 100644 index 000000000..41dc9fada --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/primitive.lux @@ -0,0 +1,67 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + [text "T/" Eq] + (text format + ["l" lexer]) + [number] + ["e" error] + [product] + (coll [list "L/" Functor Fold])) + ["r" math/random] + [meta #+ Monad] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + ["&;" module] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" primitive] + ["@;" common]))) + (.. common) + (test/luxc common)) + +(context: "Primitives" + (<| (times +100) + (do @ + [%bool% r;bool + %nat% r;nat + %int% r;int + %deg% r;deg + %frac% r;frac + %text% (r;text +5)] + (`` ($_ seq + (test "Can analyse unit." + (|> (@common;with-unknown-type + @;analyse-unit) + (meta;run (init-compiler [])) + (case> (^ (#e;Success [_type (^code [])])) + (type/= Unit _type) + + _ + false)) + ) + (~~ (do-template [ ] + [(test (format "Can analyse " ".") + (|> (@common;with-unknown-type + ( )) + (meta;run (init-compiler [])) + (case> (#e;Success [_type [_ ( value)]]) + (and (type/= _type) + (is value)) + + _ + false)) + )] + + ["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] + ))))))) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux new file mode 100644 index 000000000..134421732 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux @@ -0,0 +1,423 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + ["e" error] + [product] + (coll [array])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + ["&;" scope] + ["&;" module] + [";L" eval] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" procedure] + ["@;" common]))) + (../.. common) + (test/luxc common)) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (&;with-scope + (&;with-expected-type output-type + (@;analyse-procedure analyse evalL;eval procedure params))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + + + (#e;Error error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(context: "Lux procedures" + (<| (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" + (<| (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" + (<| (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" + (<| (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" + (<| (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 subjectC natC) Deg)) + )))) + +(context: "Frac procedures" + (<| (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 decode" (list encodedC) (type (Maybe Frac)))) + )))) + +(context: "Text procedures" + (<| (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" + (<| (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 evalL;eval "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 evalL;eval "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 evalL;eval "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 evalL;eval "lux array size" + (list (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + )))) + +(context: "Math procedures" + (<| (times +100) + (do @ + [subjectC (|> r;frac (:: @ map code;frac)) + paramC (|> r;frac (:: @ map code;frac))] + (with-expansions [ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC) Frac))] + + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math root2" "square root"] + ["lux math root3" "cubic root"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"]) + (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] + + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"])] + ($_ seq + + ))))) + +(context: "Atom procedures" + (<| (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 evalL;eval "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 evalL;eval "lux atom compare-and-swap" + (list elemC + elemC + (code;symbol ["" var-name])))))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + true + + (#e;Error _) + false))) + )))) + +(context: "Process procedures" + (<| (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" + (<| (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/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..333a60353 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux @@ -0,0 +1,529 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data ["e" error] + [product] + [maybe] + [text "text/" Eq] + text/format + (coll [array] + [list "list/" Fold] + [dict])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type]) + test) + (luxc ["&" base] + ["&;" scope] + ["&;" module] + [";L" eval] + (lang ["~" analysis] + (analysis [";A" expression] + ["@;" common] + ["@" procedure] + (procedure ["@;" host]))) + (generator ["@;" runtime])) + (../.. common) + (test/luxc common)) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (&;with-expected-type output-type + (@;analyse-procedure analyse evalL;eval procedure params)))) + (meta;run (init-compiler [])) + (case> (#e;Success _) + + + (#e;Error error) + )))] + + [success true false] + [failure false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert double-to-float" "java.lang.Double" @host;Float] + ["jvm convert double-to-int" "java.lang.Double" @host;Integer] + ["jvm convert double-to-long" "java.lang.Double" @host;Long] + ["jvm convert float-to-double" "java.lang.Float" @host;Double] + ["jvm convert float-to-int" "java.lang.Float" @host;Integer] + ["jvm convert float-to-long" "java.lang.Float" @host;Long] + )] + ($_ seq + + ))) + +(context: "Conversions [int]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert int-to-byte" "java.lang.Integer" @host;Byte] + ["jvm convert int-to-char" "java.lang.Integer" @host;Character] + ["jvm convert int-to-double" "java.lang.Integer" @host;Double] + ["jvm convert int-to-float" "java.lang.Integer" @host;Float] + ["jvm convert int-to-long" "java.lang.Integer" @host;Long] + ["jvm convert int-to-short" "java.lang.Integer" @host;Short] + )] + ($_ seq + + ))) + +(context: "Conversions [long]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert long-to-double" "java.lang.Long" @host;Double] + ["jvm convert long-to-float" "java.lang.Long" @host;Float] + ["jvm convert long-to-int" "java.lang.Long" @host;Integer] + ["jvm convert long-to-short" "java.lang.Long" @host;Short] + ["jvm convert long-to-byte" "java.lang.Long" @host;Byte] + )] + ($_ seq + + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert char-to-byte" "java.lang.Character" @host;Byte] + ["jvm convert char-to-short" "java.lang.Character" @host;Short] + ["jvm convert char-to-int" "java.lang.Character" @host;Integer] + ["jvm convert char-to-long" "java.lang.Character" @host;Long] + ["jvm convert byte-to-long" "java.lang.Byte" @host;Long] + ["jvm convert short-to-long" "java.lang.Short" @host;Long] + )] + ($_ seq + + ))) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") @host;Boolean] + [(format "jvm " " <") @host;Boolean] + )] + ($_ seq + + ))) + + (context: (format "Bitwise " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " and") ] + [(format "jvm " " or") ] + [(format "jvm " " xor") ] + [(format "jvm " " shl") "java.lang.Integer" ] + [(format "jvm " " shr") "java.lang.Integer" ] + [(format "jvm " " ushr") "java.lang.Integer" ] + )] + ($_ seq + + )))] + + + ["int" "java.lang.Integer" @host;Integer] + ["long" "java.lang.Long" @host;Long] + ) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") @host;Boolean] + [(format "jvm " " <") @host;Boolean] + )] + ($_ seq + + )))] + + + ["float" "java.lang.Float" @host;Float] + ["double" "java.lang.Double" @host;Double] + ) + +(do-template [ ] + [(context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") @host;Boolean] + [(format "jvm " " <") @host;Boolean] + )] + ($_ seq + + )))] + + + ["char" "java.lang.Character" @host;Character] + ) + +(def: array-type + (r;Random [Text Text]) + (let [entries (dict;entries @host;boxes) + num-entries (list;size entries)] + (do r;Monad + [choice (|> r;nat (:: @ map (n.% (n.inc num-entries)))) + #let [[unboxed boxed] (: [Text Text] + (|> entries + (list;nth choice) + (maybe;default ["java.lang.Object" "java.lang.Object"])))]] + (wrap [unboxed boxed])))) + +(context: "Array." + (<| (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) + (list "java.lang.Throwable" + "java.lang.Error" + "java.io.IOError" + "java.lang.VirtualMachineError" + "java.lang.Exception" + "java.io.IOException" + "java.lang.RuntimeException")) + +(context: "Object." + (<| (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 + (test "jvm member static get" + (success "jvm member static get" + (list (code;text "java.lang.System") + (code;text "out")) + (#;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")) + (#;Primitive "java.lang.Object" (list)))) + (test "jvm member static put" + (success "jvm member static put" + (list (code;text "java.awt.datatransfer.DataFlavor") + (code;text "allHtmlFlavor") + (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) + ("jvm object null")))) + Unit)) + (test "jvm member static put (final)" + (failure "jvm member static put" + (list (code;text "java.lang.System") + (code;text "out") + (`' ("lux check" (+0 "java.io.PrintStream" (+0)) + ("jvm object null")))) + Unit)) + (test "jvm member static put (inheritance in)" + (success "jvm member static put" + (list (code;text "java.awt.datatransfer.DataFlavor") + (code;text "allHtmlFlavor") + (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null")))) + Unit)) + )) + +(context: "Member [Virtual Field]." + ($_ seq + (test "jvm member virtual get" + (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")))) + (#;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")))) + (#;Primitive "java.lang.Object" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code;text "org.omg.CORBA.ValueMember") + (code;text "id") + (`' ("lux check" (+0 "java.lang.String" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (primitive org.omg.CORBA.ValueMember))) + (test "jvm member virtual put (final)" + (failure "jvm member virtual put" + (list (code;text "javax.swing.text.html.parser.DTD") + (code;text "applet") + (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) + ("jvm object null")))) + (primitive javax.swing.text.html.parser.DTD))) + (test "jvm member virtual put (inheritance in)" + (success "jvm member virtual put" + (list (code;text "java.awt.GridBagConstraints") + (code;text "insets") + (`' ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) + ("jvm object null")))) + (primitive java.awt.GridBagConstraints))) + )) + +(context: "Boxing/Unboxing." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code;text "java.util.GregorianCalendar") + (code;text "AD")) + (#;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")))) + (#;Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code;text "javax.accessibility.AccessibleAttributeSequence") + (code;text "startIndex") + (`' ("lux check" (+0 "java.lang.Integer" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (primitive javax.accessibility.AccessibleAttributeSequence))) + )) + +(context: "Member [Method]." + (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) + +123)) + intC (`' ("jvm convert long-to-int" (~ longC))) + objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) + ("jvm member invoke constructor" "java.util.ArrayList" + ["int" (~ intC)])))] + ($_ seq + (test "jvm member invoke static" + (success "jvm member invoke static" + (list (code;text "java.lang.Long") + (code;text "decode") + (code;tuple (list (' "java.lang.String") + (' ("lux coerce" (+0 "java.lang.String" (+0)) + "YOLO"))))) + (#;Primitive "java.lang.Long" (list)))) + (test "jvm member invoke virtual" + (success "jvm member invoke virtual" + (list (code;text "java.lang.Object") + (code;text "equals") + longC + (code;tuple (list (' "java.lang.Object") + longC))) + (#;Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke special" + (success "jvm member invoke special" + (list (code;text "java.lang.Long") + (code;text "equals") + longC + (code;tuple (list (' "java.lang.Object") + longC))) + (#;Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke interface" + (success "jvm member invoke interface" + (list (code;text "java.util.Collection") + (code;text "add") + objectC + (code;tuple (list (' "java.lang.Object") + longC))) + (#;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] (#;Primitive "java.util.ArrayList" (list a))))) + ))) diff --git a/new-luxc/test/test/luxc/lang/analysis/reference.lux b/new-luxc/test/test/luxc/lang/analysis/reference.lux new file mode 100644 index 000000000..f6021e184 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/reference.lux @@ -0,0 +1,52 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error]) + ["r" math/random] + [meta #+ Monad] + (meta [type "type/" Eq]) + test) + (luxc ["&;" scope] + ["&;" module] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" reference] + ["@;" common]))) + (.. common) + (test/luxc common)) + +(context: "References" + (<| (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 (^code ((~ [_ (#;Int var)])))])) + (type/= ref-type _type) + + _ + false))) + (test "Can analyse definition." + (|> (do Monad + [_ (&module;create +0 module-name) + _ (&module;define [module-name var-name] + [ref-type (' {}) (:! Void [])])] + (@common;with-unknown-type + (@;analyse-reference [module-name var-name]))) + (meta;run (init-compiler [])) + (case> (#e;Success [_type [_ (#;Symbol def-name)]]) + (type/= ref-type _type) + + _ + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux new file mode 100644 index 000000000..507b61995 --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/structure.lux @@ -0,0 +1,336 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + ["e" error] + [product] + [maybe] + [text] + text/format + (coll [list "list/" Functor] + ["S" set])) + ["r" math/random "r/" Monad] + [meta] + (meta [code] + [type "type/" Eq] + (type ["tc" check])) + test) + (luxc ["&" base] + (lang ["la" analysis] + (analysis [";A" expression] + ["@" structure] + ["@;" common])) + ["@;" module]) + (.. common) + (test/luxc common)) + +(context: "Sums" + (<| (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]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) + + _ + false))) + (test "Can analyse sum through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do meta;Monad + [_ (&;with-type-env + (tc;check varT variantT))] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC)))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ sumA]) + [(la;unfold-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 + + _ + 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) + (n.= choice +choice)))) + )))) + +(context: "Products" + (<| (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 (la;unfold-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 (la;unfold-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 + + (#e;Error error) + false))) + (test "Can analyse product through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do meta;Monad + [_ (&;with-type-env + (tc;check varT (type;tuple (list/map product;left primitives))))] + (&;with-expected-type varT + (@;analyse-product analyse (list/map product;right primitives))))))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ tupleA]) + (n.= size (list;size (la;unfold-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 + + (#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))) + )))) + +(def: (check-variant-inference variantT choice size analysis) + (-> Type Nat Nat (Meta [Module Scope Type la;Analysis]) Bool) + (|> analysis + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ sumT sumA]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (type/= variantT sumT) + (n.= tag choice) + (bool/= last? (n.= (n.dec size) choice))) + + _ + false))) + +(def: (check-record-inference tupleT size analysis) + (-> Type Nat (Meta [Module Scope Type la;Analysis]) Bool) + (|> analysis + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ productT productA]) + [(la;unfold-tuple productA) + membersA]) + (and (type/= tupleT productT) + (n.= size (list;size membersA))) + + _ + false))) + +(context: "Tagged Sums" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + choice (|> r;nat (:: @ map (n.% size))) + other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) + primitives (r;list size gen-primitive) + module-name (r;text +5) + type-name (r;text +5) + #let [varT (#;Bound +1) + primitivesT (list/map product;left primitives) + [choiceT choiceC] (maybe;assume (list;nth choice primitives)) + [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) + variantT (type;variant primitivesT) + namedT (#;Named [module-name type-name] variantT) + polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT) + choice-tag (maybe;assume (list;nth choice tags)) + other-choice-tag (maybe;assume (list;nth other-choice tags))]] + ($_ seq + (test "Can infer tagged sum." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (test "Tagged sums specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (check-variant-inference polyT other-choice size))) + (test "Can specialize generic tagged sums." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type variantT + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ sumA]) + [(la;unfold-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag other-choice) + (bool/= last? (n.= (n.dec size) other-choice))) + + _ + false))) + )))) + +(context: "Records" + (<| (times +100) + (do @ + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash size (r;text +5)) (:: @ map S;to-list)) + primitives (r;list size gen-primitive) + module-name (r;text +5) + type-name (r;text +5) + choice (|> r;nat (:: @ map (n.% size))) + #let [varT (#;Bound +1) + tagsC (list/map (|>. [module-name] code;tag) tags) + primitivesT (list/map product;left primitives) + primitivesC (list/map product;right primitives) + tupleT (type;tuple primitivesT) + namedT (#;Named [module-name type-name] tupleT) + recordC (list;zip2 tagsC primitivesC) + polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT)]] + ($_ seq + (test "Can infer record." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Records specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Can specialize generic records." + (|> (@module;with-module +0 module-name + (do meta;Monad + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type tupleT + (@;analyse-record analyse recordC))))) + (meta;run (init-compiler [])) + (case> (^multi (#e;Success [_ _ productA]) + [(la;unfold-tuple productA) + membersA]) + (n.= size (list;size membersA)) + + _ + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/type.lux b/new-luxc/test/test/luxc/lang/analysis/type.lux new file mode 100644 index 000000000..649c33fef --- /dev/null +++ b/new-luxc/test/test/luxc/lang/analysis/type.lux @@ -0,0 +1,91 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + [text "text/" Eq] + (text format + ["l" lexer]) + [number] + ["e" error] + [product] + (coll [list "list/" Functor Fold])) + ["r" math/random "r/" Monad] + [meta #+ Monad] + (meta [code] + [type "type/" Eq]) + test) + (luxc ["&" base] + ["&;" module] + (lang ["~" analysis] + (analysis [";A" expression] + ["@" type] + ["@;" common])) + (generator ["@;" runtime]) + [eval]) + (.. common) + (test/luxc common)) + +(def: check + (r;Random [Code Type Code]) + (with-expansions [ (do-template [ ] + [(do r;Monad + [value ] + (wrap [(` ) + + ( value)]))] + + [r;bool (+0 "#Bool" (+0)) code;bool] + [r;nat (+0 "#Nat" (+0)) code;nat] + [r;int (+0 "#Int" (+0)) code;int] + [r;deg (+0 "#Deg" (+0)) code;deg] + [r;frac (+0 "#Frac" (+0)) code;frac] + [(r;text +5) (+0 "#Text" (+0)) code;text] + )] + ($_ r;either + ))) + +(context: "Type checking/coercion." + (<| (times +100) + (do @ + [[typeC codeT exprC] check] + ($_ seq + (test (format "Can analyse type-checking.") + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (@common;with-unknown-type + (@;analyse-check analyse eval;eval typeC exprC)))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ [analysisT analysisA]]) + (and (type/= codeT analysisT) + (case [exprC analysisA] + (^template [ ] + [[_ ( expected)] [_ ( actual)]] + ( expected actual)) + ([#;Bool bool/=] + [#;Nat n.=] + [#;Int i.=] + [#;Deg d.=] + [#;Frac f.=] + [#;Text text/=]) + + _ + false)) + + (#e;Error error) + false))) + (test (format "Can analyse type-coercion.") + (|> (do Monad + [runtime-bytecode @runtime;generate] + (&;with-scope + (@common;with-unknown-type + (@;analyse-coerce analyse eval;eval typeC exprC)))) + (meta;run (init-compiler [])) + (case> (#e;Success [_ [analysisT analysisA]]) + (type/= codeT analysisT) + + (#e;Error error) + false))) + )))) diff --git a/new-luxc/test/test/luxc/lang/parser.lux b/new-luxc/test/test/luxc/lang/parser.lux new file mode 100644 index 000000000..c70bdaece --- /dev/null +++ b/new-luxc/test/test/luxc/lang/parser.lux @@ -0,0 +1,233 @@ +(;module: + lux + (lux [io] + (control [monad #+ do]) + (data [number] + ["e" error] + [text] + (text format + ["l" lexer]) + (coll [list])) + ["r" math/random "r/" Monad] + (meta [code]) + test) + (luxc (lang ["&" parser]))) + +(def: default-cursor + Cursor + {#;module "" + #;line +0 + #;column +0}) + +(def: ident-part^ + (r;Random Text) + (do r;Monad + [#let [digits "0123456789" + delimiters "()[]{}#;\"" + space "\t\v \n\r\f" + invalid-range (format digits delimiters space) + char-gen (|> r;nat + (r;filter (function [sample] + (not (text;contains? (text;from-code sample) + invalid-range)))))] + size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))] + (r;text' char-gen size))) + +(def: ident^ + (r;Random Ident) + (r;seq ident-part^ ident-part^)) + +(def: code^ + (r;Random Code) + (let [numeric^ (: (r;Random Code) + ($_ r;either + (|> r;bool (r/map (|>. #;Bool [default-cursor]))) + (|> r;nat (r/map (|>. #;Nat [default-cursor]))) + (|> r;int (r/map (|>. #;Int [default-cursor]))) + (|> r;deg (r/map (|>. #;Deg [default-cursor]))) + (|> r;frac (r/map (|>. #;Frac [default-cursor]))))) + textual^ (: (r;Random Code) + ($_ r;either + (do r;Monad + [size (|> r;nat (r/map (n.% +20)))] + (|> (r;text size) (r/map (|>. #;Text [default-cursor])))) + (|> ident^ (r/map (|>. #;Symbol [default-cursor]))) + (|> ident^ (r/map (|>. #;Tag [default-cursor]))))) + simple^ (: (r;Random Code) + ($_ r;either + numeric^ + textual^))] + (r;rec + (function [code^] + (let [multi^ (do r;Monad + [size (|> r;nat (r/map (n.% +3)))] + (r;list size code^)) + composite^ (: (r;Random Code) + ($_ r;either + (|> multi^ (r/map (|>. #;Form [default-cursor]))) + (|> multi^ (r/map (|>. #;Tuple [default-cursor]))) + (do r;Monad + [size (|> r;nat (r/map (n.% +3)))] + (|> (r;list size (r;seq code^ code^)) + (r/map (|>. #;Record [default-cursor]))))))] + (r;either simple^ + composite^)))))) + +(context: "Lux code parser." + (<| (times +100) + (do @ + [sample code^ + other code^] + ($_ seq + (test "Can parse Lux code." + (case (&;parse [default-cursor +0 (code;to-text sample)]) + (#e;Error error) + false + + (#e;Success [_ parsed]) + (:: code;Eq = parsed sample))) + (test "Can parse Lux multiple code nodes." + (case (&;parse [default-cursor +0 (format (code;to-text sample) " " + (code;to-text other))]) + (#e;Error error) + false + + (#e;Success [remaining =sample]) + (case (&;parse remaining) + (#e;Error error) + false + + (#e;Success [_ =other]) + (and (:: code;Eq = sample =sample) + (:: code;Eq = other =other))))) + )))) + +(def: nat-to-frac + (-> Nat Frac) + (|>. nat-to-int int-to-frac)) + +(context: "Frac special syntax." + (<| (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 +0 + (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." + (<| (times +100) + (do @ + [expected (|> r;nat (:: @ map (n.% +1_000)))] + (test "Can parse nat char syntax." + (case (&;parse [default-cursor +0 + (format "#" (%t (text;from-code expected)) "")]) + (#e;Success [_ [_ (#;Nat actual)]]) + (n.= expected actual) + + _ + false) + )))) + +(def: comment-text^ + (r;Random Text) + (let [char-gen (|> r;nat (r;filter (function [value] + (not (or (text;space? value) + (n.= (char "#") value) + (n.= (char "(") value) + (n.= (char ")") value))))))] + (do r;Monad + [size (|> r;nat (r/map (n.% +20)))] + (r;text' char-gen size)))) + +(def: comment^ + (r;Random Text) + (r;either (do r;Monad + [comment comment-text^] + (wrap (format "## " comment "\n"))) + (r;rec (function [nested^] + (do r;Monad + [comment (r;either comment-text^ + nested^)] + (wrap (format "#( " comment " )#"))))))) + +(context: "Multi-line text & comments." + (<| (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 +0 + (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)))) + +0 + (format "\"" good-input "\"")]) + (#e;Error error) + false + + (#e;Success [_ parsed]) + (:: code;Eq = + parsed + (code;text good-output))))) + (test "Can handle comments." + (case (&;parse [default-cursor +0 + (format comment (code;to-text sample))]) + (#e;Error error) + false + + (#e;Success [_ parsed]) + (:: code;Eq = parsed sample))) + (test "Will reject unbalanced multi-line comments." + (and (case (&;parse [default-cursor +0 + (format "#(" "#(" unbalanced-comment ")#" + (code;to-text sample))]) + (#e;Error error) + true + + (#e;Success [_ parsed]) + false) + (case (&;parse [default-cursor +0 + (format "#(" unbalanced-comment ")#" ")#" + (code;to-text sample))]) + (#e;Error error) + true + + (#e;Success [_ parsed]) + false))) + )))) diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux deleted file mode 100644 index 33a0bc154..000000000 --- a/new-luxc/test/test/luxc/parser.lux +++ /dev/null @@ -1,233 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do]) - (data [number] - ["e" error] - [text] - (text format - ["l" lexer]) - (coll [list])) - ["r" math/random "r/" Monad] - (meta [code]) - test) - (luxc ["&" parser])) - -(def: default-cursor - Cursor - {#;module "" - #;line +0 - #;column +0}) - -(def: ident-part^ - (r;Random Text) - (do r;Monad - [#let [digits "0123456789" - delimiters "()[]{}#;\"" - space "\t\v \n\r\f" - invalid-range (format digits delimiters space) - char-gen (|> r;nat - (r;filter (function [sample] - (not (text;contains? (text;from-code sample) - invalid-range)))))] - size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))] - (r;text' char-gen size))) - -(def: ident^ - (r;Random Ident) - (r;seq ident-part^ ident-part^)) - -(def: code^ - (r;Random Code) - (let [numeric^ (: (r;Random Code) - ($_ r;either - (|> r;bool (r/map (|>. #;Bool [default-cursor]))) - (|> r;nat (r/map (|>. #;Nat [default-cursor]))) - (|> r;int (r/map (|>. #;Int [default-cursor]))) - (|> r;deg (r/map (|>. #;Deg [default-cursor]))) - (|> r;frac (r/map (|>. #;Frac [default-cursor]))))) - textual^ (: (r;Random Code) - ($_ r;either - (do r;Monad - [size (|> r;nat (r/map (n.% +20)))] - (|> (r;text size) (r/map (|>. #;Text [default-cursor])))) - (|> ident^ (r/map (|>. #;Symbol [default-cursor]))) - (|> ident^ (r/map (|>. #;Tag [default-cursor]))))) - simple^ (: (r;Random Code) - ($_ r;either - numeric^ - textual^))] - (r;rec - (function [code^] - (let [multi^ (do r;Monad - [size (|> r;nat (r/map (n.% +3)))] - (r;list size code^)) - composite^ (: (r;Random Code) - ($_ r;either - (|> multi^ (r/map (|>. #;Form [default-cursor]))) - (|> multi^ (r/map (|>. #;Tuple [default-cursor]))) - (do r;Monad - [size (|> r;nat (r/map (n.% +3)))] - (|> (r;list size (r;seq code^ code^)) - (r/map (|>. #;Record [default-cursor]))))))] - (r;either simple^ - composite^)))))) - -(context: "Lux code parser." - (<| (times +100) - (do @ - [sample code^ - other code^] - ($_ seq - (test "Can parse Lux code." - (case (&;parse [default-cursor +0 (code;to-text sample)]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq = parsed sample))) - (test "Can parse Lux multiple code nodes." - (case (&;parse [default-cursor +0 (format (code;to-text sample) " " - (code;to-text other))]) - (#e;Error error) - false - - (#e;Success [remaining =sample]) - (case (&;parse remaining) - (#e;Error error) - false - - (#e;Success [_ =other]) - (and (:: code;Eq = sample =sample) - (:: code;Eq = other =other))))) - )))) - -(def: nat-to-frac - (-> Nat Frac) - (|>. nat-to-int int-to-frac)) - -(context: "Frac special syntax." - (<| (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 +0 - (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." - (<| (times +100) - (do @ - [expected (|> r;nat (:: @ map (n.% +1_000)))] - (test "Can parse nat char syntax." - (case (&;parse [default-cursor +0 - (format "#" (%t (text;from-code expected)) "")]) - (#e;Success [_ [_ (#;Nat actual)]]) - (n.= expected actual) - - _ - false) - )))) - -(def: comment-text^ - (r;Random Text) - (let [char-gen (|> r;nat (r;filter (function [value] - (not (or (text;space? value) - (n.= (char "#") value) - (n.= (char "(") value) - (n.= (char ")") value))))))] - (do r;Monad - [size (|> r;nat (r/map (n.% +20)))] - (r;text' char-gen size)))) - -(def: comment^ - (r;Random Text) - (r;either (do r;Monad - [comment comment-text^] - (wrap (format "## " comment "\n"))) - (r;rec (function [nested^] - (do r;Monad - [comment (r;either comment-text^ - nested^)] - (wrap (format "#( " comment " )#"))))))) - -(context: "Multi-line text & comments." - (<| (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 +0 - (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)))) - +0 - (format "\"" good-input "\"")]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq = - parsed - (code;text good-output))))) - (test "Can handle comments." - (case (&;parse [default-cursor +0 - (format comment (code;to-text sample))]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq = parsed sample))) - (test "Will reject unbalanced multi-line comments." - (and (case (&;parse [default-cursor +0 - (format "#(" "#(" unbalanced-comment ")#" - (code;to-text sample))]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false) - (case (&;parse [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code;to-text sample))]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false))) - )))) diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux index fb37f6104..2a1490193 100644 --- a/new-luxc/test/test/luxc/synthesizer/primitive.lux +++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux @@ -9,7 +9,6 @@ test) (luxc (lang ["la" analysis] ["ls" synthesis]) - [analyser] [synthesizer])) (context: "Primitives" diff --git a/new-luxc/test/test/luxc/synthesizer/procedure.lux b/new-luxc/test/test/luxc/synthesizer/procedure.lux index 68010adeb..c659c5e34 100644 --- a/new-luxc/test/test/luxc/synthesizer/procedure.lux +++ b/new-luxc/test/test/luxc/synthesizer/procedure.lux @@ -10,7 +10,6 @@ test) (luxc (lang ["la" analysis] ["ls" synthesis]) - (analyser [";A" structure]) [synthesizer]) (.. common)) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 13eb44402..c112e4076 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -5,15 +5,15 @@ (concurrency [promise]) [cli #+ program:] [test]) - (test (luxc ["_;P" parser] - (analyser ["_;A" primitive] - ["_;A" structure] - ["_;A" reference] - ["_;A" case] - ["_;A" function] - ["_;A" type] - (procedure ["_;A" common] - ["_;A" host])) + (test (luxc (lang ["_;P" parser] + (analysis ["_;A" primitive] + ["_;A" structure] + ["_;A" reference] + ["_;A" case] + ["_;A" function] + ["_;A" type] + (procedure ["_;A" common] + ["_;A" host]))) (synthesizer ["_;S" primitive] ["_;S" structure] (case ["_;S" special]) -- cgit v1.2.3