aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser.lux253
-rw-r--r--new-luxc/source/luxc/analyser/case.lux32
-rw-r--r--new-luxc/source/luxc/analyser/function.lux13
-rw-r--r--new-luxc/source/luxc/analyser/inference.lux158
-rw-r--r--new-luxc/source/luxc/analyser/reference.lux22
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux71
6 files changed, 334 insertions, 215 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index b10f29369..f0712794d 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -1,14 +1,19 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(data ["e" error]
+ [product]
text/format)
[meta]
(meta [type]
- (type ["tc" check])))
+ (type ["tc" check]))
+ [host #+ do-to])
(luxc ["&" base]
+ [";L" host]
(lang ["la" analysis])
- ["&;" module])
+ ["&;" module]
+ (generator [";G" common]))
(. ["&&;" common]
["&&;" function]
["&&;" primitive]
@@ -18,6 +23,37 @@
["&&;" case]
["&&;" procedure]))
+(for {"JVM" (as-is (host;import java.lang.reflect.Method
+ (invoke [Object (Array Object)] #try Object))
+ (host;import (java.lang.Class c)
+ (getMethod [String (Array (Class Object))] #try Method))
+ (host;import java.lang.Object
+ (getClass [] (Class Object))
+ (toString [] String))
+ (def: _object-class (Class Object) (host;class-for Object))
+ (def: _apply-args
+ (Array (Class Object))
+ (|> (host;array (Class Object) +2)
+ (host;array-write +0 _object-class)
+ (host;array-write +1 _object-class)))
+ (def: (call-macro macro inputs)
+ (-> Macro (List Code) (Meta (List Code)))
+ (do meta;Monad<Meta>
+ [class (commonG;load-class hostL;function-class)]
+ (function [compiler]
+ (do e;Monad<Error>
+ [apply-method (Class.getMethod ["apply" _apply-args] class)
+ output (Method.invoke [(:! Object macro)
+ (|> (host;array Object +2)
+ (host;array-write +0 (:! Object inputs))
+ (host;array-write +1 (:! Object compiler)))]
+ apply-method)]
+ (:! (e;Error [Compiler (List Code)])
+ output))))))
+ })
+
+(exception: #export Macro-Expression-Must-Have-Single-Expansion)
+
(def: (to-branches raw)
(-> (List Code) (Meta (List [Code Code])))
(case raw
@@ -36,104 +72,113 @@
(-> &;Eval &;Analyser)
(: (-> Code (Meta la;Analysis))
(function analyse [ast]
- (let [[cursor ast'] ast]
- ## The cursor must be set in the compiler for the sake
- ## of having useful error messages.
- (&;with-cursor cursor
- (case ast'
- (^template [<tag> <analyser>]
- (<tag> value)
- (<analyser> value))
- ([#;Bool &&primitive;analyse-bool]
- [#;Nat &&primitive;analyse-nat]
- [#;Int &&primitive;analyse-int]
- [#;Deg &&primitive;analyse-deg]
- [#;Frac &&primitive;analyse-frac]
- [#;Text &&primitive;analyse-text])
-
- (^ (#;Tuple (list)))
- &&primitive;analyse-unit
-
- ## Singleton tuples are equivalent to the element they contain.
- (^ (#;Tuple (list singleton)))
- (analyse singleton)
-
- (^ (#;Tuple elems))
- (&&structure;analyse-product analyse elems)
-
- (^ (#;Record pairs))
- (&&structure;analyse-record analyse pairs)
-
- (#;Symbol reference)
- (&&reference;analyse-reference reference)
-
- (^ (#;Form (list [_ (#;Text "lux function")]
- [_ (#;Symbol ["" func-name])]
- [_ (#;Symbol ["" arg-name])]
- body)))
- (&&function;analyse-function analyse func-name arg-name body)
-
- (^template [<special> <analyser>]
- (^ (#;Form (list [_ (#;Text <special>)] type value)))
- (<analyser> analyse eval type value))
- (["lux check" &&type;analyse-check]
- ["lux coerce" &&type;analyse-coerce])
-
- (^ (#;Form (list& [_ (#;Text "lux case")]
- input
- branches)))
- (do meta;Monad<Meta>
- [paired (to-branches branches)]
- (&&case;analyse-case analyse input paired))
-
- (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
- (&&procedure;analyse-procedure analyse proc-name proc-args)
-
- (^template [<tag> <analyser>]
- (^ (#;Form (list& [_ (<tag> tag)]
- values)))
- (case values
- (#;Cons value #;Nil)
- (<analyser> analyse tag value)
-
- _
- (<analyser> analyse tag (` [(~@ values)]))))
- ([#;Nat &&structure;analyse-sum]
- [#;Tag &&structure;analyse-tagged-sum])
-
- (#;Tag tag)
- (&&structure;analyse-tagged-sum analyse tag (' []))
-
- (^ (#;Form (list& func args)))
- (do meta;Monad<Meta>
- [[funcT =func] (&&common;with-unknown-type
- (analyse func))]
- (case =func
- (#la;Definition def-name)
- (do @
- [[def-type def-anns def-value] (meta;find-def def-name)]
- (if (meta;macro? def-anns)
- (do @
- [## macro-expansion (function [compiler]
- ## (case (macro-caller def-value args compiler)
- ## (#e;Success [compiler' output])
- ## (#e;Success [compiler' output])
-
- ## (#e;Error error)
- ## ((&;fail error) compiler)))
- macro-expansion (: (Meta (List Code))
- (undefined))]
- (case macro-expansion
- (^ (list single-expansion))
- (analyse single-expansion)
-
- _
- (&;fail (format "Macro expressions must expand to a single expression: " (%code ast)))))
- (&&function;analyse-apply analyse funcT =func args)))
-
- _
- (&&function;analyse-apply analyse funcT =func args)))
-
- _
- (&;fail (format "Unrecognized syntax: " (%code ast)))
- ))))))
+ (do meta;Monad<Meta>
+ [expectedT meta;expected-type]
+ (let [[cursor ast'] ast]
+ ## The cursor must be set in the compiler for the sake
+ ## of having useful error messages.
+ (&;with-cursor cursor
+ (case ast'
+ (^template [<tag> <analyser>]
+ (<tag> value)
+ (<analyser> value))
+ ([#;Bool &&primitive;analyse-bool]
+ [#;Nat &&primitive;analyse-nat]
+ [#;Int &&primitive;analyse-int]
+ [#;Deg &&primitive;analyse-deg]
+ [#;Frac &&primitive;analyse-frac]
+ [#;Text &&primitive;analyse-text])
+
+ (^ (#;Tuple (list)))
+ &&primitive;analyse-unit
+
+ ## Singleton tuples are equivalent to the element they contain.
+ (^ (#;Tuple (list singleton)))
+ (analyse singleton)
+
+ (^ (#;Tuple elems))
+ (&&structure;analyse-product analyse elems)
+
+ (^ (#;Record pairs))
+ (&&structure;analyse-record analyse pairs)
+
+ (#;Symbol reference)
+ (&&reference;analyse-reference reference)
+
+ (^ (#;Form (list [_ (#;Text "lux function")]
+ [_ (#;Symbol ["" func-name])]
+ [_ (#;Symbol ["" arg-name])]
+ body)))
+ (&&function;analyse-function analyse func-name arg-name body)
+
+ (^template [<special> <analyser>]
+ (^ (#;Form (list [_ (#;Text <special>)] type value)))
+ (<analyser> analyse eval type value))
+ (["lux check" &&type;analyse-check]
+ ["lux coerce" &&type;analyse-coerce])
+
+ (^ (#;Form (list [_ (#;Text "lux check type")] valueC)))
+ (do meta;Monad<Meta>
+ [valueA (&;with-expected-type Type
+ (analyse valueC))
+ expected meta;expected-type
+ _ (&;with-type-env
+ (tc;check expected Type))]
+ (wrap valueA))
+
+ (^ (#;Form (list& [_ (#;Text "lux case")]
+ input
+ branches)))
+ (do meta;Monad<Meta>
+ [paired (to-branches branches)]
+ (&&case;analyse-case analyse input paired))
+
+ (^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
+ (&&procedure;analyse-procedure analyse proc-name proc-args)
+
+ (^template [<tag> <analyser>]
+ (^ (#;Form (list& [_ (<tag> tag)]
+ values)))
+ (case values
+ (#;Cons value #;Nil)
+ (<analyser> analyse tag value)
+
+ _
+ (<analyser> analyse tag (` [(~@ values)]))))
+ ([#;Nat &&structure;analyse-sum]
+ [#;Tag &&structure;analyse-tagged-sum])
+
+ (#;Tag tag)
+ (&&structure;analyse-tagged-sum analyse tag (' []))
+
+ (^ (#;Form (list& func args)))
+ (do meta;Monad<Meta>
+ [[funcT =func] (&&common;with-unknown-type
+ (analyse func))]
+ (case =func
+ (#la;Definition def-name)
+ (do @
+ [[def-type def-anns def-value] (meta;find-def def-name)]
+ (if (meta;macro? def-anns)
+ (do @
+ [expansion (function [compiler]
+ (case (call-macro (:! Macro def-value) args compiler)
+ (#e;Success [compiler' output])
+ (#e;Success [compiler' output])
+
+ (#e;Error error)
+ ((&;fail error) compiler)))]
+ (case expansion
+ (^ (list single))
+ (analyse single)
+
+ _
+ (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
+ (&&function;analyse-apply analyse funcT =func args)))
+
+ _
+ (&&function;analyse-apply analyse funcT =func args)))
+
+ _
+ (&;fail (format "Unrecognized syntax: " (%code ast)))
+ )))))))
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))]
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-13 02:11:36 +0000