aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/analysis
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/case.lux23
-rw-r--r--new-luxc/source/luxc/lang/analysis/case/coverage.lux13
-rw-r--r--new-luxc/source/luxc/lang/analysis/common.lux3
-rw-r--r--new-luxc/source/luxc/lang/analysis/expression.lux15
-rw-r--r--new-luxc/source/luxc/lang/analysis/function.lux38
-rw-r--r--new-luxc/source/luxc/lang/analysis/inference.lux28
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux71
8 files changed, 116 insertions, 77 deletions
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
index e33f51927..369e9dd7e 100644
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ b/new-luxc/source/luxc/lang/analysis.lux
@@ -68,7 +68,7 @@
(def: #export (apply args func)
(-> (List Analysis) Analysis Analysis)
- (list/fold (function [arg func]
+ (list/fold (function (_ arg func)
(` ("lux apply" (~ arg) (~ func))))
func
args))
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]))
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 04:02:50 +0000