diff options
author | Eduardo Julian | 2017-05-29 22:05:57 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-05-29 22:05:57 -0400 |
commit | 953f49d5a46209f2d75e67b50edea378261108cd (patch) | |
tree | b2f1c4e08fbbbfa84c5b918ce68e4acbae08efa1 /new-luxc/source/luxc/analyser/structure.lux | |
parent | 9ca82858b0e15800972ca7b2a776190a8d4b371c (diff) |
- Fixes for pattern-matching (case) analysis.
- Small refactorings.
- Improved common procedures analysis.
- Can now handle tagged structures (variants & records).
- Tests for pattern-matching, functions (definition & application), and common procedures.
Diffstat (limited to 'new-luxc/source/luxc/analyser/structure.lux')
-rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 351 |
1 files changed, 351 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux new file mode 100644 index 000000000..ab6f6adae --- /dev/null +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -0,0 +1,351 @@ +(;module: + lux + (lux (control monad + pipe) + [io #- run] + [function] + (concurrency ["A" atom]) + (data [text "T/" Eq<Text>] + text/format + [ident] + (coll [list "L/" Fold<List> Monoid<List> Monad<List>] + ["D" dict] + ["S" set]) + [number] + [product]) + [macro #+ Monad<Lux>] + (macro [code]) + [type] + (type ["TC" check])) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis] + ["lp" pattern]) + ["&;" module] + ["&;" env] + (analyser ["&;" common] + ["&;" inference]))) + +## [Analysers] +(def: (analyse-typed-product analyse members) + (-> &;Analyser (List Code) (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (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]))) + (mapM Monad<Lux> + (function [[key val]] + (case key + [_ (#;Tag key)] + (do Monad<Lux> + [key (macro;normalize key)] + (wrap [key val])) + + _ + (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + pairs)) + +(def: #export (order-record pairs) + (-> (List [Ident Code]) (Lux [(List Code) Type])) + (case pairs + (#;Cons [head-k head-v] _) + (do Monad<Lux> + [head-k (macro;normalize head-k) + [_ tag-set recordT] (macro;resolve-tag head-k) + #let [size-record (list;size pairs) + size-ts (list;size tag-set)] + _ (if (n.= size-ts size-record) + (wrap []) + (&;fail (format "Record size does not match tag-set size." "\n" + "Expected: " (|> size-ts nat-to-int %i) "\n" + " Actual: " (|> size-record nat-to-int %i) "\n" + "For type: " (%type recordT)))) + #let [tuple-range (list;n.range +0 (n.dec size-ts)) + tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] + idx->val (foldM @ + (function [[key val] idx->val] + (do @ + [key (macro;normalize key)] + (case (D;get key tag->idx) + #;None + (&;fail (format "Tag " (%code (code;tag key)) + " does not belong to tag-set for type " (%type recordT))) + + (#;Some idx) + (if (D;contains? idx idx->val) + (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (wrap (D;put idx val idx->val)))))) + (: (D;Dict Nat Code) + (D;new number;Hash<Nat>)) + pairs) + #let [ordered-tuple (L/map (function [idx] + (assume (D;get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + + _ + (:: Monad<Lux> wrap [(list) Unit]))) + +(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] + (&;with-stacked-errors + (function [_] (format "Invalid type for tuple: " (%type expected))) + (case expected + (#;Product _) + (analyse-typed-product analyse membersC) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-product analyse membersC)) + + (#;Var id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-product analyse membersC))) + (do @ + [membersTA (mapM @ (|>. analyse &common;with-unknown-type) + membersC) + _ (&;within-type-env + (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-product analyse membersC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-product analyse membersC)))) + + _ + (&;fail "") + )))) + +(def: (record-function-type type) + (-> Type (Lux Type)) + (case type + (#;Named name unnamedT) + (do Monad<Lux> + [unnamedT+ (record-function-type unnamedT)] + (wrap (#;Named name unnamedT+))) + + (^template [<tag>] + (<tag> env bodyT) + (do Monad<Lux> + [bodyT+ (record-function-type bodyT)] + (wrap (<tag> env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Product _) + (:: Monad<Lux> wrap (type;function (type;flatten-tuple type) type)) + + _ + (&;fail (format "Not a record type: " (%type type))))) + +(def: (out-of-bounds-error type size tag) + (All [a] (-> Type Nat Nat (Lux a))) + (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" + " Tag: " (%i (nat-to-int tag)) "\n" + "Size: " (%i (nat-to-int size)) "\n" + "Type: " (%type type)))) + +(def: (variant-function-type tag expected-size type) + (-> Nat Nat Type (Lux Type)) + (case type + (#;Named name unnamedT) + (do Monad<Lux> + [unnamedT+ (variant-function-type tag expected-size unnamedT)] + (wrap (#;Named name unnamedT+))) + + (^template [<tag>] + (<tag> env bodyT) + (do Monad<Lux> + [bodyT+ (variant-function-type tag expected-size bodyT)] + (wrap (<tag> env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Sum _) + (let [cases (type;flatten-variant type) + actual-size (list;size cases) + boundary (n.dec expected-size)] + (cond (or (n.= expected-size actual-size) + (and (n.> expected-size actual-size) + (n.< boundary tag))) + (case (list;nth tag cases) + (#;Some caseT) + (:: Monad<Lux> wrap (type;function (list caseT) type)) + + #;None + (out-of-bounds-error type expected-size tag)) + + (n.< expected-size actual-size) + (&;fail (format "Variant type is smaller than expected." "\n" + "Expected: " (%i (nat-to-int expected-size)) "\n" + " Actual: " (%i (nat-to-int actual-size)))) + + (n.= boundary tag) + (let [caseT (type;variant (list;drop boundary cases))] + (:: Monad<Lux> wrap (type;function (list caseT) type))) + + ## else + (out-of-bounds-error type expected-size tag))) + + _ + (&;fail (format "Not a variant type: " (%type type))))) + +(def: #export (analyse-record analyse members) + (-> &;Analyser (List [Code Code]) (Lux Analysis)) + (do Monad<Lux> + [members (normalize-record members) + [members recordT] (order-record members) + expectedT macro;expected-type + functionT (record-function-type recordT) + [inferredT membersA] (&inference;apply-function analyse functionT members) + _ (&;within-type-env + (TC;check expectedT inferredT))] + (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) + (if (n.= (n.dec size) tag) + (if (n.= +1 tag) + (sum-right value) + (L/fold (function;const sum-left) + (sum-right value) + (list;n.range +0 (n.- +2 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) + [idx group variantT] (macro;resolve-tag tag) + #let [case-size (list;size group)] + functionT (variant-function-type idx case-size variantT) + [inferredT valueA+] (&inference;apply-function analyse functionT (list value)) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT inferredT)) + temp &env;next-local] + (wrap (variant idx case-size temp (|> valueA+ list;head assume))))) + +(def: #export (analyse-sum analyse tag valueC) + (-> &;Analyser Nat Code (Lux Analysis)) + (do Monad<Lux> + [expected macro;expected-type] + (&;with-stacked-errors + (function [_] (format "Invalid type for variant: " (%type expected))) + (case expected + (#;Sum _) + (let [flat (type;flatten-variant expected) + type-size (list;size flat)] + (case (list;nth tag flat) + (#;Some variant-type) + (do @ + [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-sum analyse tag valueC)) + + (#;Var id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-sum analyse tag valueC))) + (&;fail (format "Invalid type for variant: " (%type expected))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;within-type-env + TC;existential)] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-sum analyse tag valueC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-sum analyse tag valueC)))) + + _ + (if (n.= +0 tag) + (analyse valueC) + (&;fail "")))))) |