- Added tests for type-checking and type-coercion.

- Implemented "eval".
- Fixed bugs when analysing variants and tuples.

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]