diff options
author | Eduardo Julian | 2017-12-01 18:13:05 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-12-01 18:13:05 -0400 |
commit | 84a71e373e01f36c57d1bf42b7946f3a8b212d4f (patch) | |
tree | 6aacee5d18fca8277c2c532b9e48aa8b3779d8e4 /new-luxc/test/test/luxc/lang/analysis | |
parent | 4433c9bcd6c6cac44c018aad2e21a5b4d7cc4896 (diff) |
- Got the tests to compile again.
Diffstat (limited to 'new-luxc/test/test/luxc/lang/analysis')
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/case.lux | 234 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/common.lux | 36 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/function.lux | 136 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/primitive.lux | 48 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/procedure/common.lux | 184 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux | 290 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/reference.lux | 42 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/structure.lux | 410 | ||||
-rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/type.lux | 70 |
9 files changed, 725 insertions, 725 deletions
diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/new-luxc/test/test/luxc/lang/analysis/case.lux index f99c034e8..50d31a86e 100644 --- a/new-luxc/test/test/luxc/lang/analysis/case.lux +++ b/new-luxc/test/test/luxc/lang/analysis/case.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -18,80 +18,80 @@ (type ["tc" check])) test) (luxc ["&" lang] - (lang ["@;" module] + (lang ["@." module] ["la" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" case] - ["@;" common]))) - (.. common) + ["@." common]))) + (// common) (test/luxc common)) (def: (exhaustive-weaving branchings) (-> (List (List Code)) (List (List Code))) (case branchings - #;Nil - #;Nil + #.Nil + #.Nil - (#;Cons head+ #;Nil) - (L/map (|>. list) head+) + (#.Cons head+ #.Nil) + (L/map (|>> list) head+) - (#;Cons head+ tail++) - (do list;Monad<List> + (#.Cons head+ tail++) + (do list.Monad<List> [tail+ (exhaustive-weaving tail++) head head+] - (wrap (#;Cons head tail+))))) + (wrap (#.Cons head tail+))))) (def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bool (List [Code Code]) Code (r;Random (List Code))) + (-> Bool (List [Code Code]) Code (r.Random (List Code))) (case inputC - [_ (#;Bool _)] + [_ (#.Bool _)] (r/wrap (list (' true) (' false))) (^template [<tag> <gen> <wrapper>] [_ (<tag> _)] (if allow-literals? - (do r;Monad<Random> - [?sample (r;maybe <gen>)] + (do r.Monad<Random> + [?sample (r.maybe <gen>)] (case ?sample - (#;Some sample) + (#.Some sample) (do @ [else (exhaustive-branches allow-literals? variantTC inputC)] (wrap (list& (<wrapper> sample) else))) - #;None + #.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]) + ([#.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))]) + (^ [_ (#.Tuple (list))]) (r/wrap (list (' []))) - (^ [_ (#;Record (list))]) + (^ [_ (#.Record (list))]) (r/wrap (list (' {}))) - [_ (#;Tuple members)] - (do r;Monad<Random> - [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] + [_ (#.Tuple members)] + (do r.Monad<Random> + [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] (wrap (|> member-wise-patterns exhaustive-weaving - (L/map code;tuple)))) + (L/map code.tuple)))) - [_ (#;Record kvs)] - (do r;Monad<Random> - [#let [ks (L/map product;left kvs) - vs (L/map product;right kvs)] - member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] + [_ (#.Record kvs)] + (do r.Monad<Random> + [#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))))) + (L/map (|>> (list.zip2 ks) code.record))))) - (^ [_ (#;Form (list [_ (#;Tag _)] _))]) - (do r;Monad<Random> - [bundles (monad;map @ + (^ [_ (#.Form (list [_ (#.Tag _)] _))]) + (do r.Monad<Random> + [bundles (monad.map @ (function [[_tag _code]] (do @ [v-branches (exhaustive-branches allow-literals? variantTC _code)] @@ -105,21 +105,21 @@ )) (def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r;Random Code)) - (r;rec + (-> (List Code) (List Code) (List Code) (r.Random Code)) + (r.rec (function [input] - ($_ r;either - (r/map product;right gen-primitive) - (do r;Monad<Random> - [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))]] + ($_ r.either + (r/map product.right gen-primitive) + (do r.Monad<Random> + [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<Random> - [size (|> r;nat (:: @ map (n.% +3))) - elems (r;list size input)] - (wrap (code;tuple elems))) - (r/wrap (code;record (list;zip2 record-tags primitivesC))) + (do r.Monad<Random> + [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) @@ -132,96 +132,96 @@ (<| (seed +5004137551292836565) ## (times +100) (do @ - [module-name (r;text +5) - variant-name (r;text +5) - record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) - size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - variant-tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) - record-tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) - primitivesTC (r;list size gen-primitive) - #let [primitivesT (L/map product;left primitivesTC) - primitivesC (L/map product;right primitivesTC) - variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) - record-tags+ (L/map (|>. [module-name] code;tag) record-tags) - variantTC (list;zip2 variant-tags+ primitivesC)] + [module-name (r.text +5) + variant-name (r.text +5) + record-name (|> (r.text +5) (r.filter (|>> (T/= variant-name) not))) + size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + variant-tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map S.to-list)) + record-tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map S.to-list)) + primitivesTC (r.list size gen-primitive) + #let [primitivesT (L/map product.left primitivesTC) + primitivesC (L/map product.right primitivesTC) + variant-tags+ (L/map (|>> [module-name] code.tag) variant-tags) + record-tags+ (L/map (|>> [module-name] code.tag) record-tags) + variantTC (list.zip2 variant-tags+ primitivesC)] inputC (input variant-tags+ record-tags+ primitivesC) [outputT outputC] gen-primitive [heterogeneousT heterogeneousC] (|> gen-primitive - (r;filter (|>. product;left (tc;checks? outputT) not))) + (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)))) + 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)) + 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))] + 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))) + (list.drop (n/inc heterogeneous-idx) exhaustive-branchesC))) ]] ($_ seq (test "Will reject empty pattern-matching (no branches)." - (|> (&;with-scope - (&;with-type outputT - (@;analyse-case analyse inputC (list)))) + (|> (&.with-scope + (&.with-type outputT + (@.analyse-case analyse inputC (list)))) check-failure)) (test "Can analyse exhaustive pattern-matching." - (|> (@module;with-module +0 module-name + (|> (@module.with-module +0 module-name (do Monad<Meta> - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-type outputT - (@;analyse-case analyse inputC exhaustive-branchesC))))) + [_ (@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-type outputT + (@.analyse-case analyse inputC exhaustive-branchesC))))) check-success)) (test "Will reject non-exhaustive pattern-matching." - (|> (@module;with-module +0 module-name + (|> (@module.with-module +0 module-name (do Monad<Meta> - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-type outputT - (@;analyse-case analyse inputC non-exhaustive-branchesC))))) + [_ (@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-type outputT + (@.analyse-case analyse inputC non-exhaustive-branchesC))))) check-failure)) (test "Will reject redundant pattern-matching." - (|> (@module;with-module +0 module-name + (|> (@module.with-module +0 module-name (do Monad<Meta> - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-type outputT - (@;analyse-case analyse inputC redundant-branchesC))))) + [_ (@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-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 + (|> (@module.with-module +0 module-name (do Monad<Meta> - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-type outputT - (@;analyse-case analyse inputC heterogeneous-branchesC))))) + [_ (@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-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 index e7b9dc486..38c712972 100644 --- a/new-luxc/test/test/luxc/lang/analysis/common.lux +++ b/new-luxc/test/test/luxc/lang/analysis/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control pipe) ["r" math/random "r/" Monad<Random>] @@ -6,45 +6,45 @@ [macro] (macro [code])) (luxc ["&" lang] - (lang (analysis [";A" expression]) + (lang (analysis [".A" expression]) [eval])) (test/luxc common)) (def: gen-unit - (r;Random Code) + (r.Random Code) (r/wrap (' []))) (def: #export gen-primitive - (r;Random [Type Code]) + (r.Random [Type Code]) (with-expansions [<generators> (do-template [<type> <code-wrapper> <value-gen>] - [(r;seq (r/wrap <type>) (r/map <code-wrapper> <value-gen>))] + [(r.seq (r/wrap <type>) (r/map <code-wrapper> <value-gen>))] - [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)] + [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 + ($_ r.either <generators> ))) (def: #export analyse - &;Analyser - (expressionA;analyser eval;eval)) + &.Analyser + (expressionA.analyser eval.eval)) (do-template [<name> <on-success> <on-failure>] [(def: #export (<name> analysis) (All [a] (-> (Meta a) Bool)) (|> analysis - (macro;run (init-compiler [])) - (case> (#e;Success _) + (macro.run (init-compiler [])) + (case> (#e.Success _) <on-success> - (#e;Error error) + (#e.Error error) <on-failure>)))] [check-success true false] diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux index b99e5e2ee..3f8a17505 100644 --- a/new-luxc/test/test/luxc/lang/analysis/function.lux +++ b/new-luxc/test/test/luxc/lang/analysis/function.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -15,140 +15,140 @@ (lang [type "type/" Eq<Type>]) test) (luxc ["&" lang] - (lang ["@;" module] + (lang ["@." module] ["la" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" function] - ["@;" common]))) - (.. common) + ["@." common]))) + (// common) (test/luxc common)) (def: (check-type expectedT error) - (-> Type (e;Error [Type la;Analysis]) Bool) + (-> Type (e.Error [Type la.Analysis]) Bool) (case error - (#e;Success [exprT exprA]) + (#e.Success [exprT exprA]) (type/= expectedT exprT) _ false)) (def: (succeeds? error) - (All [a] (-> (e;Error a) Bool)) + (All [a] (-> (e.Error a) Bool)) (case error - (#e;Success _) + (#e.Success _) true - (#e;Error _) + (#e.Error _) false)) (def: (flatten-apply analysis) - (-> la;Analysis [la;Analysis (List la;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)]) + [func' (#.Cons head tail)]) _ [analysis (list)])) (def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta [Type la;Analysis]) Bool) + (-> Type Nat (Meta [Type la.Analysis]) Bool) (|> analysis - (macro;run (init-compiler [])) - (case> (#e;Success [applyT applyA]) + (macro.run (init-compiler [])) + (case> (#e.Success [applyT applyA]) (let [[funcA argsA] (flatten-apply applyA)] (and (type/= expectedT applyT) - (n.= num-args (list;size argsA)))) + (n/= num-args (list.size argsA)))) - (#e;Error error) + (#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))) + [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-type (type (All [a] (-> a outputT))) - (@;analyse-function analyse func-name arg-name outputC)) - (macro;run (init-compiler [])) + (|> (&.with-type (type (All [a] (-> a outputT))) + (@.analyse-function analyse func-name arg-name outputC)) + (macro.run (init-compiler [])) succeeds?)) (test "Generic functions can always be specialized." - (and (|> (&;with-type (-> inputT outputT) - (@;analyse-function analyse func-name arg-name outputC)) - (macro;run (init-compiler [])) + (and (|> (&.with-type (-> inputT outputT) + (@.analyse-function analyse func-name arg-name outputC)) + (macro.run (init-compiler [])) succeeds?) - (|> (&;with-type (-> inputT inputT) - (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (macro;run (init-compiler [])) + (|> (&.with-type (-> inputT inputT) + (@.analyse-function analyse func-name arg-name (code.symbol ["" arg-name]))) + (macro.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)) - (macro;run (init-compiler [])) + (|> (@common.with-unknown-type + (@.analyse-function analyse func-name arg-name outputC)) + (macro.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]))) - (macro;run (init-compiler [])) + (|> (@common.with-unknown-type + (@.analyse-function analyse func-name arg-name (code.symbol ["" arg-name]))) + (macro.run (init-compiler [])) (check-type (type (All [a] (-> a a)))))) (test "The function's name is bound to the function's type." - (|> (&;with-type (type (Rec self (-> inputT self))) - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (macro;run (init-compiler [])) + (|> (&.with-type (type (Rec self (-> inputT self))) + (@.analyse-function analyse func-name arg-name (code.symbol ["" func-name]))) + (macro.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)] + [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) + #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)))) + (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 (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)) + 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)) + (|> (@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))) + (|> (@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)) + (|> (@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)))) + (|> (@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))) + (|> (@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 index cf60d64fe..d8ba4561f 100644 --- a/new-luxc/test/test/luxc/lang/analysis/primitive.lux +++ b/new-luxc/test/test/luxc/lang/analysis/primitive.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -11,29 +11,29 @@ (lang [type "type/" Eq<Type>]) test) (luxc ["&" lang] - (lang ["&;" module] + (lang ["&." module] ["~" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" primitive] - ["@;" common]))) - (.. common) + ["@." 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)] + [%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) - (macro;run (init-compiler [])) - (case> (^ (#e;Success [_type (^code [])])) + (|> (@common.with-unknown-type + @.analyse-unit) + (macro.run (init-compiler [])) + (case> (^ (#e.Success [_type (^code [])])) (type/= Unit _type) _ @@ -41,10 +41,10 @@ ) (~~ (do-template [<desc> <type> <tag> <value> <analyser>] [(test (format "Can analyse " <desc> ".") - (|> (@common;with-unknown-type + (|> (@common.with-unknown-type (<analyser> <value>)) - (macro;run (init-compiler [])) - (case> (#e;Success [_type [_ (<tag> value)]]) + (macro.run (init-compiler [])) + (case> (#e.Success [_type [_ (<tag> value)]]) (and (type/= <type> _type) (is <value> value)) @@ -52,10 +52,10 @@ 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] + ["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 index 91e5267f8..8d2494db7 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -14,27 +14,27 @@ (lang [type "type/" Eq<Type>]) test) (luxc ["&" lang] - (lang ["&;" scope] - ["&;" module] + (lang ["&." scope] + ["&." module] ["~" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" procedure] - ["@;" common]) - [";L" eval])) - (../.. common) + ["@." common]) + [".L" eval])) + (/// common) (test/luxc common)) (do-template [<name> <success> <failure>] [(def: (<name> procedure params output-type) (-> Text (List Code) Type Bool) - (|> (&;with-scope - (&;with-type output-type - (@;analyse-procedure analyse evalL;eval procedure params))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&.with-scope + (&.with-type output-type + (@.analyse-procedure analyse evalL.eval procedure params))) + (macro.run (init-compiler [])) + (case> (#e.Success _) <success> - (#e;Error error) + (#e.Error error) <failure>)))] [check-success+ true false] @@ -46,7 +46,7 @@ (do @ [[primT primC] gen-primitive [antiT antiC] (|> gen-primitive - (r;filter (|>. product;left (type/= primT) not)))] + (r.filter (|>> product.left (type/= primT) not)))] ($_ seq (test "Can test for reference equality." (check-success+ "lux is" (list primC primC) Bool)) @@ -61,9 +61,9 @@ (context: "Bit procedures" (<| (times +100) (do @ - [subjectC (|> r;nat (:: @ map code;nat)) - signedC (|> r;int (:: @ map code;int)) - paramC (|> r;nat (:: @ map code;nat))] + [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)) @@ -84,8 +84,8 @@ (context: "Nat procedures" (<| (times +100) (do @ - [subjectC (|> r;nat (:: @ map code;nat)) - paramC (|> r;nat (:: @ map code;nat))] + [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)) @@ -114,8 +114,8 @@ (context: "Int procedures" (<| (times +100) (do @ - [subjectC (|> r;int (:: @ map code;int)) - paramC (|> r;int (:: @ map code;int))] + [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)) @@ -144,9 +144,9 @@ (context: "Deg procedures" (<| (times +100) (do @ - [subjectC (|> r;deg (:: @ map code;deg)) - paramC (|> r;deg (:: @ map code;deg)) - natC (|> r;nat (:: @ map code;nat))] + [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)) @@ -177,9 +177,9 @@ (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))] + [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)) @@ -220,11 +220,11 @@ (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))] + [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)) @@ -252,72 +252,72 @@ (<| (times +100) (do @ [[elemT elemC] gen-primitive - sizeC (|> r;nat (:: @ map code;nat)) - idxC (|> r;nat (:: @ map code;nat)) - var-name (r;text +5) + 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-type elemT - (@;analyse-procedure analyse evalL;eval "lux array get" + (|> (&scope.with-scope "" + (&scope.with-local [var-name arrayT] + (&.with-type elemT + (@.analyse-procedure analyse evalL.eval "lux array get" (list idxC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (code.symbol ["" var-name])))))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error _) + (#e.Error _) false))) (test "Can put a value inside an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-type arrayT - (@;analyse-procedure analyse evalL;eval "lux array put" + (|> (&scope.with-scope "" + (&scope.with-local [var-name arrayT] + (&.with-type arrayT + (@.analyse-procedure analyse evalL.eval "lux array put" (list idxC elemC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (code.symbol ["" var-name])))))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error _) + (#e.Error _) false))) (test "Can remove a value from an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-type arrayT - (@;analyse-procedure analyse evalL;eval "lux array remove" + (|> (&scope.with-scope "" + (&scope.with-local [var-name arrayT] + (&.with-type arrayT + (@.analyse-procedure analyse evalL.eval "lux array remove" (list idxC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (code.symbol ["" var-name])))))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error _) + (#e.Error _) false))) (test "Can query the size of an array." - (|> (&scope;with-scope "" - (&scope;with-local [var-name arrayT] - (&;with-type Nat - (@;analyse-procedure analyse evalL;eval "lux array size" - (list (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&scope.with-scope "" + (&scope.with-local [var-name arrayT] + (&.with-type Nat + (@.analyse-procedure analyse evalL.eval "lux array size" + (list (code.symbol ["" var-name])))))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error _) + (#e.Error _) false))) )))) (context: "Math procedures" (<| (times +100) (do @ - [subjectC (|> r;frac (:: @ map code;frac)) - paramC (|> r;frac (:: @ map code;frac))] + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac))] (with-expansions [<unary> (do-template [<proc> <desc>] [(test (format "Can calculate " <desc> ".") (check-success+ <proc> (list subjectC) Frac))] @@ -352,38 +352,38 @@ (<| (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))]] + 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-type elemT - (@;analyse-procedure analyse evalL;eval "lux atom read" - (list (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&scope.with-scope "" + (&scope.with-local [var-name atomT] + (&.with-type elemT + (@.analyse-procedure analyse evalL.eval "lux atom read" + (list (code.symbol ["" var-name])))))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error _) + (#e.Error _) false))) (test "Can swap the value of an atomic reference." - (|> (&scope;with-scope "" - (&scope;with-local [var-name atomT] - (&;with-type Bool - (@;analyse-procedure analyse evalL;eval "lux atom compare-and-swap" + (|> (&scope.with-scope "" + (&scope.with-local [var-name atomT] + (&.with-type Bool + (@.analyse-procedure analyse evalL.eval "lux atom compare-and-swap" (list elemC elemC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (code.symbol ["" var-name])))))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error _) + (#e.Error _) false))) )))) @@ -391,7 +391,7 @@ (<| (times +100) (do @ [[primT primC] gen-primitive - timeC (|> r;nat (:: @ map code;nat))] + timeC (|> r.nat (:: @ map code.nat))] ($_ seq (test "Can query the level of concurrency." (check-success+ "lux process concurrency-level" (list) Nat)) @@ -409,8 +409,8 @@ (context: "IO procedures" (<| (times +100) (do @ - [logC (|> (r;text +5) (:: @ map code;text)) - exitC (|> r;nat (:: @ map code;nat))] + [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)) 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 index 13645840e..72d1e8bc9 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -18,31 +18,31 @@ (lang [type]) test) (luxc ["&" lang] - (lang ["&;" scope] - ["&;" module] + (lang ["&." scope] + ["&." module] ["~" analysis] - (analysis [";A" expression] - ["@;" common] + (analysis [".A" expression] + ["@." common] ["@" procedure] - (procedure ["@;" host])) - (translation ["@;" runtime]) - [";L" eval])) - (../.. common) + (procedure ["@." host])) + (translation ["@." runtime]) + [".L" eval])) + (/// common) (test/luxc common)) (do-template [<name> <success> <failure>] [(def: (<name> procedure params output-type) (-> Text (List Code) Type Bool) (|> (do Monad<Meta> - [runtime-bytecode @runtime;translate] - (&;with-scope - (&;with-type output-type - (@;analyse-procedure analyse evalL;eval procedure params)))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + [runtime-bytecode @runtime.translate] + (&.with-scope + (&.with-type output-type + (@.analyse-procedure analyse evalL.eval procedure params)))) + (macro.run (init-compiler [])) + (case> (#e.Success _) <success> - (#e;Error error) + (#e.Error error) <failure>)))] [success true false] @@ -56,12 +56,12 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["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] + ["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 <conversions> @@ -74,12 +74,12 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["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] + ["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 <conversions> @@ -92,11 +92,11 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["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] + ["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 <conversions> @@ -109,12 +109,12 @@ (test (format <procedure> " FAILURE") (failure <procedure> (list (' [])) <to>))] - ["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] + ["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 <conversions> @@ -147,8 +147,8 @@ (' ("lux coerce" (+0 <param> (+0)) []))) <output>))] - [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] )] ($_ seq <instructions> @@ -174,8 +174,8 @@ )))] - ["int" "java.lang.Integer" @host;Integer] - ["long" "java.lang.Long" @host;Long] + ["int" "java.lang.Integer" @host.Integer] + ["long" "java.lang.Long" @host.Long] ) (do-template [<domain> <boxed> <type>] @@ -205,16 +205,16 @@ (' ("lux coerce" (+0 <param> (+0)) []))) <output>))] - [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] )] ($_ seq <instructions> )))] - ["float" "java.lang.Float" @host;Float] - ["double" "java.lang.Double" @host;Double] + ["float" "java.lang.Float" @host.Float] + ["double" "java.lang.Double" @host.Double] ) (do-template [<domain> <boxed> <type>] @@ -226,59 +226,59 @@ (' ("lux coerce" (+0 <param> (+0)) []))) <output>))] - [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean] - [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean] + [(format "jvm " <domain> " =") <boxed> <boxed> @host.Boolean] + [(format "jvm " <domain> " <") <boxed> <boxed> @host.Boolean] )] ($_ seq <instructions> )))] - ["char" "java.lang.Character" @host;Character] + ["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<Random> - [choice (|> r;nat (:: @ map (n.% (n.inc num-entries)))) + (r.Random [Text Text]) + (let [entries (dict.entries @host.boxes) + num-entries (list.size entries)] + (do r.Monad<Random> + [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"])))]] + (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))] + [#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))) + 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"))) + (|> innerT (list) (#.Primitive "#Array"))) boxedT - (list;n.range +1 level))]] + (list.n/range +1 level))]] ($_ seq (test "jvm array new" (success "jvm array new" - (list (code;nat size)) + (list (code.nat size)) arrayT)) (test "jvm array new (no nesting)" (failure "jvm array new" - (list (code;nat size)) + (list (code.nat size)) unboxedT)) (test "jvm array new (nested/multi-level)" (success "jvm array new" - (list (code;nat size)) + (list (code.nat size)) multi-arrayT)) (test "jvm array length" (success "jvm array length" @@ -286,11 +286,11 @@ Nat)) (test "jvm array read" (success "jvm array read" - (list arrayC (code;nat idx)) + (list arrayC (code.nat idx)) boxedT)) (test "jvm array write" (success "jvm array write" - (list arrayC (code;nat idx) (`' ("lux coerce" (~ boxedTC) []))) + (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) arrayT)) )))) @@ -309,33 +309,33 @@ (do @ [[unboxed boxed] array-type [!unboxed !boxed] (|> array-type - (r;filter (function [[!unboxed !boxed]] + (r.filter (function [[!unboxed !boxed]] (not (text/= boxed !boxed))))) - #let [boxedT (#;Primitive boxed (list)) - boxedC (`' ("lux check" (+0 (~ (code;text boxed)) (+0)) + #let [boxedT (#.Primitive boxed (list)) + boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) ("jvm object null"))) - !boxedC (`' ("lux check" (+0 (~ (code;text !boxed)) (+0)) + !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) ("jvm object null"))) - unboxedC (`' ("lux check" (+0 (~ (code;text unboxed)) (+0)) + unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) ("jvm object null")))] - throwable (|> r;nat - (:: @ map (n.% (n.inc (list;size throwables)))) + 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)) + (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)))) + (#.Primitive boxed (list)))) (test "jvm object null (no primitives)" (or (text/= "java.lang.Object" boxed) (failure "jvm object null" (list) - (#;Primitive unboxed (list))))) + (#.Primitive unboxed (list))))) (test "jvm object null?" (success "jvm object null?" (list boxedC) @@ -356,11 +356,11 @@ Bottom))) (test "jvm object class" (success "jvm object class" - (list (code;text boxed)) - (#;Primitive "java.lang.Class" (list boxedT)))) + (list (code.text boxed)) + (#.Primitive "java.lang.Class" (list boxedT)))) (test "jvm object instance?" (success "jvm object instance?" - (list (code;text boxed) + (list (code.text boxed) boxedC) Bool)) (test "jvm object instance? (lineage)" @@ -371,7 +371,7 @@ (test "jvm object instance? (no lineage)" (or (text/= "java.lang.Object" boxed) (failure "jvm object instance?" - (list (code;text boxed) + (list (code.text boxed) !boxedC) Bool))) )))) @@ -380,32 +380,32 @@ ($_ 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)))) + (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)))) + (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") + (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") + (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") + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) ("jvm object null")))) Unit)) @@ -415,70 +415,70 @@ ($_ seq (test "jvm member virtual get" (success "jvm member virtual get" - (list (code;text "org.omg.CORBA.ValueMember") - (code;text "id") + (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)))) + (#.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") + (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)))) + (#.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") + (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))) + (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") + (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))) + (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") + (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))) + (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)))) + (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") + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) ("jvm object null")))) - (#;Primitive "java.lang.Integer" (list)))) + (#.Primitive "java.lang.Integer" (list)))) (test "jvm member virtual put" (success "jvm member virtual put" - (list (code;text "javax.accessibility.AccessibleAttributeSequence") - (code;text "startIndex") + (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))) + (primitive "javax.accessibility.AccessibleAttributeSequence"))) )) (context: "Member [Method]." @@ -491,39 +491,39 @@ ($_ 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") + (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)))) + (#.Primitive "java.lang.Long" (list)))) (test "jvm member invoke virtual" (success "jvm member invoke virtual" - (list (code;text "java.lang.Object") - (code;text "equals") + (list (code.text "java.lang.Object") + (code.text "equals") longC - (code;tuple (list (' "java.lang.Object") + (code.tuple (list (' "java.lang.Object") longC))) - (#;Primitive "java.lang.Boolean" (list)))) + (#.Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke special" (success "jvm member invoke special" - (list (code;text "java.lang.Long") - (code;text "equals") + (list (code.text "java.lang.Long") + (code.text "equals") longC - (code;tuple (list (' "java.lang.Object") + (code.tuple (list (' "java.lang.Object") longC))) - (#;Primitive "java.lang.Boolean" (list)))) + (#.Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke interface" (success "jvm member invoke interface" - (list (code;text "java.util.Collection") - (code;text "add") + (list (code.text "java.util.Collection") + (code.text "add") objectC - (code;tuple (list (' "java.lang.Object") + (code.tuple (list (' "java.lang.Object") longC))) - (#;Primitive "java.lang.Boolean" (list)))) + (#.Primitive "java.lang.Boolean" (list)))) (test "jvm member invoke constructor" (success "jvm member invoke constructor" - (list (code;text "java.util.ArrayList") - (code;tuple (list (' "int") intC))) - (All [a] (#;Primitive "java.util.ArrayList" (list a))))) + (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 index 14079c6b8..45e1eb0e8 100644 --- a/new-luxc/test/test/luxc/lang/analysis/reference.lux +++ b/new-luxc/test/test/luxc/lang/analysis/reference.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -8,43 +8,43 @@ [macro #+ Monad<Meta>] (lang [type "type/" Eq<Type>]) test) - (luxc (lang ["&;" scope] - ["&;" module] + (luxc (lang ["&." scope] + ["&." module] ["~" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" reference] - ["@;" common]))) - (.. common) + ["@." 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)] + 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])))) - (macro;run (init-compiler [])) - (case> (^ (#e;Success [_type (^code ((~ [_ (#;Int var)])))])) + (|> (&scope.with-scope scope-name + (&scope.with-local [var-name ref-type] + (@common.with-unknown-type + (@.analyse-reference ["" var-name])))) + (macro.run (init-compiler [])) + (case> (^ (#e.Success [_type (^code ((~ [_ (#.Int var)])))])) (type/= ref-type _type) _ false))) (test "Can analyse definition." (|> (do Monad<Meta> - [_ (&module;create +0 module-name) - _ (&module;define [module-name var-name] + [_ (&module.create +0 module-name) + _ (&module.define [module-name var-name] [ref-type (' {}) (:! Void [])])] - (@common;with-unknown-type - (@;analyse-reference [module-name var-name]))) - (macro;run (init-compiler [])) - (case> (#e;Success [_type [_ (#;Symbol def-name)]]) + (@common.with-unknown-type + (@.analyse-reference [module-name var-name]))) + (macro.run (init-compiler [])) + (case> (#e.Success [_type [_ (#.Symbol def-name)]]) (type/= ref-type _type) _ diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux index 58212359e..5694c0927 100644 --- a/new-luxc/test/test/luxc/lang/analysis/structure.lux +++ b/new-luxc/test/test/luxc/lang/analysis/structure.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -18,196 +18,196 @@ (type ["tc" check])) test) (luxc ["&" lang] - (lang ["@;" module] + (lang ["@." module] ["la" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" structure] - ["@;" common]))) - (.. common) + ["@." common]))) + (// 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)))) + [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))]] + #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-type variantT - (@;analyse-sum analyse choice valueC))) - (macro;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))) + (|> (&.with-scope + (&.with-type variantT + (@.analyse-sum analyse choice valueC))) + (macro.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 - (do macro;Monad<Meta> - [[_ varT] (&;with-type-env tc;var) - _ (&;with-type-env - (tc;check varT variantT))] - (&;with-type varT - (@;analyse-sum analyse choice valueC)))) - (macro;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))) + (|> (&.with-scope + (do macro.Monad<Meta> + [[_ varT] (&.with-type-env tc.var) + _ (&.with-type-env + (tc.check varT variantT))] + (&.with-type varT + (@.analyse-sum analyse choice valueC)))) + (macro.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 - (do macro;Monad<Meta> - [[_ varT] (&;with-type-env tc;var)] - (&;with-type varT - (@;analyse-sum analyse choice valueC)))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&.with-scope + (do macro.Monad<Meta> + [[_ varT] (&.with-type-env tc.var)] + (&.with-type varT + (@.analyse-sum analyse choice valueC)))) + (macro.run (init-compiler [])) + (case> (#e.Success _) false _ true))) (test "Can analyse sum through existential quantification." - (|> (&;with-scope - (&;with-type (type;ex-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&.with-scope + (&.with-type (type.ex-q +1 +variantT) + (@.analyse-sum analyse +choice +valueC))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error error) + (#e.Error error) false))) (test "Can analyse sum through universal quantification." - (|> (&;with-scope - (&;with-type (type;univ-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (macro;run (init-compiler [])) - (case> (#e;Success _) - (not (n.= choice +choice)) + (|> (&.with-scope + (&.with-type (type.univ-q +1 +variantT) + (@.analyse-sum analyse +choice +valueC))) + (macro.run (init-compiler [])) + (case> (#e.Success _) + (not (n/= choice +choice)) - (#e;Error error) - (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))) + [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))]] + #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-type (type;tuple (list/map product;left primitives)) - (@;analyse-product analyse (list/map product;right primitives))) - (macro;run (init-compiler [])) - (case> (#e;Success tupleA) - (n.= size (list;size (la;unfold-tuple tupleA))) + (|> (&.with-type (type.tuple (list/map product.left primitives)) + (@.analyse-product analyse (list/map product.right primitives))) + (macro.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))) - (macro;run (init-compiler [])) - (case> (#e;Success [_type tupleA]) - (and (type/= (type;tuple (list/map product;left primitives)) + (|> (@common.with-unknown-type + (@.analyse-product analyse (list/map product.right primitives))) + (macro.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)))) + (n/= size (list.size (la.unfold-tuple tupleA)))) _ false))) (test "Can analyse pseudo-product (singleton tuple)" - (|> (&;with-type singletonT + (|> (&.with-type singletonT (analyse (` [(~ singletonC)]))) - (macro;run (init-compiler [])) - (case> (#e;Success singletonA) + (macro.run (init-compiler [])) + (case> (#e.Success singletonA) true - (#e;Error error) + (#e.Error error) false))) (test "Can analyse product through bound type-vars." - (|> (&;with-scope - (do macro;Monad<Meta> - [[_ varT] (&;with-type-env tc;var) - _ (&;with-type-env - (tc;check varT (type;tuple (list/map product;left primitives))))] - (&;with-type varT - (@;analyse-product analyse (list/map product;right primitives))))) - (macro;run (init-compiler [])) - (case> (#e;Success [_ tupleA]) - (n.= size (list;size (la;unfold-tuple tupleA))) + (|> (&.with-scope + (do macro.Monad<Meta> + [[_ varT] (&.with-type-env tc.var) + _ (&.with-type-env + (tc.check varT (type.tuple (list/map product.left primitives))))] + (&.with-type varT + (@.analyse-product analyse (list/map product.right primitives))))) + (macro.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-type (type;ex-q +1 +tupleT) - (@;analyse-product analyse (list/map product;right +primitives)))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&.with-scope + (&.with-type (type.ex-q +1 +tupleT) + (@.analyse-product analyse (list/map product.right +primitives)))) + (macro.run (init-compiler [])) + (case> (#e.Success _) true - (#e;Error error) + (#e.Error error) false))) (test "Cannot analyse product through universal quantification." - (|> (&;with-scope - (&;with-type (type;univ-q +1 +tupleT) - (@;analyse-product analyse (list/map product;right +primitives)))) - (macro;run (init-compiler [])) - (case> (#e;Success _) + (|> (&.with-scope + (&.with-type (type.univ-q +1 +tupleT) + (@.analyse-product analyse (list/map product.right +primitives)))) + (macro.run (init-compiler [])) + (case> (#e.Success _) false - (#e;Error error) + (#e.Error error) true))) )))) (def: (check-variant-inference variantT choice size analysis) - (-> Type Nat Nat (Meta [Module Scope Type la;Analysis]) Bool) + (-> Type Nat Nat (Meta [Module Scope Type la.Analysis]) Bool) (|> analysis - (macro;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ sumT sumA]) - [(la;unfold-variant sumA) - (#;Some [tag last? valueA])]) + (macro.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))) + (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) + (-> Type Nat (Meta [Module Scope Type la.Analysis]) Bool) (|> analysis - (macro;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productT productA]) - [(la;unfold-tuple productA) + (macro.run (init-compiler [])) + (case> (^multi (#e.Success [_ _ productT productA]) + [(la.unfold-tuple productA) membersA]) (and (type/= tupleT productT) - (n.= size (list;size membersA))) + (n/= size (list.size membersA))) _ false))) @@ -215,64 +215,64 @@ (context: "Tagged Sums" (<| (times +100) (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) - choice (|> r;nat (:: @ map (n.% size))) - other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - #let [varT (#;Bound +1) - primitivesT (list/map product;left primitives) - [choiceT choiceC] (maybe;assume (list;nth choice primitives)) - [other-choiceT other-choiceC] (maybe;assume (list;nth other-choice primitives)) - variantT (type;variant primitivesT) - namedT (#;Named [module-name type-name] variantT) - polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map S.to-list)) + choice (|> r.nat (:: @ map (n/% size))) + other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) + primitives (r.list size gen-primitive) + module-name (r.text +5) + type-name (r.text +5) + #let [varT (#.Bound +1) + primitivesT (list/map product.left primitives) + [choiceT choiceC] (maybe.assume (list.nth choice primitives)) + [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) + variantT (type.variant primitivesT) + namedT (#.Named [module-name type-name] variantT) + polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT) - choice-tag (maybe;assume (list;nth choice tags)) - other-choice-tag (maybe;assume (list;nth other-choice tags))]] + (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 macro;Monad<Meta> - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false namedT)] + (&.with-scope + (@common.with-unknown-type + (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) (check-variant-inference variantT choice size))) (test "Tagged sums specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do macro;Monad<Meta> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false named-polyT)] + (&.with-scope + (@common.with-unknown-type + (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) (check-variant-inference variantT choice size))) (test "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (@module;with-module +0 module-name - (do macro;Monad<Meta> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false named-polyT)] + (&.with-scope + (@common.with-unknown-type + (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) (check-variant-inference polyT other-choice size))) (test "Can specialize generic tagged sums." - (|> (@module;with-module +0 module-name - (do macro;Monad<Meta> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-type variantT - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (macro;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))) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false named-polyT)] + (&.with-scope + (&.with-type variantT + (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (macro.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))) @@ -281,53 +281,53 @@ (context: "Records" (<| (times +100) (do @ - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) - primitives (r;list size gen-primitive) - module-name (r;text +5) - type-name (r;text +5) - choice (|> r;nat (:: @ map (n.% size))) - #let [varT (#;Bound +1) - tagsC (list/map (|>. [module-name] code;tag) tags) - primitivesT (list/map product;left primitives) - primitivesC (list/map product;right primitives) - tupleT (type;tuple primitivesT) - namedT (#;Named [module-name type-name] tupleT) - recordC (list;zip2 tagsC primitivesC) - polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map S.to-list)) + primitives (r.list size gen-primitive) + module-name (r.text +5) + type-name (r.text +5) + choice (|> r.nat (:: @ map (n/% size))) + #let [varT (#.Bound +1) + tagsC (list/map (|>> [module-name] code.tag) tags) + primitivesT (list/map product.left primitives) + primitivesC (list/map product.right primitives) + tupleT (type.tuple primitivesT) + namedT (#.Named [module-name type-name] tupleT) + recordC (list.zip2 tagsC primitivesC) + polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) (list varT) - (list;drop (n.inc choice) primitivesT)))) - (type;univ-q +1)) - named-polyT (#;Named [module-name type-name] polyT)]] + (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 macro;Monad<Meta> - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false namedT)] + (&.with-scope + (@common.with-unknown-type + (@.analyse-record analyse recordC))))) (check-record-inference tupleT size))) (test "Records specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do macro;Monad<Meta> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false named-polyT)] + (&.with-scope + (@common.with-unknown-type + (@.analyse-record analyse recordC))))) (check-record-inference tupleT size))) (test "Can specialize generic records." - (|> (@module;with-module +0 module-name - (do macro;Monad<Meta> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-type tupleT - (@;analyse-record analyse recordC))))) - (macro;run (init-compiler [])) - (case> (^multi (#e;Success [_ _ productA]) - [(la;unfold-tuple productA) + (|> (@module.with-module +0 module-name + (do macro.Monad<Meta> + [_ (@module.declare-tags tags false named-polyT)] + (&.with-scope + (&.with-type tupleT + (@.analyse-record analyse recordC))))) + (macro.run (init-compiler [])) + (case> (^multi (#e.Success [_ _ productA]) + [(la.unfold-tuple productA) membersA]) - (n.= size (list;size 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 index b159870c8..6f8a1343a 100644 --- a/new-luxc/test/test/luxc/lang/analysis/type.lux +++ b/new-luxc/test/test/luxc/lang/analysis/type.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux [io] (control [monad #+ do] @@ -17,33 +17,33 @@ (lang [type "type/" Eq<Type>]) test) (luxc ["&" lang] - (lang ["&;" module] + (lang ["&." module] ["~" analysis] - (analysis [";A" expression] + (analysis [".A" expression] ["@" type] - ["@;" common]) - (translation ["@;" runtime]) + ["@." common]) + (translation ["@." runtime]) [eval])) - (.. common) + (// common) (test/luxc common)) (def: check - (r;Random [Code Type Code]) + (r.Random [Code Type Code]) (with-expansions [<triples> (do-template [<random> <type> <code>] - [(do r;Monad<Random> + [(do r.Monad<Random> [value <random>] (wrap [(` <type>) <type> (<code> 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.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 + ($_ r.either <triples>))) (context: "Type checking/coercion." @@ -53,39 +53,39 @@ ($_ seq (test (format "Can analyse type-checking.") (|> (do Monad<Meta> - [runtime-bytecode @runtime;translate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-check analyse eval;eval typeC exprC)))) - (macro;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) + [runtime-bytecode @runtime.translate] + (&.with-scope + (@common.with-unknown-type + (@.analyse-check analyse eval.eval typeC exprC)))) + (macro.run (init-compiler [])) + (case> (#e.Success [_ [analysisT analysisA]]) (and (type/= codeT analysisT) (case [exprC analysisA] (^template [<tag> <test>] [[_ (<tag> expected)] [_ (<tag> actual)]] (<test> expected actual)) - ([#;Bool bool/=] - [#;Nat n.=] - [#;Int i.=] - [#;Deg d.=] - [#;Frac f.=] - [#;Text text/=]) + ([#.Bool bool/=] + [#.Nat n/=] + [#.Int i/=] + [#.Deg d/=] + [#.Frac f/=] + [#.Text text/=]) _ false)) - (#e;Error error) + (#e.Error error) false))) (test (format "Can analyse type-coercion.") (|> (do Monad<Meta> - [runtime-bytecode @runtime;translate] - (&;with-scope - (@common;with-unknown-type - (@;analyse-coerce analyse eval;eval typeC exprC)))) - (macro;run (init-compiler [])) - (case> (#e;Success [_ [analysisT analysisA]]) + [runtime-bytecode @runtime.translate] + (&.with-scope + (@common.with-unknown-type + (@.analyse-coerce analyse eval.eval typeC exprC)))) + (macro.run (init-compiler [])) + (case> (#e.Success [_ [analysisT analysisA]]) (type/= codeT analysisT) - (#e;Error error) + (#e.Error error) false))) )))) |