diff options
author | Eduardo Julian | 2017-10-31 23:39:49 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-10-31 23:39:49 -0400 |
commit | 15121222d570f8fe3c5a326208e4f0bad737e63c (patch) | |
tree | 88c93ed1f4965fd0e80677df5553a0d47e521963 /new-luxc/source/luxc/lang/analysis/structure.lux | |
parent | a269ea72337852e8e57bd427773baed111ad6e92 (diff) |
- Re-organized analysis.
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/structure.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 311 |
1 files changed, 311 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux new file mode 100644 index 000000000..0284245e1 --- /dev/null +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -0,0 +1,311 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + pipe) + [function] + (concurrency ["A" atom]) + (data [ident] + [number] + [product] + [maybe] + (coll [list "list/" Functor<List>] + [dict #+ Dict]) + [text] + text/format) + [meta] + (meta [code] + [type] + (type ["tc" check]))) + (luxc ["&" base] + (lang ["la" analysis] + (analysis ["&;" common] + ["&;" inference])) + ["&;" module] + ["&;" scope])) + +(exception: #export Not-Variant-Type) +(exception: #export Not-Tuple-Type) +(exception: #export Cannot-Infer-Numeric-Tag) + +(type: Type-Error + (-> Type Text)) + +(def: (not-quantified type) + Type-Error + (format "Not a quantified type: " (%type type))) + +(def: #export (analyse-sum analyse tag valueC) + (-> &;Analyser Nat Code (Meta la;Analysis)) + (do meta;Monad<Meta> + [expectedT meta;expected-type] + (&;with-stacked-errors + (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT)))) + (case expectedT + (#;Sum _) + (let [flat (type;flatten-variant expectedT) + type-size (list;size flat)] + (case (list;nth tag flat) + (#;Some variant-type) + (do @ + [valueA (&;with-expected-type variant-type + (analyse valueC)) + temp &scope;next-local] + (wrap (la;sum tag type-size temp valueA))) + + #;None + (&common;variant-out-of-bounds-error expectedT type-size tag))) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-sum analyse tag valueC)) + + (#;Var id) + (do @ + [bound? (&;with-type-env + (tc;bound? id))] + (if bound? + (do @ + [expectedT' (&;with-type-env + (tc;read id))] + (&;with-expected-type expectedT' + (analyse-sum analyse tag valueC))) + ## 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. + (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;with-type-env + tc;existential)] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (analyse-sum analyse tag valueC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (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))) + + _ + (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT))))))) + +(def: (analyse-typed-product analyse members) + (-> &;Analyser (List Code) (Meta la;Analysis)) + (do meta;Monad<Meta> + [expectedT meta;expected-type] + (loop [expectedT expectedT + members members] + (case [expectedT members] + ## If the type and the code are still ongoing, match each + ## sub-expression to its corresponding type. + [(#;Product leftT rightT) (#;Cons leftC rightC)] + (do @ + [leftA (&;with-expected-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (` [(~ leftA) (~ rightA)]))) + + ## If the tuple runs out, whatever expression is the last gets + ## matched to the remaining type. + [tailT (#;Cons tailC #;Nil)] + (&;with-expected-type tailT + (analyse tailC)) + + ## If, however, the type runs out but there is still enough + ## tail, the remaining elements get packaged into another + ## tuple, and analysed through the intermediation of a + ## temporary local variable. + ## The reason for this is that it is assumed that the type of + ## the tuple represents the expectations of the user. + ## If the type is for a 3-tuple, but a 5-tuple is provided, it + ## is assumed that the user intended the following layout: + ## [0, 1, [2, 3, 4]] + ## but that, for whatever reason, it was written in a flat + ## way. + ## The reason why an intermediate variable is used is that if + ## the code was just re-written with just tuple nesting, the + ## resulting analysis would have undone the explicity nesting, + ## since Product nodes rely on nesting inherently, thereby + ## blurring the line between what was wanted (the separation) + ## and what was analysed. + [tailT tailC] + (do @ + [g!tail (meta;gensym "tail")] + (&;with-expected-type tailT + (analyse (` ((~' _lux_case) [(~@ tailC)] + (~ g!tail) + (~ g!tail)))))) + )))) + +(def: #export (analyse-product analyse membersC) + (-> &;Analyser (List Code) (Meta la;Analysis)) + (do meta;Monad<Meta> + [expectedT meta;expected-type] + (&;with-stacked-errors + (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)]))))) + (case expectedT + (#;Product _) + (analyse-typed-product analyse membersC) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-product analyse membersC)) + + (#;Var id) + (do @ + [bound? (&;with-type-env + (tc;bound? id))] + (if bound? + (do @ + [expectedT' (&;with-type-env + (tc;read id))] + (&;with-expected-type expectedT' + (analyse-product analyse membersC))) + ## Must do inference... + (do @ + [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + membersC) + _ (&;with-type-env + (tc;check expectedT + (type;tuple (list/map product;left membersTA))))] + (wrap (la;product (list/map product;right membersTA)))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;with-type-env + tc;existential)] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (analyse-product analyse membersC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (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))) + + _ + (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)])))) + )))) + +(def: #export (analyse-tagged-sum analyse tag valueC) + (-> &;Analyser Ident Code (Meta la;Analysis)) + (do meta;Monad<Meta> + [tag (meta;normalize tag) + [idx group variantT] (meta;resolve-tag tag) + expectedT meta;expected-type] + (case expectedT + (#;Var _) + (do @ + [#let [case-size (list;size group)] + inferenceT (&inference;variant idx case-size variantT) + [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) + _ (&;with-type-env + (tc;check expectedT inferredT)) + temp &scope;next-local] + (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) + + _ + (analyse-sum analyse idx valueC)))) + +## There cannot be any ambiguity or improper syntax when analysing +## records, so they must be normalized for further analysis. +## Normalization just means that all the tags get resolved to their +## canonical form (with their corresponding module identified). +(def: #export (normalize record) + (-> (List [Code Code]) (Meta (List [Ident Code]))) + (monad;map meta;Monad<Meta> + (function [[key val]] + (case key + [_ (#;Tag key)] + (do meta;Monad<Meta> + [key (meta;normalize key)] + (wrap [key val])) + + _ + (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + record)) + +## Lux already possesses the means to analyse tuples, so +## re-implementing the same functionality for records makes no sense. +## Records, thus, get transformed into tuples by ordering the elements. +(def: #export (order record) + (-> (List [Ident Code]) (Meta [(List Code) Type])) + (case record + ## empty-record = empty-tuple = unit = [] + #;Nil + (:: meta;Monad<Meta> wrap [(list) Unit]) + + (#;Cons [head-k head-v] _) + (do meta;Monad<Meta> + [head-k (meta;normalize head-k) + [_ tag-set recordT] (meta;resolve-tag head-k) + #let [size-record (list;size record) + 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 (dict;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] + idx->val (monad;fold @ + (function [[key val] idx->val] + (do @ + [key (meta;normalize key)] + (case (dict;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 (dict;contains? idx idx->val) + (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (wrap (dict;put idx val idx->val)))))) + (: (Dict Nat Code) + (dict;new number;Hash<Nat>)) + record) + #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (analyse-record analyse members) + (-> &;Analyser (List [Code Code]) (Meta la;Analysis)) + (do meta;Monad<Meta> + [members (normalize members) + [members recordT] (order members) + expectedT meta;expected-type + inferenceT (&inference;record recordT) + [inferredT membersA] (&inference;apply-function analyse inferenceT members) + _ (&;with-type-env + (tc;check expectedT inferredT))] + (wrap (la;product membersA)))) |