From 54815ade282ff4feb81d7d557188bde8111db376 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 5 Oct 2017 00:17:51 -0400 Subject: - Added tests for type-checking and type-coercion. - Implemented "eval". - Fixed bugs when analysing variants and tuples. --- new-luxc/source/luxc/analyser.lux | 32 ++++----- new-luxc/source/luxc/analyser/structure.lux | 33 ++++++++- new-luxc/source/luxc/eval.lux | 17 +++++ new-luxc/test/test/luxc/analyser/common.lux | 5 +- new-luxc/test/test/luxc/analyser/type.lux | 89 +++++++++++++++++++++++++ new-luxc/test/test/luxc/generator/structure.lux | 10 +-- new-luxc/test/tests.lux | 1 + 7 files changed, 162 insertions(+), 25 deletions(-) create mode 100644 new-luxc/source/luxc/eval.lux create mode 100644 new-luxc/test/test/luxc/analyser/type.lux (limited to 'new-luxc') diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 3272057f2..f17ec8496 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -76,16 +76,12 @@ body))) (&&function;analyse-function analyse func-name arg-name body) - (^ (#;Form (list [_ (#;Symbol ["" "_lux_check"])] - type - value))) - (&&type;analyse-check analyse eval type value) - - (^ (#;Form (list [_ (#;Symbol ["" "_lux_coerce"])] - type - value))) - (&&type;analyse-coerce analyse eval type value) - + (^template [ ] + (^ (#;Form (list [_ (#;Symbol ["" ])] type value))) + ( analyse eval type value)) + (["_lux_check" &&type;analyse-check] + ["_lux_coerce" &&type;analyse-coerce]) + (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) (&&procedure;analyse-procedure analyse proc-name proc-args) @@ -96,13 +92,17 @@ [paired (to-branches branches)] (&&case;analyse-case analyse input paired)) - (^ (#;Form (list [_ (#;Nat tag)] - value))) - (&&structure;analyse-sum analyse tag value) + (^template [ ] + (^ (#;Form (list& [_ ( tag)] + values))) + (case values + (#;Cons value #;Nil) + ( analyse tag value) - (^ (#;Form (list [_ (#;Tag tag)] - value))) - (&&structure;analyse-tagged-sum analyse tag value) + _ + ( analyse tag (` [(~@ values)])))) + ([#;Nat &&structure;analyse-sum] + [#;Tag &&structure;analyse-tagged-sum]) (^ (#;Form (list& func args))) (do Monad diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index e13d1d88a..9a42db0fa 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -24,12 +24,23 @@ (analyser ["&;" common] ["&;" inference]))) +(type: Type-Error + (-> Type Text)) + +(def: (not-variant type) + Type-Error + (format "Invalid type for variant: " (%type type))) + +(def: (not-quantified type) + Type-Error + (format "Not a quantified type: " (%type type))) + (def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Lux la;Analysis)) (do Monad [expected macro;expected-type] (&;with-stacked-errors - (function [_] (format "Invalid type for variant: " (%type expected))) + (function [_] (not-variant expected)) (case expected (#;Sum _) (let [flat (type;flatten-variant expected) @@ -62,7 +73,7 @@ ## Cannot do inference when the tag is numeric. ## This is because there is no way of knowing how many ## cases the inferred sum type would have. - (&;fail (format "Invalid type for variant: " (%type expected))))) + (&;fail (not-variant expected)))) (#;UnivQ _) (do @ @@ -76,6 +87,15 @@ (function [[var-id var]] (&;with-expected-type (assume (type;apply (list var) expected)) (analyse-sum analyse tag valueC)))) + + (#;Apply inputT funT) + (case (type;apply (list inputT) funT) + #;None + (&;fail (not-quantified funT)) + + (#;Some outputT) + (&;with-expected-type outputT + (analyse-sum analyse tag valueC))) _ (&;fail ""))))) @@ -173,6 +193,15 @@ (function [[var-id var]] (&;with-expected-type (assume (type;apply (list var) expected)) (analyse-product analyse membersC)))) + + (#;Apply inputT funT) + (case (type;apply (list inputT) funT) + #;None + (&;fail (not-quantified funT)) + + (#;Some outputT) + (&;with-expected-type outputT + (analyse-product analyse membersC))) _ (&;fail "") diff --git a/new-luxc/source/luxc/eval.lux b/new-luxc/source/luxc/eval.lux new file mode 100644 index 000000000..266becee6 --- /dev/null +++ b/new-luxc/source/luxc/eval.lux @@ -0,0 +1,17 @@ +(;module: + lux + (lux (control [monad #+ do]) + [macro]) + [../base] + (.. [analyser] + [synthesizer] + (generator [expr] + [eval]))) + +(def: #export (eval type exprC) + ../base;Eval + (do macro;Monad + [exprA (../base;with-expected-type type + (analyser;analyser eval exprC)) + #let [exprS (synthesizer;synthesize exprA)]] + (eval;eval (expr;generate exprS)))) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux index 6d701e823..60f3eef50 100644 --- a/new-luxc/test/test/luxc/analyser/common.lux +++ b/new-luxc/test/test/luxc/analyser/common.lux @@ -6,7 +6,8 @@ [macro] (macro [code])) (luxc ["&" base] - [analyser]) + [analyser] + [eval]) (test/luxc common)) (def: gen-unit @@ -33,7 +34,7 @@ (def: #export analyse &;Analyser - (analyser;analyser (:!! []))) + (analyser;analyser eval;eval)) (do-template [ ] [(def: #export ( analysis) diff --git a/new-luxc/test/test/luxc/analyser/type.lux b/new-luxc/test/test/luxc/analyser/type.lux new file mode 100644 index 000000000..b23b16d6a --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/type.lux @@ -0,0 +1,89 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + [text "text/" Eq] + (text format + ["l" lexer]) + [number] + ["R" result] + [product] + (coll [list "list/" Functor Fold])) + ["r" math/random "r/" Monad] + [type "type/" Eq] + [macro #+ Monad] + (macro [code]) + 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." + [[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)))) + (macro;run (init-compiler [])) + (case> (#R;Success [_ [analysisT analysisA]]) + (and (type/= codeT analysisT) + (case [exprC analysisA] + (^template [ ] + [[_ ( expected)] ( actual)] + ( expected actual)) + ([#;Bool #~;Bool bool/=] + [#;Nat #~;Nat n.=] + [#;Int #~;Int i.=] + [#;Deg #~;Deg d.=] + [#;Frac #~;Frac f.=] + [#;Text #~;Text text/=]) + + _ + false)) + + (#R;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)))) + (macro;run (init-compiler [])) + (case> (#R;Success [_ [analysisT analysisA]]) + (type/= codeT analysisT) + + (#R;Error error) + false))) + )) diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 4652c4bd9..ab0c17ade 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -5,8 +5,8 @@ pipe) (data text/format ["R" result] - [bool "B/" Eq] - [text "T/" Eq] + [bool "bool/" Eq] + [text "text/" Eq] (coll ["a" array] [list])) ["r" math/random "r/" Monad] @@ -48,12 +48,12 @@ (#R;Error error) false)) - ([#ls;Bool Bool B/=] + ([#ls;Bool Bool bool/=] [#ls;Nat Nat n.=] [#ls;Int Int i.=] [#ls;Deg Deg d.=] [#ls;Frac Frac f.=] - [#ls;Text Text T/=]) + [#ls;Text Text text/=]) _ false @@ -92,7 +92,7 @@ (and (n.= tag (|> _tag host;i2l int-to-nat)) (case _last? (#;Some _last?') - (and last? (T/= "" (:! Text _last?'))) + (and last? (text/= "" (:! Text _last?'))) #;None (not last?)) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 30fab3878..28ccefc42 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -11,6 +11,7 @@ ["_;A" reference] ["_;A" case] ["_;A" function] + ["_;A" type] (procedure ["_;A" common])) (synthesizer ["_;S" primitive] ["_;S" structure] -- cgit v1.2.3