diff options
author | Eduardo Julian | 2018-05-16 00:11:49 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-05-16 00:11:49 -0400 |
commit | 8ba6ac8952e3457b1a09e30ac5312168d48006d1 (patch) | |
tree | f4ed8a04f95bd95165add394541ef81eadbfd839 /new-luxc/source/luxc/lang/analysis/structure.lux | |
parent | 4242e4d3b18eb532ae18e8b38e85ad1ee1988e02 (diff) |
- Migrated structure analysis to stdlib.
- Added an easy way to report information in exceptions.
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/structure.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 365 |
1 files changed, 0 insertions, 365 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux deleted file mode 100644 index f9e7ad8fc..000000000 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ /dev/null @@ -1,365 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [ident] - [number] - [product] - [maybe] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict])) - text/format) - [macro] - (macro [code]) - (lang [type] - (type ["tc" check]))) - (luxc ["&" lang] - (lang ["&." scope] - ["&." module] - ["la" analysis] - (analysis ["&." common] - [".A" primitive] - ["&." inference])))) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Invalid-Variant-Type] - [Invalid-Tuple-Type] - [Not-Quantified-Type] - - [Cannot-Analyse-Variant] - [Cannot-Analyse-Tuple] - - [Cannot-Infer-Numeric-Tag] - [Record-Keys-Must-Be-Tags] - [Cannot-Repeat-Tag] - [Tag-Does-Not-Belong-To-Record] - [Record-Size-Mismatch] - ) - -(def: #export (analyse-sum analyse tag valueC) - (-> &.Analyser Nat Code (Meta la.Analysis)) - (do macro.Monad<Meta> - [expectedT macro.expected-type] - (&.with-stacked-errors - (function (_ _) - (ex.construct Cannot-Analyse-Variant - (format " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Expression: " (%code valueC)))) - (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-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-type unnamedT - (analyse-sum analyse tag valueC)) - - (#.Var id) - (do @ - [?expectedT' (&.with-type-env - (tc.read id))] - (case ?expectedT' - (#.Some expectedT') - (&.with-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 " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Expression: " (%code valueC))) - )) - - (^template [<tag> <instancer>] - (<tag> _) - (do @ - [[instance-id instanceT] (&.with-type-env <instancer>)] - (&.with-type (maybe.assume (type.apply (list instanceT) expectedT)) - (analyse-sum analyse tag valueC)))) - ([#.UnivQ tc.existential] - [#.ExQ tc.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT-id) - (do @ - [?funT' (&.with-type-env (tc.read funT-id))] - (case ?funT' - (#.Some funT') - (&.with-type (#.Apply inputT funT') - (analyse-sum analyse tag valueC)) - - _ - (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Expression: " (%code valueC))))) - - _ - (case (type.apply (list inputT) funT) - #.None - (&.throw Not-Quantified-Type (%type funT)) - - (#.Some outputT) - (&.with-type outputT - (analyse-sum analyse tag valueC)))) - - _ - (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Expression: " (%code valueC))))))) - -(def: (analyse-typed-product analyse membersC+) - (-> &.Analyser (List Code) (Meta la.Analysis)) - (do macro.Monad<Meta> - [expectedT macro.expected-type] - (loop [expectedT expectedT - membersC+ membersC+] - (case [expectedT membersC+] - ## If the tuple runs out, whatever expression is the last gets - ## matched to the remaining type. - [tailT (#.Cons tailC #.Nil)] - (&.with-type tailT - (analyse tailC)) - - ## 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-type leftT - (analyse leftC)) - rightA (recur rightT rightC)] - (wrap (` [(~ leftA) (~ rightA)]))) - - ## 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] - (macro.with-gensyms [g!tail] - (&.with-type tailT - (analyse (` ("lux case" [(~+ tailC)] - (~ g!tail) - (~ g!tail)))))) - )))) - -(def: #export (analyse-product analyse membersC) - (-> &.Analyser (List Code) (Meta la.Analysis)) - (do macro.Monad<Meta> - [expectedT macro.expected-type] - (&.with-stacked-errors - (function (_ _) - (ex.construct Cannot-Analyse-Tuple - (format " Type: " (%type expectedT) "\n" - "Expression: " (%code (` [(~+ membersC)]))))) - (case expectedT - (#.Product _) - (analyse-typed-product analyse membersC) - - (#.Named name unnamedT) - (&.with-type unnamedT - (analyse-product analyse membersC)) - - (#.Var id) - (do @ - [?expectedT' (&.with-type-env - (tc.read id))] - (case ?expectedT' - (#.Some expectedT') - (&.with-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)))))) - - (^template [<tag> <instancer>] - (<tag> _) - (do @ - [[instance-id instanceT] (&.with-type-env <instancer>)] - (&.with-type (maybe.assume (type.apply (list instanceT) expectedT)) - (analyse-product analyse membersC)))) - ([#.UnivQ tc.existential] - [#.ExQ tc.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT-id) - (do @ - [?funT' (&.with-type-env (tc.read funT-id))] - (case ?funT' - (#.Some funT') - (&.with-type (#.Apply inputT funT') - (analyse-product analyse membersC)) - - _ - (&.throw Invalid-Tuple-Type - (format " Type: " (%type expectedT) "\n" - "Expression: " (%code (` [(~+ membersC)])))))) - - _ - (case (type.apply (list inputT) funT) - #.None - (&.throw Not-Quantified-Type (%type funT)) - - (#.Some outputT) - (&.with-type outputT - (analyse-product analyse membersC)))) - - _ - (&.throw Invalid-Tuple-Type - (format " Type: " (%type expectedT) "\n" - "Expression: " (%code (` [(~+ membersC)])))) - )))) - -(def: #export (analyse-tagged-sum analyse tag valueC) - (-> &.Analyser Ident Code (Meta la.Analysis)) - (do macro.Monad<Meta> - [tag (macro.normalize tag) - [idx group variantT] (macro.resolve-tag tag) - expectedT macro.expected-type] - (case expectedT - (#.Var _) - (do @ - [#let [case-size (list.size group)] - inferenceT (&inference.variant idx case-size variantT) - [inferredT valueA+] (&inference.general analyse inferenceT (list valueC)) - 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 macro.Monad<Meta> - (function (_ [key val]) - (case key - [_ (#.Tag key)] - (do macro.Monad<Meta> - [key (macro.normalize key)] - (wrap [key val])) - - _ - (&.throw Record-Keys-Must-Be-Tags - (format " Key: " (%code key) "\n" - "Record: " (%code (code.record record)))))) - 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 - (:: macro.Monad<Meta> wrap [(list) Top]) - - (#.Cons [head-k head-v] _) - (do macro.Monad<Meta> - [head-k (macro.normalize head-k) - [_ tag-set recordT] (macro.resolve-tag head-k) - #let [size-record (list.size record) - size-ts (list.size tag-set)] - _ (if (n/= size-ts size-record) - (wrap []) - (&.throw Record-Size-Mismatch - (format " Expected: " (|> size-ts nat-to-int %i) "\n" - " Actual: " (|> size-record nat-to-int %i) "\n" - " Type: " (%type recordT) "\n" - "Expression: " (%code (|> record - (list/map (function (_ [keyI valueC]) - [(code.tag keyI) valueC])) - code.record))))) - #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 (macro.normalize key)] - (case (dict.get key tag->idx) - #.None - (&.throw Tag-Does-Not-Belong-To-Record - (format " Tag: " (%code (code.tag key)) "\n" - "Type: " (%type recordT))) - - (#.Some idx) - (if (dict.contains? idx idx->val) - (&.throw Cannot-Repeat-Tag - (format " Tag: " (%code (code.tag key)) "\n" - "Record: " (%code (code.record (list/map (function (_ [keyI valC]) - [(code.tag keyI) valC]) - record))))) - (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 macro.Monad<Meta> - [members (normalize members) - [membersC recordT] (order members)] - (case membersC - (^ (list)) - primitiveA.analyse-unit - - (^ (list singletonC)) - (analyse singletonC) - - _ - (do @ - [expectedT macro.expected-type] - (case expectedT - (#.Var _) - (do @ - [inferenceT (&inference.record recordT) - [inferredT membersA] (&inference.general analyse inferenceT membersC)] - (wrap (la.product membersA))) - - _ - (analyse-product analyse membersC)))))) |