aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser.lux32
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux33
-rw-r--r--new-luxc/source/luxc/eval.lux17
-rw-r--r--new-luxc/test/test/luxc/analyser/common.lux5
-rw-r--r--new-luxc/test/test/luxc/analyser/type.lux89
-rw-r--r--new-luxc/test/test/luxc/generator/structure.lux10
-rw-r--r--new-luxc/test/tests.lux1
7 files changed, 162 insertions, 25 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 3272057f2..f17ec8496 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -76,16 +76,12 @@
body)))
(&&function;analyse-function analyse func-name arg-name body)
- (^ (#;Form (list [_ (#;Symbol ["" "_lux_check"])]
- type
- value)))
- (&&type;analyse-check analyse eval type value)
-
- (^ (#;Form (list [_ (#;Symbol ["" "_lux_coerce"])]
- type
- value)))
- (&&type;analyse-coerce analyse eval type value)
-
+ (^template [<proc> <analyser>]
+ (^ (#;Form (list [_ (#;Symbol ["" <proc>])] type value)))
+ (<analyser> analyse eval type value))
+ (["_lux_check" &&type;analyse-check]
+ ["_lux_coerce" &&type;analyse-coerce])
+
(^ (#;Form (list& [_ (#;Text proc-name)] proc-args)))
(&&procedure;analyse-procedure analyse proc-name proc-args)
@@ -96,13 +92,17 @@
[paired (to-branches branches)]
(&&case;analyse-case analyse input paired))
- (^ (#;Form (list [_ (#;Nat tag)]
- value)))
- (&&structure;analyse-sum analyse tag value)
+ (^template [<tag> <analyser>]
+ (^ (#;Form (list& [_ (<tag> tag)]
+ values)))
+ (case values
+ (#;Cons value #;Nil)
+ (<analyser> analyse tag value)
- (^ (#;Form (list [_ (#;Tag tag)]
- value)))
- (&&structure;analyse-tagged-sum analyse tag value)
+ _
+ (<analyser> analyse tag (` [(~@ values)]))))
+ ([#;Nat &&structure;analyse-sum]
+ [#;Tag &&structure;analyse-tagged-sum])
(^ (#;Form (list& func args)))
(do Monad<Lux>
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index e13d1d88a..9a42db0fa 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -24,12 +24,23 @@
(analyser ["&;" common]
["&;" inference])))
+(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)))
+
(def: #export (analyse-sum analyse tag valueC)
(-> &;Analyser Nat Code (Lux la;Analysis))
(do Monad<Lux>
[expected macro;expected-type]
(&;with-stacked-errors
- (function [_] (format "Invalid type for variant: " (%type expected)))
+ (function [_] (not-variant expected))
(case expected
(#;Sum _)
(let [flat (type;flatten-variant expected)
@@ -62,7 +73,7 @@
## 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 (format "Invalid type for variant: " (%type expected)))))
+ (&;fail (not-variant expected))))
(#;UnivQ _)
(do @
@@ -76,6 +87,15 @@
(function [[var-id var]]
(&;with-expected-type (assume (type;apply (list var) expected))
(analyse-sum analyse tag valueC))))
+
+ (#;Apply inputT funT)
+ (case (type;apply (list inputT) funT)
+ #;None
+ (&;fail (not-quantified funT))
+
+ (#;Some outputT)
+ (&;with-expected-type outputT
+ (analyse-sum analyse tag valueC)))
_
(&;fail "")))))
@@ -173,6 +193,15 @@
(function [[var-id var]]
(&;with-expected-type (assume (type;apply (list var) expected))
(analyse-product analyse membersC))))
+
+ (#;Apply inputT funT)
+ (case (type;apply (list inputT) funT)
+ #;None
+ (&;fail (not-quantified funT))
+
+ (#;Some outputT)
+ (&;with-expected-type outputT
+ (analyse-product analyse membersC)))
_
(&;fail "")
diff --git a/new-luxc/source/luxc/eval.lux b/new-luxc/source/luxc/eval.lux
new file mode 100644
index 000000000..266becee6
--- /dev/null
+++ b/new-luxc/source/luxc/eval.lux
@@ -0,0 +1,17 @@
+(;module:
+ lux
+ (lux (control [monad #+ do])
+ [macro])
+ [../base]
+ (.. [analyser]
+ [synthesizer]
+ (generator [expr]
+ [eval])))
+
+(def: #export (eval type exprC)
+ ../base;Eval
+ (do macro;Monad<Lux>
+ [exprA (../base;with-expected-type type
+ (analyser;analyser eval exprC))
+ #let [exprS (synthesizer;synthesize exprA)]]
+ (eval;eval (expr;generate exprS))))
diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux
index 6d701e823..60f3eef50 100644
--- a/new-luxc/test/test/luxc/analyser/common.lux
+++ b/new-luxc/test/test/luxc/analyser/common.lux
@@ -6,7 +6,8 @@
[macro]
(macro [code]))
(luxc ["&" base]
- [analyser])
+ [analyser]
+ [eval])
(test/luxc common))
(def: gen-unit
@@ -33,7 +34,7 @@
(def: #export analyse
&;Analyser
- (analyser;analyser (:!! [])))
+ (analyser;analyser eval;eval))
(do-template [<name> <on-success> <on-failure>]
[(def: #export (<name> analysis)
diff --git a/new-luxc/test/test/luxc/analyser/type.lux b/new-luxc/test/test/luxc/analyser/type.lux
new file mode 100644
index 000000000..b23b16d6a
--- /dev/null
+++ b/new-luxc/test/test/luxc/analyser/type.lux
@@ -0,0 +1,89 @@
+(;module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data [bool "bool/" Eq<Bool>]
+ [text "text/" Eq<Text>]
+ (text format
+ ["l" lexer])
+ [number]
+ ["R" result]
+ [product]
+ (coll [list "list/" Functor<List> Fold<List>]))
+ ["r" math/random "r/" Monad<Random>]
+ [type "type/" Eq<Type>]
+ [macro #+ Monad<Lux>]
+ (macro [code])
+ test)
+ (luxc ["&" base]
+ ["&;" module]
+ (lang ["~" analysis])
+ [analyser]
+ (analyser ["@" type]
+ ["@;" common])
+ (generator ["@;" runtime])
+ [eval])
+ (.. common)
+ (test/luxc common))
+
+(def: check
+ (r;Random [Code Type Code])
+ (with-expansions [<triples> (do-template [<random> <type> <code>]
+ [(do r;Monad<Random>
+ [value <random>]
+ (wrap [(` <type>)
+ <type>
+ (<code> value)]))]
+
+ [r;bool (+0 "#Bool" (+0)) code;bool]
+ [r;nat (+0 "#Nat" (+0)) code;nat]
+ [r;int (+0 "#Int" (+0)) code;int]
+ [r;deg (+0 "#Deg" (+0)) code;deg]
+ [r;frac (+0 "#Frac" (+0)) code;frac]
+ [(r;text +5) (+0 "#Text" (+0)) code;text]
+ )]
+ ($_ r;either
+ <triples>)))
+
+(context: "Type checking/coercion."
+ [[typeC codeT exprC] check]
+ ($_ seq
+ (test (format "Can analyse type-checking.")
+ (|> (do Monad<Lux>
+ [runtime-bytecode @runtime;generate]
+ (&;with-scope
+ (@common;with-unknown-type
+ (@;analyse-check analyse eval;eval typeC exprC))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success [_ [analysisT analysisA]])
+ (and (type/= codeT analysisT)
+ (case [exprC analysisA]
+ (^template [<expected> <actual> <test>]
+ [[_ (<expected> expected)] (<actual> actual)]
+ (<test> expected actual))
+ ([#;Bool #~;Bool bool/=]
+ [#;Nat #~;Nat n.=]
+ [#;Int #~;Int i.=]
+ [#;Deg #~;Deg d.=]
+ [#;Frac #~;Frac f.=]
+ [#;Text #~;Text text/=])
+
+ _
+ false))
+
+ (#R;Error error)
+ false)))
+ (test (format "Can analyse type-coercion.")
+ (|> (do Monad<Lux>
+ [runtime-bytecode @runtime;generate]
+ (&;with-scope
+ (@common;with-unknown-type
+ (@;analyse-coerce analyse eval;eval typeC exprC))))
+ (macro;run (init-compiler []))
+ (case> (#R;Success [_ [analysisT analysisA]])
+ (type/= codeT analysisT)
+
+ (#R;Error error)
+ false)))
+ ))
diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux
index 4652c4bd9..ab0c17ade 100644
--- a/new-luxc/test/test/luxc/generator/structure.lux
+++ b/new-luxc/test/test/luxc/generator/structure.lux
@@ -5,8 +5,8 @@
pipe)
(data text/format
["R" result]
- [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
+ [bool "bool/" Eq<Bool>]
+ [text "text/" Eq<Text>]
(coll ["a" array]
[list]))
["r" math/random "r/" Monad<Random>]
@@ -48,12 +48,12 @@
(#R;Error error)
false))
- ([#ls;Bool Bool B/=]
+ ([#ls;Bool Bool bool/=]
[#ls;Nat Nat n.=]
[#ls;Int Int i.=]
[#ls;Deg Deg d.=]
[#ls;Frac Frac f.=]
- [#ls;Text Text T/=])
+ [#ls;Text Text text/=])
_
false
@@ -92,7 +92,7 @@
(and (n.= tag (|> _tag host;i2l int-to-nat))
(case _last?
(#;Some _last?')
- (and last? (T/= "" (:! Text _last?')))
+ (and last? (text/= "" (:! Text _last?')))
#;None
(not last?))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 30fab3878..28ccefc42 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -11,6 +11,7 @@
["_;A" reference]
["_;A" case]
["_;A" function]
+ ["_;A" type]
(procedure ["_;A" common]))
(synthesizer ["_;S" primitive]
["_;S" structure]
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-30 23:15:15 +0000