diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/structure.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 278 |
1 files changed, 139 insertions, 139 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index e6cd2dbad..fb521d02e 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -1,4 +1,4 @@ -(;module: +(.module: lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) @@ -14,11 +14,11 @@ (lang [type] (type ["tc" check]))) (luxc ["&" lang] - (lang ["&;" scope] - ["&;" module] + (lang ["&." scope] + ["&." module] ["la" analysis] - (analysis ["&;" common] - ["&;" inference])))) + (analysis ["&." common] + ["&." inference])))) (exception: #export Invalid-Variant-Type) (exception: #export Invalid-Tuple-Type) @@ -34,46 +34,46 @@ (exception: #export 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 + (-> &.Analyser Nat Code (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (&.with-stacked-errors (function [_] (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) + (#.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 + [valueA (&.with-type variant-type (analyse valueC)) - temp &scope;next-local] - (wrap (la;sum tag type-size temp valueA))) + temp &scope.next-local] + (wrap (la.sum tag type-size temp valueA))) - #;None - (&common;variant-out-of-bounds-error expectedT type-size tag))) + #.None + (&common.variant-out-of-bounds-error expectedT type-size tag))) - (#;Named name unnamedT) - (&;with-type unnamedT + (#.Named name unnamedT) + (&.with-type unnamedT (analyse-sum analyse tag valueC)) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') - (&;with-type 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" + (&.throw Cannot-Infer-Numeric-Tag (format " Type: " (%type expectedT) "\n" " Tag: " (%n tag) "\n" "Expression: " (%code valueC))) )) @@ -81,59 +81,59 @@ (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (&;with-type-env <instancer>)] - (&;with-type (maybe;assume (type;apply (list instanceT) expectedT)) + [[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]) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Apply inputT funT) + (#.Apply inputT funT) (case funT - (#;Var funT-id) + (#.Var funT-id) (do @ - [?funT' (&;with-type-env (tc;read funT-id))] + [?funT' (&.with-type-env (tc.read funT-id))] (case ?funT' - (#;Some funT') - (&;with-type (#;Apply inputT funT') + (#.Some funT') + (&.with-type (#.Apply inputT funT') (analyse-sum analyse tag valueC)) _ - (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + (&.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)) + (case (type.apply (list inputT) funT) + #.None + (&.throw Not-Quantified-Type (%type funT)) - (#;Some outputT) - (&;with-type outputT + (#.Some outputT) + (&.with-type outputT (analyse-sum analyse tag valueC)))) _ - (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + (&.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] + (-> &.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 + [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)] + [(#.Product leftT rightT) (#.Cons leftC rightC)] (do @ - [leftA (&;with-type leftT + [leftA (&.with-type leftT (analyse leftC)) rightA (recur rightT rightC)] (wrap (` [(~ leftA) (~ rightA)]))) @@ -157,98 +157,98 @@ ## and what was analysed. [tailT tailC] (do @ - [g!tail (macro;gensym "tail")] - (&;with-type tailT + [g!tail (macro.gensym "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 + (-> &.Analyser (List Code) (Meta la.Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (&.with-stacked-errors (function [_] (Cannot-Analyse-Tuple (format " Type: " (%type expectedT) "\n" "Expression: " (%code (` [(~@ membersC)]))))) (case expectedT - (#;Product _) + (#.Product _) (analyse-typed-product analyse membersC) - (#;Named name unnamedT) - (&;with-type unnamedT + (#.Named name unnamedT) + (&.with-type unnamedT (analyse-product analyse membersC)) - (#;Var id) + (#.Var id) (do @ - [?expectedT' (&;with-type-env - (tc;read id))] + [?expectedT' (&.with-type-env + (tc.read id))] (case ?expectedT' - (#;Some expectedT') - (&;with-type expectedT' + (#.Some expectedT') + (&.with-type expectedT' (analyse-product analyse membersC)) _ ## Must do inference... (do @ - [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + [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)))))) + _ (&.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)) + [[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]) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) - (#;Apply inputT funT) + (#.Apply inputT funT) (case funT - (#;Var funT-id) + (#.Var funT-id) (do @ - [?funT' (&;with-type-env (tc;read funT-id))] + [?funT' (&.with-type-env (tc.read funT-id))] (case ?funT' - (#;Some funT') - (&;with-type (#;Apply inputT funT') + (#.Some funT') + (&.with-type (#.Apply inputT funT') (analyse-product analyse membersC)) _ - (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + (&.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)) + (case (type.apply (list inputT) funT) + #.None + (&.throw Not-Quantified-Type (%type funT)) - (#;Some outputT) - (&;with-type outputT + (#.Some outputT) + (&.with-type outputT (analyse-product analyse membersC)))) _ - (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + (&.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] + (-> &.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 _) + (#.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)))) + [#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)))) @@ -259,17 +259,17 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Meta (List [Ident Code]))) - (monad;map macro;Monad<Meta> + (monad.map macro.Monad<Meta> (function [[key val]] (case key - [_ (#;Tag key)] - (do macro;Monad<Meta> - [key (macro;normalize 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)))))) + (&.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 @@ -279,56 +279,56 @@ (-> (List [Ident Code]) (Meta [(List Code) Type])) (case record ## empty-record = empty-tuple = unit = [] - #;Nil - (:: macro;Monad<Meta> wrap [(list) Unit]) - - (#;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) + #.Nil + (:: macro.Monad<Meta> wrap [(list) Unit]) + + (#.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 + (&.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 @ + [(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" + [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]) + (#.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)))))) + (wrap (dict.put idx val idx->val)))))) (: (Dict Nat Code) - (dict;new number;Hash<Nat>)) + (dict.new number.Hash<Nat>)) record) - #let [ordered-tuple (list/map (function [idx] (maybe;assume (dict;get idx idx->val))) + #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> + (-> &.Analyser (List [Code Code]) (Meta la.Analysis)) + (do macro.Monad<Meta> [members (normalize members) [membersC recordT] (order members)] (case membersC @@ -337,13 +337,13 @@ _ (do @ - [expectedT macro;expected-type] + [expectedT macro.expected-type] (case expectedT - (#;Var _) + (#.Var _) (do @ - [inferenceT (&inference;record recordT) - [inferredT membersA] (&inference;general analyse inferenceT membersC)] - (wrap (la;product membersA))) + [inferenceT (&inference.record recordT) + [inferredT membersA] (&inference.general analyse inferenceT membersC)] + (wrap (la.product membersA))) _ (analyse-product analyse membersC)))))) |