diff options
| -rw-r--r-- | new-luxc/source/luxc/analyser.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/primitive.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/struct.lux | 156 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis.lux | 5 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/primitive.lux | 10 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/struct.lux | 17 |
6 files changed, 110 insertions, 86 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 90140afb4..2be2b6da6 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -61,7 +61,7 @@ (analyse singleton) (^ (#;Tuple elems)) - (&&struct;analyse-tuple analyse elems) + (&&struct;analyse-product analyse elems) (^ (#;Record pairs)) (&&struct;analyse-record analyse pairs) @@ -93,11 +93,11 @@ (^ (#;Form (list [_ (#;Nat tag)] value))) - (&&struct;analyse-variant analyse tag value) + (&&struct;analyse-sum analyse tag value) (^ (#;Form (list [_ (#;Tag tag)] value))) - (&&struct;analyse-tagged-variant analyse tag value) + (&&struct;analyse-tagged-sum analyse tag value) (^ (#;Form (list& func args))) (do Monad<Lux> diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux index 48be75c3c..26580a503 100644 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ b/new-luxc/source/luxc/analyser/primitive.lux @@ -31,4 +31,4 @@ [expected macro;expected-type _ (&;within-type-env (TC;check expected Unit))] - (wrap (#la;Tuple (list))))) + (wrap #la;Unit))) diff --git a/new-luxc/source/luxc/analyser/struct.lux b/new-luxc/source/luxc/analyser/struct.lux index 185b8747f..562e30294 100644 --- a/new-luxc/source/luxc/analyser/struct.lux +++ b/new-luxc/source/luxc/analyser/struct.lux @@ -3,6 +3,7 @@ (lux (control monad pipe) [io #- run] + [function] (concurrency ["A" atom]) (data [text "T/" Eq<Text>] text/format @@ -17,58 +18,40 @@ [type] (type ["TC" check])) (luxc ["&" base] - (lang ["la" analysis #+ Analysis]) + (lang ["la" analysis #+ Analysis] + ["lp" pattern]) ["&;" module] ["&;" env] (analyser ["&;" common] ["&;" inference]))) ## [Analysers] -(def: (analyse-typed-tuple analyse members) +(def: (analyse-typed-product analyse members) (-> &;Analyser (List Code) (Lux Analysis)) (do Monad<Lux> [expected macro;expected-type] - (let [member-types (type;flatten-tuple expected) - num-types (list;size member-types) - num-members (list;size members)] - (cond (n.= num-types num-members) - (do @ - [=tuple (: (Lux (List Analysis)) - (mapM @ - (function [[expected member]] - (&;with-expected-type expected - (analyse member))) - (list;zip2 member-types members)))] - (wrap (#la;Tuple =tuple))) - - (n.< num-types num-members) - (do @ - [#let [[head-ts tail-ts] (list;split (n.- +2 num-members) - member-types)] - =prevs (mapM @ - (function [[expected member]] - (&;with-expected-type expected - (analyse member))) - (list;zip2 head-ts members)) - =last (&;with-expected-type (type;tuple tail-ts) - (analyse (default (undefined) - (list;last members))))] - (wrap (#la;Tuple (L/append =prevs (list =last))))) - - ## (n.> num-types num-members) - (do @ - [#let [[head-xs tail-xs] (list;split (n.- +2 num-types) - members)] - =prevs (mapM @ - (function [[expected member]] - (&;with-expected-type expected - (analyse member))) - (list;zip2 member-types head-xs)) - =last (&;with-expected-type (default (undefined) - (list;last member-types)) - (analyse-typed-tuple analyse tail-xs))] - (wrap (#la;Tuple (L/append =prevs (list =last))))) - )))) + (loop [expected expected + members members] + (case [expected members] + [(#;Product leftT rightT) (#;Cons leftC rightC)] + (do @ + [leftA (&;with-expected-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (#la;Product leftA rightA))) + + [tailT (#;Cons tailC #;Nil)] + (&;with-expected-type tailT + (analyse tailC)) + + [tailT tailC] + (do @ + [g!tail (macro;gensym "tail")] + (&;with-expected-type tailT + (analyse (` ((~' _lux_case) [(~@ tailC)] + (~ g!tail) + (~ g!tail)))))) + )))) (def: #export (normalize-record pairs) (-> (List [Code Code]) (Lux (List [Ident Code]))) @@ -125,7 +108,19 @@ _ (:: Monad<Lux> wrap [(list) Unit]))) -(def: #export (analyse-tuple analyse members) +(def: (tuple members) + (-> (List Analysis) Analysis) + (case members + #;Nil + #la;Unit + + (#;Cons singleton #;Nil) + singleton + + (#;Cons left right) + (#la;Product left (tuple right)))) + +(def: #export (analyse-product analyse membersC) (-> &;Analyser (List Code) (Lux Analysis)) (do Monad<Lux> [expected macro;expected-type] @@ -133,11 +128,11 @@ (function [_] (format "Invalid type for tuple: " (%type expected))) (case expected (#;Product _) - (analyse-typed-tuple analyse members) + (analyse-typed-product analyse membersC) (#;Named name unnamedT) (&;with-expected-type unnamedT - (analyse-tuple analyse members)) + (analyse-product analyse membersC)) (#;Var id) (do @ @@ -148,27 +143,27 @@ [expected' (&;within-type-env (TC;read-var id))] (&;with-expected-type expected' - (analyse-tuple analyse members))) + (analyse-product analyse membersC))) (do @ - [=members (mapM @ (|>. analyse &common;with-unknown-type) - members) - #let [tuple-type (type;tuple (L/map product;left =members))] + [membersTA (mapM @ (|>. analyse &common;with-unknown-type) + membersC) _ (&;within-type-env - (TC;check expected tuple-type))] - (wrap (#la;Tuple (L/map product;right =members)))))) + (TC;check expected + (type;tuple (L/map product;left membersTA))))] + (wrap (tuple (L/map product;right membersTA)))))) (#;UnivQ _) (do @ [[var-id var] (&;within-type-env TC;existential)] (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-tuple analyse members))) + (analyse-product analyse membersC))) (#;ExQ _) (&common;with-var (function [[var-id var]] (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-tuple analyse members)))) + (analyse-product analyse membersC)))) _ (&;fail "") @@ -258,9 +253,34 @@ [inferredT membersA] (&inference;apply-function analyse functionT members) _ (&;within-type-env (TC;check expectedT inferredT))] - (wrap (#la;Tuple membersA)))) - -(def: #export (analyse-tagged-variant analyse tag value) + (wrap (tuple membersA)))) + +(do-template [<name> <side>] + [(def: (<name> inner) + (-> Analysis Analysis) + (#la;Sum (<side> inner)))] + + [sum-left #;Left] + [sum-right #;Right]) + +(def: (variant tag size temp value) + (-> Nat Nat Nat Analysis Analysis) + (let [last-tag (n.dec size)] + (if (n.= last-tag tag) + (L/fold (function;const sum-left) + (sum-right value) + (list;n.range +0 last-tag)) + (L/fold (function;const sum-left) + (case value + (#la;Sum _) + (#la;Case value (list [(#lp;Bind temp) + (#la;Relative (#;Local temp))])) + + _ + value) + (list;n.range +0 tag))))) + +(def: #export (analyse-tagged-sum analyse tag value) (-> &;Analyser Ident Code (Lux Analysis)) (do Monad<Lux> [tag (macro;normalize tag) @@ -270,10 +290,11 @@ [inferredT valueA+] (&inference;apply-function analyse functionT (list value)) expectedT macro;expected-type _ (&;within-type-env - (TC;check expectedT inferredT))] - (wrap (#la;Variant idx case-size (|> valueA+ list;head assume))))) + (TC;check expectedT inferredT)) + temp &env;next-local] + (wrap (variant idx case-size temp (|> valueA+ list;head assume))))) -(def: #export (analyse-variant analyse tag value) +(def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Lux Analysis)) (do Monad<Lux> [expected macro;expected-type] @@ -286,16 +307,17 @@ (case (list;nth tag flat) (#;Some variant-type) (do @ - [=value (&;with-expected-type variant-type - (analyse value))] - (wrap (#la;Variant tag type-size =value))) + [valueA (&;with-expected-type variant-type + (analyse valueC)) + temp &env;next-local] + (wrap (variant tag type-size temp valueA))) #;None (out-of-bounds-error expected type-size tag))) (#;Named name unnamedT) (&;with-expected-type unnamedT - (analyse-variant analyse tag value)) + (analyse-sum analyse tag valueC)) (#;Var id) (do @ @@ -306,7 +328,7 @@ [expected' (&;within-type-env (TC;read-var id))] (&;with-expected-type expected' - (analyse-variant analyse tag value))) + (analyse-sum analyse tag valueC))) (&;fail (format "Invalid type for variant: " (%type expected))))) (#;UnivQ _) @@ -314,13 +336,13 @@ [[var-id var] (&;within-type-env TC;existential)] (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-variant analyse tag value))) + (analyse-sum analyse tag valueC))) (#;ExQ _) (&common;with-var (function [[var-id var]] (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-variant analyse tag value)))) + (analyse-sum analyse tag valueC)))) _ (&;fail ""))))) diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index 8cfc9b108..4e823276d 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -11,8 +11,9 @@ (#Real Real) (#Char Char) (#Text Text) - (#Variant Nat Nat Analysis) - (#Tuple (List Analysis)) + #Unit + (#Sum (Either Analysis Analysis)) + (#Product Analysis Analysis) (#Case Analysis (List [lp;Pattern Analysis])) (#Function Scope Analysis) (#Apply Analysis Analysis) diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux index e844c194d..6053e2fd7 100644 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ b/new-luxc/test/test/luxc/analyser/primitive.lux @@ -48,6 +48,7 @@ false)) )] + ["unit" Unit #~;Unit [] (function [value] @;analyse-unit)] ["bool" Bool #~;Bool %bool% @;analyse-bool] ["nat" Nat #~;Nat %nat% @;analyse-nat] ["int" Int #~;Int %int% @;analyse-int] @@ -57,13 +58,4 @@ ["text" Text #~;Text %text% @;analyse-text] )] ($_ seq - (assert (format "Can analyse unit.") - (|> (@common;with-unknown-type - @;analyse-unit) - (macro;run init-compiler) - (case> (^ (#R;Success [_type (#~;Tuple (list))])) - (Type/= Unit _type) - - _ - false))) <primitives>))) diff --git a/new-luxc/test/test/luxc/analyser/struct.lux b/new-luxc/test/test/luxc/analyser/struct.lux index 869b2b0d1..8bf7957b5 100644 --- a/new-luxc/test/test/luxc/analyser/struct.lux +++ b/new-luxc/test/test/luxc/analyser/struct.lux @@ -11,7 +11,7 @@ [macro #+ Monad<Lux>] test) (luxc ["&" base] - (lang ["~" analysis]) + (lang ["la" analysis]) [analyser] (analyser ["@" struct] ["@;" common])) @@ -21,18 +21,27 @@ &;Analyser (analyser;analyser (:!! []))) +(def: (flatten-tuple analysis) + (-> la;Analysis (List la;Analysis)) + (case analysis + (#la;Product left right) + (#;Cons left (flatten-tuple right)) + + _ + (list analysis))) + (test: "Tuples" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) primitives (r;list size gen-simple-primitive)] ($_ seq (assert "Can analyse tuple." (|> (@common;with-unknown-type - (@;analyse-tuple analyse (L/map product;right primitives))) + (@;analyse-product analyse (L/map product;right primitives))) (macro;run init-compiler) - (case> (#R;Success [_type (#~;Tuple elems)]) + (case> (#R;Success [_type tupleA]) (and (Type/= (type;tuple (L/map product;left primitives)) _type) - (n.= size (list;size elems))) + (n.= size (list;size (flatten-tuple tupleA)))) _ false)) |