diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser')
-rw-r--r-- | new-luxc/source/luxc/analyser/case.lux | 32 | ||||
-rw-r--r-- | new-luxc/source/luxc/analyser/function.lux | 13 | ||||
-rw-r--r-- | new-luxc/source/luxc/analyser/inference.lux | 158 | ||||
-rw-r--r-- | new-luxc/source/luxc/analyser/reference.lux | 22 | ||||
-rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 71 |
5 files changed, 185 insertions, 111 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index b65b9ff94..b17dbcbfd 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -1,6 +1,7 @@ (;module: lux (lux (control [monad #+ do] + ["ex" exception #+ exception:] eq) (data [bool] [number] @@ -21,10 +22,15 @@ ["&;" structure]) (. ["&&;" coverage])) +(exception: #export Cannot-Match-Type-With-Pattern) +(exception: #export Sum-Type-Has-No-Case) +(exception: #export Unrecognized-Pattern-Syntax) + (def: (pattern-error type pattern) (-> Type Code Text) - (format "Cannot match this type: " (%type type) "\n" - " With this pattern: " (%code pattern))) + (Cannot-Match-Type-With-Pattern + (format " Type: " (%type type) "\n" + "Pattern: " (%code pattern)))) ## Type-checking on the input value is done during the analysis of a ## "case" expression, to ensure that the patterns being used make @@ -56,6 +62,14 @@ tc;existential)] (simplify-case-type (maybe;assume (type;apply (list exT) type)))) + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (:: meta;Monad<Meta> wrap outputT) + + #;None + (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT)))) + _ (:: meta;Monad<Meta> wrap type))) @@ -122,7 +136,7 @@ [inputT' (simplify-case-type inputT)] (case inputT' (#;Product _) - (let [sub-types (type;flatten-tuple inputT) + (let [sub-types (type;flatten-tuple inputT') num-sub-types (maybe;default (list;size sub-types) num-tags) num-sub-patterns (list;size sub-patterns) @@ -175,7 +189,7 @@ [inputT' (simplify-case-type inputT)] (case inputT' (#;Sum _) - (let [flat-sum (type;flatten-variant inputT) + (let [flat-sum (type;flatten-variant inputT') size-sum (list;size flat-sum) num-cases (maybe;default size-sum num-tags)] (case (list;nth idx flat-sum) @@ -196,7 +210,9 @@ nextA]))) _ - (&;fail (format "Cannot match index " (%n idx) " against type: " (%type inputT))))) + (&;throw Sum-Type-Has-No-Case + (format "Case: " (%n idx) "\n" + "Type: " (%type inputT))))) _ (&;fail (pattern-error inputT pattern))))) @@ -211,10 +227,10 @@ (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) _ - (&;fail (format "Unrecognized pattern syntax: " (%code pattern))) + (&;throw Unrecognized-Pattern-Syntax (%code pattern)) )) -(def: #export (analyse-case analyse input branches) +(def: #export (analyse-case analyse inputC branches) (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) (case branches #;Nil @@ -223,7 +239,7 @@ (#;Cons [patternH bodyH] branchesT) (do meta;Monad<Meta> [[inputT inputA] (&common;with-unknown-type - (analyse input)) + (analyse inputC)) outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) outputT (monad;map @ (function [[patternT bodyT]] diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux index 1432308f8..55896480e 100644 --- a/new-luxc/source/luxc/analyser/function.lux +++ b/new-luxc/source/luxc/analyser/function.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control monad) + (lux (control monad + ["ex" exception #+ exception:]) (data [maybe] [text] text/format @@ -14,6 +15,9 @@ (analyser ["&;" common] ["&;" inference]))) +(exception: #export Invalid-Function-Type) +(exception: #export Cannot-Apply-Function) + ## [Analysers] (def: #export (analyse-function analyse func-name arg-name body) (-> &;Analyser Text Text Code (Meta Analysis)) @@ -21,7 +25,7 @@ [functionT meta;expected-type] (loop [expectedT functionT] (&;with-stacked-errors - (function [_] (format "Functions require function types: " (type;to-text expectedT))) + (function [_] (Invalid-Function-Type (%type expectedT))) (case expectedT (#;Named name unnamedT) (recur unnamedT) @@ -92,8 +96,9 @@ (def: #export (analyse-apply analyse funcT funcA args) (-> &;Analyser Type Analysis (List Code) (Meta Analysis)) (&;with-stacked-errors - (function [_] (format "Cannot apply function " (%type funcT) - " to args: " (|> args (list/map %code) (text;join-with " ")))) + (function [_] + (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" + "Arguments: " (|> args (list/map %code) (text;join-with " "))))) (do Monad<Meta> [expected meta;expected-type [applyT argsA] (&inference;apply-function analyse funcT args) diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux index 86832ae9e..049abec28 100644 --- a/new-luxc/source/luxc/analyser/inference.lux +++ b/new-luxc/source/luxc/analyser/inference.lux @@ -1,9 +1,11 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) (data [maybe] + [text] text/format - (coll [list "L/" Functor<List>])) + (coll [list "list/" Functor<List>])) [meta #+ Monad<Meta>] (meta [type] (type ["tc" check]))) @@ -11,6 +13,10 @@ (lang ["la" analysis #+ Analysis]) (analyser ["&;" common]))) +(exception: #export Cannot-Infer) +(exception: #export Cannot-Infer-Argument) +(exception: #export Smaller-Variant-Than-Expected) + ## When doing inference, type-variables often need to be created in ## order to figure out which types are present in the expression being ## inferred. @@ -23,7 +29,7 @@ (-> Nat Nat Type Type) (case type (#;Primitive name params) - (#;Primitive name (L/map (replace-var var-id bound-idx) params)) + (#;Primitive name (list/map (replace-var var-id bound-idx) params)) (^template [<tag>] (<tag> left right) @@ -41,15 +47,41 @@ (^template [<tag>] (<tag> env quantified) - (<tag> (L/map (replace-var var-id bound-idx) env) + (<tag> (list/map (replace-var var-id bound-idx) env) (replace-var var-id (n.+ +2 bound-idx) quantified))) ([#;UnivQ] [#;ExQ]) - (#;Named name unnamedT) - (#;Named name - (replace-var var-id bound-idx unnamedT)) + _ + type)) +(def: (replace-bound bound-idx replacementT type) + (-> Nat Type Type Type) + (case type + (#;Primitive name params) + (#;Primitive name (list/map (replace-bound bound-idx replacementT) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (replace-bound bound-idx replacementT left) + (replace-bound bound-idx replacementT right))) + ([#;Sum] + [#;Product] + [#;Function] + [#;Apply]) + + (#;Bound idx) + (if (n.= bound-idx idx) + replacementT + type) + + (^template [<tag>] + (<tag> env quantified) + (<tag> (list/map (replace-bound bound-idx replacementT) env) + (replace-bound (n.+ +2 bound-idx) replacementT quantified))) + ([#;UnivQ] + [#;ExQ]) + _ type)) @@ -66,7 +98,7 @@ #;Nil (:: Monad<Meta> wrap [funcT (list)]) - (#;Cons arg args') + (#;Cons argC args') (case funcT (#;Named name unnamedT) (apply-function analyse unnamedT args) @@ -104,29 +136,31 @@ (do Monad<Meta> [[outputT' args'A] (apply-function analyse outputT args') argA (&;with-stacked-errors - (function [_] (format "Expected type: " (%type inputT) "\n" - " For argument: " (%code arg))) + (function [_] (Cannot-Infer-Argument + (format "Inferred Type: " (%type inputT) "\n" + " Argument: " (%code argC)))) (&;with-expected-type inputT - (analyse arg)))] + (analyse argC)))] (wrap [outputT' (list& argA args'A)])) _ - (&;fail (format "Cannot apply a non-function: " (%type funcT)))) + (&;throw Cannot-Infer (format "Inference Type: " (%type funcT) + " Arguments: " (|> args (list/map %code) (text;join-with " "))))) )) ## Turns a record type into the kind of function type suitable for inference. -(def: #export (record-inference-type type) +(def: #export (record type) (-> Type (Meta Type)) (case type (#;Named name unnamedT) (do Monad<Meta> - [unnamedT+ (record-inference-type unnamedT)] - (wrap (#;Named name unnamedT+))) + [unnamedT+ (record unnamedT)] + (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) (do Monad<Meta> - [bodyT+ (record-inference-type bodyT)] + [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) ([#;UnivQ] [#;ExQ]) @@ -138,47 +172,57 @@ (&;fail (format "Not a record type: " (%type type))))) ## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant-inference-type tag expected-size type) +(def: #export (variant tag expected-size type) (-> Nat Nat Type (Meta Type)) - (case type - (#;Named name unnamedT) - (do Monad<Meta> - [unnamedT+ (variant-inference-type tag expected-size unnamedT)] - (wrap (#;Named name unnamedT+))) - - (^template [<tag>] - (<tag> env bodyT) + (loop [depth +0 + currentT type] + (case currentT + (#;Named name unnamedT) (do Monad<Meta> - [bodyT+ (variant-inference-type tag expected-size bodyT)] - (wrap (<tag> env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Sum _) - (let [cases (type;flatten-variant type) - actual-size (list;size cases) - boundary (n.dec expected-size)] - (cond (or (n.= expected-size actual-size) - (and (n.> expected-size actual-size) - (n.< boundary tag))) - (case (list;nth tag cases) - (#;Some caseT) - (:: Monad<Meta> wrap (type;function (list caseT) type)) - - #;None - (&common;variant-out-of-bounds-error type expected-size tag)) - - (n.< expected-size actual-size) - (&;fail (format "Variant type is smaller than expected." "\n" - "Expected: " (%i (nat-to-int expected-size)) "\n" - " Actual: " (%i (nat-to-int actual-size)))) - - (n.= boundary tag) - (let [caseT (type;variant (list;drop boundary cases))] - (:: Monad<Meta> wrap (type;function (list caseT) type))) - - ## else - (&common;variant-out-of-bounds-error type expected-size tag))) + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + (<tag> env bodyT) + (do Monad<Meta> + [bodyT+ (recur (n.inc depth) bodyT)] + (wrap (<tag> env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Sum _) + (let [cases (type;flatten-variant currentT) + actual-size (list;size cases) + boundary (n.dec expected-size)] + (cond (or (n.= expected-size actual-size) + (and (n.> expected-size actual-size) + (n.< boundary tag))) + (case (list;nth tag cases) + (#;Some caseT) + (:: Monad<Meta> wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT))))) + + #;None + (&common;variant-out-of-bounds-error type expected-size tag)) + + (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)))) + + (n.= boundary tag) + (let [caseT (type;variant (list;drop boundary cases))] + (:: Monad<Meta> wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT)))))) + + ## else + (&common;variant-out-of-bounds-error type expected-size tag))) - _ - (&;fail (format "Not a variant type: " (%type type))))) + _ + (&;fail (format "Not a variant type: " (%type type)))))) diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux index 9756a1b9c..4a2f6dbc5 100644 --- a/new-luxc/source/luxc/analyser/reference.lux +++ b/new-luxc/source/luxc/analyser/reference.lux @@ -1,8 +1,8 @@ (;module: lux (lux (control monad) - [meta #+ Monad<Meta>] - (meta (type ["TC" check]))) + [meta] + (meta (type ["tc" check]))) (luxc ["&" base] (lang ["la" analysis #+ Analysis]) ["&;" scope])) @@ -10,23 +10,23 @@ ## [Analysers] (def: (analyse-definition def-name) (-> Ident (Meta Analysis)) - (do Monad<Meta> - [actual (meta;find-def-type def-name) - expected meta;expected-type + (do meta;Monad<Meta> + [actualT (meta;find-def-type def-name) + expectedT meta;expected-type _ (&;with-type-env - (TC;check expected actual))] + (tc;check expectedT actualT))] (wrap (#la;Definition def-name)))) (def: (analyse-variable var-name) (-> Text (Meta (Maybe Analysis))) - (do Monad<Meta> + (do meta;Monad<Meta> [?var (&scope;find var-name)] (case ?var - (#;Some [actual ref]) + (#;Some [actualT ref]) (do @ - [expected meta;expected-type + [expectedT meta;expected-type _ (&;with-type-env - (TC;check expected actual))] + (tc;check expectedT actualT))] (wrap (#;Some (#la;Variable ref)))) #;None @@ -36,7 +36,7 @@ (-> Ident (Meta Analysis)) (case reference ["" simple-name] - (do Monad<Meta> + (do meta;Monad<Meta> [?var (analyse-variable simple-name)] (case ?var (#;Some analysis) diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 8c1f7118c..7720202d8 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -1,6 +1,7 @@ (;module: lux (lux (control [monad #+ do] + ["ex" exception #+ exception:] pipe) [function] (concurrency ["A" atom]) @@ -23,13 +24,13 @@ (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-variant type) - Type-Error - (format "Invalid type for variant: " (%type type))) - (def: (not-quantified type) Type-Error (format "Not a quantified type: " (%type type))) @@ -37,12 +38,14 @@ (def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Meta la;Analysis)) (do meta;Monad<Meta> - [expected meta;expected-type] + [expectedT meta;expected-type] (&;with-stacked-errors - (function [_] (not-variant expected)) - (case expected + (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT)))) + (case expectedT (#;Sum _) - (let [flat (type;flatten-variant expected) + (let [flat (type;flatten-variant expectedT) type-size (list;size flat)] (case (list;nth tag flat) (#;Some variant-type) @@ -53,7 +56,7 @@ (wrap (la;sum tag type-size temp valueA))) #;None - (&common;variant-out-of-bounds-error expected type-size tag))) + (&common;variant-out-of-bounds-error expectedT type-size tag))) (#;Named name unnamedT) (&;with-expected-type unnamedT @@ -65,26 +68,28 @@ (tc;bound? id))] (if bound? (do @ - [expected' (&;with-type-env - (tc;read id))] - (&;with-expected-type expected' + [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. - (&;fail (not-variant expected)))) + (&;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) expected)) + (&;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) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) (analyse-sum analyse tag valueC)))) (#;Apply inputT funT) @@ -97,15 +102,17 @@ (analyse-sum analyse tag valueC))) _ - (&;fail ""))))) + (&;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> - [expected meta;expected-type] - (loop [expected expected + [expectedT meta;expected-type] + (loop [expectedT expectedT members members] - (case [expected 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)] @@ -150,10 +157,11 @@ (def: #export (analyse-product analyse membersC) (-> &;Analyser (List Code) (Meta la;Analysis)) (do meta;Monad<Meta> - [expected meta;expected-type] + [expectedT meta;expected-type] (&;with-stacked-errors - (function [_] (format "Invalid type for tuple: " (%type expected))) - (case expected + (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)]))))) + (case expectedT (#;Product _) (analyse-typed-product analyse membersC) @@ -167,16 +175,16 @@ (tc;bound? id))] (if bound? (do @ - [expected' (&;with-type-env - (tc;read id))] - (&;with-expected-type expected' + [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 expected + (tc;check expectedT (type;tuple (list/map product;left membersTA))))] (wrap (la;product (list/map product;right membersTA)))))) @@ -184,13 +192,13 @@ (do @ [[var-id var] (&;with-type-env tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expected)) + (&;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) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) (analyse-product analyse membersC)))) (#;Apply inputT funT) @@ -203,7 +211,8 @@ (analyse-product analyse membersC))) _ - (&;fail "") + (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)])))) )))) (def: #export (analyse-tagged-sum analyse tag valueC) @@ -216,7 +225,7 @@ (#;Var _) (do @ [#let [case-size (list;size group)] - inferenceT (&inference;variant-inference-type idx case-size variantT) + inferenceT (&inference;variant idx case-size variantT) [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) _ (&;with-type-env (tc;check expectedT inferredT)) @@ -295,7 +304,7 @@ [members (normalize members) [members recordT] (order members) expectedT meta;expected-type - inferenceT (&inference;record-inference-type recordT) + inferenceT (&inference;record recordT) [inferredT membersA] (&inference;apply-function analyse inferenceT members) _ (&;with-type-env (tc;check expectedT inferredT))] |