diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case.lux | 23 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case/coverage.lux | 13 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 3 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/expression.lux | 15 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 38 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/inference.lux | 28 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 71 |
7 files changed, 115 insertions, 76 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index c40bb2ac3..a9731a1d7 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -22,13 +22,18 @@ [".A" structure] (case [".A" coverage]))))) -(exception: #export Cannot-Match-Type-With-Pattern) -(exception: #export Sum-Type-Has-No-Case) -(exception: #export Unrecognized-Pattern-Syntax) -(exception: #export Cannot-Simplify-Type-For-Pattern-Matching) -(exception: #export Cannot-Have-Empty-Branches) -(exception: #export Non-Exhaustive-Pattern-Matching) -(exception: #export Symbols-Must-Be-Unqualified-Inside-Patterns) +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Cannot-Match-Type-With-Pattern] + [Sum-Type-Has-No-Case] + [Unrecognized-Pattern-Syntax] + [Cannot-Simplify-Type-For-Pattern-Matching] + [Cannot-Have-Empty-Branches] + [Non-Exhaustive-Pattern-Matching] + [Symbols-Must-Be-Unqualified-Inside-Patterns] + ) (def: (pattern-error type pattern) (-> Type Code Text) @@ -204,7 +209,7 @@ [[memberP+ thenA] (list/fold (: (All [a] (-> [Type Code] (Meta [(List la.Pattern) a]) (Meta [(List la.Pattern) a]))) - (function [[memberT memberC] then] + (function (_ [memberT memberC] then) (do @ [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a]))) analyse-pattern) @@ -292,7 +297,7 @@ (analyse inputC)) outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) outputT (monad.map @ - (function [[patternT bodyT]] + (function (_ [patternT bodyT]) (analyse-pattern #.None inputT patternT (analyse bodyT))) branchesT) outputHC (|> outputH product.left coverageA.determine) diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/new-luxc/source/luxc/lang/analysis/case/coverage.lux index ae72b47e4..b81a3b7a9 100644 --- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux +++ b/new-luxc/source/luxc/lang/analysis/case/coverage.lux @@ -13,6 +13,9 @@ (luxc ["&" lang] (lang ["la" analysis]))) +(exception: #export (Unknown-Pattern {message Text}) + message) + ## The coverage of a pattern-matching expression summarizes how well ## all the possible values of an input are being covered by the ## different patterns involved. @@ -42,8 +45,6 @@ _ false)) -(exception: #export Unknown-Pattern) - (def: #export (determine pattern) (-> la.Pattern (Meta Coverage)) (case pattern @@ -142,7 +143,7 @@ (let [flatR (flatten-alt reference) flatS (flatten-alt sample)] (and (n/= (list.size flatR) (list.size flatS)) - (list.every? (function [[coverageR coverageS]] + (list.every? (function (_ [coverageR coverageS]) (= coverageR coverageS)) (list.zip2 flatR flatS)))) @@ -184,7 +185,7 @@ ## else (do e.Monad<Error> [casesM (monad.fold @ - (function [[tagA coverageA] casesSF'] + (function (_ [tagA coverageA] casesSF') (case (dict.get tagA casesSF') (#.Some coverageSF) (do @ @@ -251,7 +252,7 @@ [#let [fuse-once (: (-> Coverage (List Coverage) (e.Error [(Maybe Coverage) (List Coverage)])) - (function [coverage possibilities] + (function (_ coverage possibilities) (loop [alts possibilities] (case alts #.Nil @@ -284,7 +285,7 @@ #.None (case (list.reverse possibilities) (#.Cons last prevs) - (wrap (list/fold (function [left right] (#Alt left right)) + (wrap (list/fold (function (_ left right) (#Alt left right)) last prevs)) diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux index aeed656a8..c4ff4bfde 100644 --- a/new-luxc/source/luxc/lang/analysis/common.lux +++ b/new-luxc/source/luxc/lang/analysis/common.lux @@ -19,7 +19,8 @@ knownT (&.with-type-env (tc.clean varT))] (wrap [knownT analysis]))) -(exception: #export Variant-Tag-Out-Of-Bounds) +(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))) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index 8907ba665..aaa64940b 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -22,14 +22,19 @@ [".A" reference] [".A" structure])) -(exception: #export Macro-Expression-Must-Have-Single-Expansion) -(exception: #export Unrecognized-Syntax) -(exception: #export Macro-Expansion-Failed) +(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] + (function (analyse code) (do macro.Monad<Meta> [expectedT macro.expected-type] (let [[cursor code'] code] @@ -96,7 +101,7 @@ (#.Some macro) (do @ [expansion (: (Meta (List Code)) - (function [compiler] + (function (_ compiler) (case (macroL.expand macro args compiler) (#e.Error error) ((&.throw Macro-Expansion-Failed error) compiler) diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index a502a9d19..eaddfa5bb 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -17,9 +17,14 @@ ["&." inference]) [".L" variable #+ Variable]))) -(exception: #export Cannot-Analyse-Function) -(exception: #export Invalid-Function-Type) -(exception: #export Cannot-Apply-Function) +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Cannot-Analyse-Function] + [Invalid-Function-Type] + [Cannot-Apply-Function] + ) ## [Analysers] (def: #export (analyse-function analyse func-name arg-name body) @@ -28,10 +33,12 @@ [functionT macro.expected-type] (loop [expectedT functionT] (&.with-stacked-errors - (function [_] (Cannot-Analyse-Function (format " Type: " (%type expectedT) "\n" - "Function: " func-name "\n" - "Argument: " arg-name "\n" - " Body: " (%code body)))) + (function (_ _) + (ex.construct Cannot-Analyse-Function + (format " Type: " (%type expectedT) "\n" + "Function: " func-name "\n" + "Argument: " arg-name "\n" + " Body: " (%code body)))) (case expectedT (#.Named name unnamedT) (recur unnamedT) @@ -73,7 +80,7 @@ )) (#.Function inputT outputT) - (<| (:: @ map (function [[scope bodyA]] + (<| (:: @ map (function (_ [scope bodyA]) (` ("lux function" [(~+ (list/map code.int (variableL.environment scope)))] (~ bodyA))))) &.with-scope @@ -91,13 +98,14 @@ (def: #export (analyse-apply analyse funcT funcA args) (-> &.Analyser Type Analysis (List Code) (Meta Analysis)) (&.with-stacked-errors - (function [_] - (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" - "Arguments:" (|> args - list.enumerate - (list/map (function [[idx argC]] - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with ""))))) + (function (_ _) + (ex.construct Cannot-Apply-Function + (format " Function: " (%type funcT) "\n" + "Arguments:" (|> args + list.enumerate + (list/map (function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))))) (do macro.Monad<Meta> [[applyT argsA] (&inference.general analyse funcT args)] (wrap (la.apply argsA funcA))))) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index 3919ff78d..9bc668050 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -13,23 +13,28 @@ (lang ["la" analysis #+ Analysis] (analysis ["&." common])))) -(exception: #export Cannot-Infer) +(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] + ) + (def: (cannot-infer type args) (-> Type (List Code) Text) (format " Type: " (%type type) "\n" "Arguments:" (|> args list.enumerate - (list/map (function [[idx argC]] + (list/map (function (_ [idx argC]) (format "\n " (%n idx) " " (%code argC)))) (text.join-with "")))) -(exception: #export Cannot-Infer-Argument) -(exception: #export Smaller-Variant-Than-Expected) -(exception: #export Invalid-Type-Application) -(exception: #export Not-A-Record-Type) -(exception: #export Not-A-Variant-Type) - (def: (replace-bound bound-idx replacementT type) (-> Nat Type Type Type) (case type @@ -131,9 +136,10 @@ (do macro.Monad<Meta> [[outputT' args'A] (general analyse outputT args') argA (&.with-stacked-errors - (function [_] (Cannot-Infer-Argument - (format "Inferred Type: " (%type inputT) "\n" - " Argument: " (%code argC)))) + (function (_ _) + (ex.construct Cannot-Infer-Argument + (format "Inferred Type: " (%type inputT) "\n" + " Argument: " (%code argC)))) (&.with-type inputT (analyse argC)))] (wrap [outputT' (list& argA args'A)])) diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index 403fe4730..c5be94df6 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -21,27 +21,34 @@ [".A" primitive] ["&." inference])))) -(exception: #export Invalid-Variant-Type) -(exception: #export Invalid-Tuple-Type) -(exception: #export Not-Quantified-Type) +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] -(exception: #export Cannot-Analyse-Variant) -(exception: #export Cannot-Analyse-Tuple) + [Invalid-Variant-Type] + [Invalid-Tuple-Type] + [Not-Quantified-Type] -(exception: #export Cannot-Infer-Numeric-Tag) -(exception: #export Record-Keys-Must-Be-Tags) -(exception: #export Cannot-Repeat-Tag) -(exception: #export Tag-Does-Not-Belong-To-Record) -(exception: #export Record-Size-Mismatch) + [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 [_] (Cannot-Analyse-Variant (format " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Expression: " (%code valueC)))) + (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) @@ -74,9 +81,10 @@ ## 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))) + (&.throw Cannot-Infer-Numeric-Tag + (format " Type: " (%type expectedT) "\n" + " Tag: " (%n tag) "\n" + "Expression: " (%code valueC))) )) (^template [<tag> <instancer>] @@ -169,8 +177,10 @@ (do macro.Monad<Meta> [expectedT macro.expected-type] (&.with-stacked-errors - (function [_] (Cannot-Analyse-Tuple (format " Type: " (%type expectedT) "\n" - "Expression: " (%code (` [(~+ membersC)]))))) + (function (_ _) + (ex.construct Cannot-Analyse-Tuple + (format " Type: " (%type expectedT) "\n" + "Expression: " (%code (` [(~+ membersC)]))))) (case expectedT (#.Product _) (analyse-typed-product analyse membersC) @@ -218,8 +228,9 @@ (analyse-product analyse membersC)) _ - (&.throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Expression: " (%code (` [(~+ membersC)])))))) + (&.throw Invalid-Tuple-Type + (format " Type: " (%type expectedT) "\n" + "Expression: " (%code (` [(~+ membersC)])))))) _ (case (type.apply (list inputT) funT) @@ -231,8 +242,9 @@ (analyse-product analyse membersC)))) _ - (&.throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Expression: " (%code (` [(~+ membersC)])))) + (&.throw Invalid-Tuple-Type + (format " Type: " (%type expectedT) "\n" + "Expression: " (%code (` [(~+ membersC)])))) )))) (def: #export (analyse-tagged-sum analyse tag valueC) @@ -260,7 +272,7 @@ (def: #export (normalize record) (-> (List [Code Code]) (Meta (List [Ident Code]))) (monad.map macro.Monad<Meta> - (function [[key val]] + (function (_ [key val]) (case key [_ (#.Tag key)] (do macro.Monad<Meta> @@ -268,8 +280,9 @@ (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 @@ -295,13 +308,13 @@ " Actual: " (|> size-record nat-to-int %i) "\n" " Type: " (%type recordT) "\n" "Expression: " (%code (|> record - (list/map (function [[keyI valueC]] + (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] + (function (_ [key val] idx->val) (do @ [key (macro.normalize key)] (case (dict.get key tag->idx) @@ -314,14 +327,14 @@ (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]] + "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))) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) )) |