diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis.lux | 111 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 21 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/expression.lux | 126 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 365 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/inference.lux (renamed from new-luxc/source/luxc/lang/analysis/inference.lux) | 108 |
5 files changed, 56 insertions, 675 deletions
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux deleted file mode 100644 index 369e9dd7e..000000000 --- a/new-luxc/source/luxc/lang/analysis.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - lux - (lux [function] - (data (coll [list "list/" Fold<List>])) - (macro [code])) - (luxc (lang [".L" variable #+ Variable]))) - -(type: #export Pattern Code) - -(type: #export Analysis Code) - -## Variants get analysed as binary sum types for the sake of semantic -## simplicity. -## This is because you can encode a variant of any size using just -## binary sums by nesting them. - -(do-template [<name> <side>] - [(def: (<name> inner) - (-> Analysis Analysis) - (` (<side> (~ inner))))] - - [sum-left "lux sum left"] - [sum-right "lux sum right"]) - -(def: (local-variable idx) - (-> Nat Int) - (nat-to-int idx)) - -(def: #export (sum tag size temp value) - (-> Nat Nat Nat Analysis Analysis) - (if (n/= (n/dec size) tag) - (if (n/= +1 tag) - (sum-right value) - (list/fold (function.const sum-left) - (sum-right value) - (list.n/range +0 (n/- +2 tag)))) - (list/fold (function.const sum-left) - (case value - (^or (^code ("lux sum left" (~ inner))) - (^code ("lux sum right" (~ inner)))) - (` ("lux case" (~ value) - {("lux case bind" (~ (code.nat temp))) - ((~ (code.int (local-variable temp))))})) - - _ - value) - (list.n/range +0 tag)))) - -## Tuples get analysed into binary products for the sake of semantic -## simplicity, since products/pairs can encode tuples of any length -## through nesting. - -(def: #export (product members) - (-> (List Analysis) Analysis) - (case members - #.Nil - (` []) - - (#.Cons singleton #.Nil) - singleton - - (#.Cons left right) - (` [(~ left) (~ (product right))]))) - -## Function application gets analysed into single-argument -## applications, since every other kind of application can be encoded -## into a finite series of single-argument applications. - -(def: #export (apply args func) - (-> (List Analysis) Analysis Analysis) - (list/fold (function (_ arg func) - (` ("lux apply" (~ arg) (~ func)))) - func - args)) - -(def: #export (procedure name args) - (-> Text (List Analysis) Analysis) - (` ((~ (code.text name)) (~+ args)))) - -(def: #export (var idx) - (-> Variable Analysis) - (` ((~ (code.int idx))))) - -(def: #export (unfold-tuple analysis) - (-> Analysis (List Analysis)) - (case analysis - (^code [(~ left) (~ right)]) - (#.Cons left (unfold-tuple right)) - - _ - (list analysis))) - -(def: #export (unfold-variant analysis) - (-> Analysis (Maybe [Nat Bool Analysis])) - (loop [so-far +0 - variantA analysis] - (case variantA - (^code ("lux sum left" (~ valueA))) - (case valueA - (^or (^code ("lux sum left" (~ _))) - (^code ("lux sum right" (~ _)))) - (recur (n/inc so-far) valueA) - - _ - (#.Some [so-far false valueA])) - - (^code ("lux sum right" (~ valueA))) - (#.Some [(n/inc so-far) true valueA]) - - _ - #.None))) diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux deleted file mode 100644 index 072616cfa..000000000 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ /dev/null @@ -1,21 +0,0 @@ -(.module: - lux - (lux (control monad - ["ex" exception #+ exception:]) - (data text/format - [product]) - [macro] - (lang [type] - (type ["tc" check]))) - (luxc ["&" lang] - (lang analysis))) - -(exception: #export (Variant-Tag-Out-Of-Bounds {message Text}) - message) - -(def: #export (variant-out-of-bounds-error type size tag) - (All [a] (-> Type Nat Nat (Meta a))) - (&.throw Variant-Tag-Out-Of-Bounds - (format " Tag: " (%n tag) "\n" - "Variant Size: " (%n size) "\n" - "Variant Type: " (%type type)))) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux deleted file mode 100644 index aaa64940b..000000000 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ /dev/null @@ -1,126 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data ["e" error] - [product] - text/format) - [macro] - (lang [type] - (type ["tc" check])) - [host]) - (luxc ["&" lang] - (lang ["&." module] - [".L" host] - [".L" macro] - [".L" extension] - ["la" analysis] - (translation (jvm [".T" common])))) - (// [".A" common] - [".A" function] - [".A" primitive] - [".A" reference] - [".A" structure])) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Macro-Expression-Must-Have-Single-Expansion] - [Unrecognized-Syntax] - [Macro-Expansion-Failed] - ) - -(def: #export (analyser eval) - (-> &.Eval &.Analyser) - (: (-> Code (Meta la.Analysis)) - (function (analyse code) - (do macro.Monad<Meta> - [expectedT macro.expected-type] - (let [[cursor code'] code] - ## The cursor must be set in the compiler for the sake - ## of having useful error messages. - (&.with-cursor cursor - (case code' - (^template [<tag> <analyser>] - (<tag> value) - (<analyser> value)) - ([#.Bool primitiveA.analyse-bool] - [#.Nat primitiveA.analyse-nat] - [#.Int primitiveA.analyse-int] - [#.Deg primitiveA.analyse-deg] - [#.Frac primitiveA.analyse-frac] - [#.Text primitiveA.analyse-text]) - - (^ (#.Tuple (list))) - primitiveA.analyse-unit - - ## Singleton tuples are equivalent to the element they contain. - (^ (#.Tuple (list singleton))) - (analyse singleton) - - (^ (#.Tuple elems)) - (structureA.analyse-product analyse elems) - - (^ (#.Record pairs)) - (structureA.analyse-record analyse pairs) - - (#.Symbol reference) - (referenceA.analyse-reference reference) - - (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) - (do macro.Monad<Meta> - [procedure (extensionL.find-analysis proc-name)] - (procedure analyse eval proc-args)) - - (^template [<tag> <analyser>] - (^ (#.Form (list& [_ (<tag> tag)] - values))) - (case values - (#.Cons value #.Nil) - (<analyser> analyse tag value) - - _ - (<analyser> analyse tag (` [(~+ values)])))) - ([#.Nat structureA.analyse-sum] - [#.Tag structureA.analyse-tagged-sum]) - - (#.Tag tag) - (structureA.analyse-tagged-sum analyse tag (' [])) - - (^ (#.Form (list& func args))) - (do macro.Monad<Meta> - [[funcT funcA] (commonA.with-unknown-type - (analyse func))] - (case funcA - [_ (#.Symbol def-name)] - (do @ - [?macro (&.with-error-tracking - (macro.find-macro def-name))] - (case ?macro - (#.Some macro) - (do @ - [expansion (: (Meta (List Code)) - (function (_ compiler) - (case (macroL.expand macro args compiler) - (#e.Error error) - ((&.throw Macro-Expansion-Failed error) compiler) - - output - output)))] - (case expansion - (^ (list single)) - (analyse single) - - _ - (&.throw Macro-Expression-Must-Have-Single-Expansion (%code code)))) - - _ - (functionA.analyse-apply analyse funcT funcA args))) - - _ - (functionA.analyse-apply analyse funcT funcA args))) - - _ - (&.throw Unrecognized-Syntax (%code code)) - ))))))) 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)))))) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/stdlib/source/lux/lang/analysis/inference.lux index 9bc668050..732a8e6e3 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/stdlib/source/lux/lang/analysis/inference.lux @@ -7,33 +7,41 @@ text/format (coll [list "list/" Functor<List>])) [macro "macro/" Monad<Meta>] + [lang] (lang [type] - (type ["tc" check]))) - (luxc ["&" lang] - (lang ["la" analysis #+ Analysis] - (analysis ["&." common])))) + (type ["tc" check]) + [analysis #+ Analysis Analyser] + (analysis [".A" type])))) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag analysis.Tag} {type Type}) + (ex.report ["Tag" (%n tag)] + ["Variant size" (%n size)] + ["Variant type" (%type type)])) + +(exception: #export (cannot-infer {type Type} {args (List Code)}) + (ex.report ["Type" (%type type)] + ["Arguments" (|> args + list.enumerate + (list/map (function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(exception: #export (cannot-infer-argument {inferred Type} {argument Code}) + (ex.report ["Inferred Type" (%type inferred)] + ["Argument" (%code argument)])) + +(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) + (ex.report ["Expected" (%i (.int expected))] + ["Actual" (%i (.int actual))])) (do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Cannot-Infer] - [Cannot-Infer-Argument] - [Smaller-Variant-Than-Expected] - [Invalid-Type-Application] - [Not-A-Record-Type] - [Not-A-Variant-Type] - ) + [(exception: #export (<name> {type Type}) + (%type type))] -(def: (cannot-infer type args) - (-> Type (List Code) Text) - (format " Type: " (%type type) "\n" - "Arguments:" - (|> args - list.enumerate - (list/map (function (_ [idx argC]) - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with "")))) + [not-a-variant-type] + [not-a-record-type] + [invalid-type-application] + ) (def: (replace-bound bound-idx replacementT type) (-> Nat Type Type Type) @@ -69,7 +77,7 @@ (Meta Type) (do macro.Monad<Meta> [[_module _line _column] macro.cursor - [ex-id exT] (&.with-type-env tc.existential)] + [ex-id exT] (typeA.with-env tc.existential)] (wrap (#.Primitive (format "{New Type @ " (%t _module) "," (%n _line) "," (%n _column) @@ -84,11 +92,11 @@ ## But, so long as the type being used for the inference can be treated ## as a function type, this method of inference should work. (def: #export (general analyse inferT args) - (-> &.Analyser Type (List Code) (Meta [Type (List Analysis)])) + (-> Analyser Type (List Code) (Meta [Type (List Analysis)])) (case args #.Nil (do macro.Monad<Meta> - [_ (&.infer inferT)] + [_ (typeA.infer inferT)] (wrap [inferT (list)])) (#.Cons argC args') @@ -98,22 +106,22 @@ (#.UnivQ _) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var)] + [[var-id varT] (typeA.with-env tc.var)] (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) (#.ExQ _) (do macro.Monad<Meta> - [[var-id varT] (&.with-type-env tc.var) + [[var-id varT] (typeA.with-env tc.var) output (general analyse (maybe.assume (type.apply (list varT) inferT)) args) - bound? (&.with-type-env + bound? (typeA.with-env (tc.bound? var-id)) _ (if bound? (wrap []) (do @ [newT new-named-type] - (&.with-type-env + (typeA.with-env (tc.check varT newT))))] (wrap output)) @@ -123,7 +131,7 @@ (general analyse outputT args) #.None - (&.throw Invalid-Type-Application (%type inferT))) + (lang.throw invalid-type-application inferT)) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which @@ -135,27 +143,25 @@ (#.Function inputT outputT) (do macro.Monad<Meta> [[outputT' args'A] (general analyse outputT args') - argA (&.with-stacked-errors + argA (lang.with-stacked-errors (function (_ _) - (ex.construct Cannot-Infer-Argument - (format "Inferred Type: " (%type inputT) "\n" - " Argument: " (%code argC)))) - (&.with-type inputT + (ex.construct cannot-infer-argument [inputT argC])) + (typeA.with-type inputT (analyse argC)))] (wrap [outputT' (list& argA args'A)])) (#.Var infer-id) (do macro.Monad<Meta> - [?inferT' (&.with-type-env (tc.read infer-id))] + [?inferT' (typeA.with-env (tc.read infer-id))] (case ?inferT' (#.Some inferT') (general analyse inferT' args) _ - (&.throw Cannot-Infer (cannot-infer inferT args)))) + (lang.throw cannot-infer [inferT args]))) _ - (&.throw Cannot-Infer (cannot-infer inferT args))) + (lang.throw cannot-infer [inferT args])) )) ## Turns a record type into the kind of function type suitable for inference. @@ -179,13 +185,13 @@ (record outputT) #.None - (&.throw Invalid-Type-Application (%type inferT))) + (lang.throw invalid-type-application inferT)) (#.Product _) (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) _ - (&.throw Not-A-Record-Type (%type inferT)))) + (lang.throw not-a-record-type inferT))) ## Turns a variant type into the kind of function type suitable for inference. (def: #export (variant tag expected-size inferT) @@ -201,7 +207,7 @@ (^template [<tag>] (<tag> env bodyT) (do macro.Monad<Meta> - [bodyT+ (recur (n/inc depth) bodyT)] + [bodyT+ (recur (inc depth) bodyT)] (wrap (<tag> env bodyT+)))) ([#.UnivQ] [#.ExQ]) @@ -209,7 +215,7 @@ (#.Sum _) (let [cases (type.flatten-variant currentT) actual-size (list.size cases) - boundary (n/dec expected-size)] + boundary (dec expected-size)] (cond (or (n/= expected-size actual-size) (and (n/> expected-size actual-size) (n/< boundary tag))) @@ -217,28 +223,26 @@ (#.Some caseT) (macro/wrap (if (n/= +0 depth) (type.function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] + (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)] (type.function (list (replace! caseT)) (replace! currentT))))) #.None - (&common.variant-out-of-bounds-error inferT expected-size tag)) + (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])) (n/< expected-size actual-size) - (&.throw Smaller-Variant-Than-Expected - (format "Expected: " (%i (nat-to-int expected-size)) "\n" - " Actual: " (%i (nat-to-int actual-size)))) + (lang.throw smaller-variant-than-expected [expected-size actual-size]) (n/= boundary tag) (let [caseT (type.variant (list.drop boundary cases))] (macro/wrap (if (n/= +0 depth) (type.function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)] + (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)] (type.function (list (replace! caseT)) (replace! currentT)))))) ## else - (&common.variant-out-of-bounds-error inferT expected-size tag))) + (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))) (#.Apply inputT funcT) (case (type.apply (list inputT) funcT) @@ -246,7 +250,7 @@ (variant tag expected-size outputT) #.None - (&.throw Invalid-Type-Application (%type inferT))) + (lang.throw invalid-type-application inferT)) _ - (&.throw Not-A-Variant-Type (%type inferT))))) + (lang.throw not-a-variant-type inferT)))) |