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/analyser/structure.lux | |
parent | a269ea72337852e8e57bd427773baed111ad6e92 (diff) |
- Re-organized analysis.
Diffstat (limited to 'new-luxc/source/luxc/analyser/structure.lux')
-rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 311 |
1 files changed, 0 insertions, 311 deletions
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux deleted file mode 100644 index d523065ea..000000000 --- a/new-luxc/source/luxc/analyser/structure.lux +++ /dev/null @@ -1,311 +0,0 @@ -(;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]) - ["&;" module] - ["&;" scope] - (analyser ["&;" common] - ["&;" inference]))) - -(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)))) |