- Fixed some bugs.

- Improved error reporting.
- Optimized pattern-matching a bit.

7 files changed, 151 insertions, 133 deletions

diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index 627fb7c0a..5a6df4d3e 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -102,10 +102,14 @@
   (&;with-stacked-errors
     (function [_]
       (Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
-                                     "Arguments: " (|> args (list/map %code) (text;join-with " ")))))
+                                     "Arguments:" (|> args
+                                                      list;enumerate
+                                                      (list/map (function [[idx argC]]
+                                                                  (format "\n  " (%n idx) " " (%code argC))))
+                                                      (text;join-with "")))))
     (do meta;Monad<Meta>
-      [expected meta;expected-type
+      [expectedT meta;expected-type
        [applyT argsA] (&inference;apply-function analyse funcT args)
        _ (&;with-type-env
-           (tc;check expected applyT))]
+           (tc;check expectedT applyT))]
       (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 cd484a623..fea685024 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -16,6 +16,9 @@
 (exception: #export Cannot-Infer)
 (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)
 
 ## When doing inference, type-variables often need to be created in
 ## order to figure out which types are present in the expression being
@@ -90,16 +93,16 @@
 ## Function types are used for this, although inference is not always
 ## done for function application (alternative uses may be records and
 ## tagged variants).
-## But, so long as the type being used for the inference can be trated
+## But, so long as the type being used for the inference can be treated
 ## as a function type, this method of inference should work.
-(def: #export (apply-function analyse funcT args)
+(def: #export (apply-function analyse inferT args)
   (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)]))
   (case args
     #;Nil
-    (:: Monad<Meta> wrap [funcT (list)])
+    (:: Monad<Meta> wrap [inferT (list)])
     
     (#;Cons argC args')
-    (case funcT
+    (case inferT
       (#;Named name unnamedT)
       (apply-function analyse unnamedT args)
 
@@ -107,7 +110,7 @@
       (&common;with-var
         (function [[var-id varT]]
           (do Monad<Meta>
-            [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) funcT)) args)]
+            [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)]
             (do @
               [? (&;with-type-env
                    (tc;bound? var-id))
@@ -123,7 +126,15 @@
       (do Monad<Meta>
         [[ex-id exT] (&;with-type-env
                        tc;existential)]
-        (apply-function analyse (maybe;assume (type;apply (list exT) funcT)) args))
+        (apply-function analyse (maybe;assume (type;apply (list exT) inferT)) args))
+
+      (#;Apply inputT transT)
+      (case (type;apply (list inputT) transT)
+        (#;Some outputT)
+        (apply-function analyse outputT args)
+
+        #;None
+        (&;throw Invalid-Type-Application (%type inferT)))
 
       ## Arguments are inferred back-to-front because, by convention,
       ## Lux functions take the most important arguments *last*, which
@@ -134,18 +145,23 @@
       ## things together more easily.
       (#;Function inputT outputT)
       (do Monad<Meta>
-        [[outputT' args'A] (apply-function analyse outputT args')
-         argA (&;with-stacked-errors
+        [argA (&;with-stacked-errors
                 (function [_] (Cannot-Infer-Argument
                                (format "Inferred Type: " (%type inputT) "\n"
                                        "     Argument: " (%code argC))))
                 (&;with-expected-type inputT
-                  (analyse argC)))]
+                  (analyse argC)))
+         [outputT' args'A] (apply-function analyse outputT args')]
         (wrap [outputT' (list& argA args'A)]))
 
       _
-      (&;throw Cannot-Infer (format "Inference Type: " (%type funcT)
-                                    "     Arguments: " (|> args (list/map %code) (text;join-with " ")))))
+      (&;throw Cannot-Infer (format "     Type: " (%type inferT) "\n"
+                                    "Arguments:"
+                                    (|> args
+                                        list;enumerate
+                                        (list/map (function [[idx argC]]
+                                                    (format "\n  " (%n idx) " " (%code argC))))
+                                        (text;join-with "")))))
     ))
 
 ## Turns a record type into the kind of function type suitable for inference.
@@ -153,9 +169,7 @@
   (-> Type (Meta Type))
   (case type
     (#;Named name unnamedT)
-    (do Monad<Meta>
-      [unnamedT+ (record unnamedT)]
-      (wrap unnamedT+))
+    (record unnamedT)
 
     (^template [<tag>]
       (<tag> env bodyT)
@@ -169,7 +183,7 @@
     (:: Monad<Meta> wrap (type;function (type;flatten-tuple type) type))
 
     _
-    (&;fail (format "Not a record type: " (%type type)))))
+    (&;throw Not-A-Record-Type (%type type))))
 
 ## Turns a variant type into the kind of function type suitable for inference.
 (def: #export (variant tag expected-size type)
@@ -225,4 +239,4 @@
               (&common;variant-out-of-bounds-error type expected-size tag)))
 
       _
-      (&;fail (format "Not a variant type: " (%type type))))))
+      (&;throw Not-A-Variant-Type (%type type)))))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 0284245e1..5cac1a0d3 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -40,9 +40,9 @@
   (do meta;Monad<Meta>
     [expectedT meta;expected-type]
     (&;with-stacked-errors
-      (function [_] (Not-Variant-Type (format "  Tag: " (%n tag) "\n"
+      (function [_] (Not-Variant-Type (format " Type: " (%type expectedT) "\n"
                                               "Value: " (%code  valueC) "\n"
-                                              " Type: " (%type expectedT))))
+                                              "  Tag: " (%n tag))))
       (case expectedT
         (#;Sum _)
         (let [flat (type;flatten-variant expectedT)
@@ -102,9 +102,9 @@
             (analyse-sum analyse tag valueC)))
         
         _
-        (&;throw Not-Variant-Type (format "  Tag: " (%n tag) "\n"
-                                          "Value: " (%code  valueC) "\n"
-                                          " Type: " (%type expectedT)))))))
+        (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
+                                          "  Tag: " (%n tag) "\n"
+                                          "Value: " (%code  valueC)))))))
 
 (def: (analyse-typed-product analyse members)
   (-> &;Analyser (List Code) (Meta la;Analysis))
@@ -302,10 +302,16 @@
   (-> &;Analyser (List [Code Code]) (Meta la;Analysis))
   (do meta;Monad<Meta>
     [members (normalize members)
-     [members recordT] (order members)
-     expectedT meta;expected-type
-     inferenceT (&inference;record recordT)
-     [inferredT membersA] (&inference;apply-function analyse inferenceT members)
-     _ (&;with-type-env
-         (tc;check expectedT inferredT))]
-    (wrap (la;product membersA))))
+     [membersC recordT] (order members)
+     expectedT meta;expected-type]
+    (case expectedT
+      (#;Var _)
+      (do @
+        [inferenceT (&inference;record recordT)
+         [inferredT membersA] (&inference;apply-function analyse inferenceT membersC)
+         _ (&;with-type-env
+             (tc;check expectedT inferredT))]
+        (wrap (la;product membersA)))
+
+      _
+      (analyse-product analyse membersC))))
diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux
index d0b038d93..74bb712f4 100644
--- a/new-luxc/source/luxc/lang/analysis/type.lux
+++ b/new-luxc/source/luxc/lang/analysis/type.lux
@@ -12,20 +12,20 @@
 (def: #export (analyse-check analyse eval type value)
   (-> &;Analyser &;Eval Code Code (Meta Analysis))
   (do Monad<Meta>
-    [actual (eval Type type)
-     #let [actual (:! Type actual)]
-     expected meta;expected-type
+    [actualT (eval Type type)
+     #let [actualT (:! Type actualT)]
+     expectedT meta;expected-type
      _ (&;with-type-env
-         (TC;check expected actual))]
-    (&;with-expected-type actual
+         (TC;check expectedT actualT))]
+    (&;with-expected-type actualT
       (analyse value))))
 
 (def: #export (analyse-coerce analyse eval type value)
   (-> &;Analyser &;Eval Code Code (Meta Analysis))
   (do Monad<Meta>
-    [actual (eval Type type)
-     expected meta;expected-type
+    [actualT (eval Type type)
+     expectedT meta;expected-type
      _ (&;with-type-env
-         (TC;check expected (:! Type actual)))]
+         (TC;check expectedT (:! Type actualT)))]
     (&;with-expected-type Top
       (analyse value))))
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux
index e230e2799..2fd6e19bb 100644
--- a/new-luxc/source/luxc/lang/synthesis/case.lux
+++ b/new-luxc/source/luxc/lang/synthesis/case.lux
@@ -4,73 +4,77 @@
              [text "text/" Eq<Text>]
              text/format
              [number]
-             (coll [list "list/" Fold<List>]))
+             (coll [list "list/" Fold<List> Monoid<List>]))
        (meta [code "code/" Eq<Code>]))
   (luxc (lang [";L" variable #+ Variable]
               ["la" analysis]
               ["ls" synthesis]
               (synthesis [";S" function]))))
 
-(def: #export (path outer-arity pattern)
-  (-> ls;Arity la;Pattern ls;Path)
+(def: popPS ls;Path (' ("lux case pop")))
+
+(def: (path' outer-arity pattern)
+  (-> ls;Arity la;Pattern (List ls;Path))
   (case pattern
     (^code ("lux case tuple" [(~@ membersP)]))
-    (case (list;reverse membersP)
+    (case membersP
       #;Nil
-      (' ("lux case pop"))
+      (list popPS)
 
       (#;Cons singletonP #;Nil)
-      (path outer-arity singletonP)
+      (path' outer-arity singletonP)
 
-      (#;Cons lastP prevsP)
-      (let [length (list;size membersP)
-            last-idx (n.dec length)
-            [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]]
+      (#;Cons _)
+      (let [last-idx (n.dec (list;size membersP))
+            [_ tuple-path] (list/fold (function [current-pattern [current-idx next]]
                                         [(n.dec current-idx)
-                                         (` ("lux case seq"
-                                             ("lux case tuple left" (~ (code;nat current-idx)) (~ (path outer-arity current-pattern)))
-                                             (~ next-path)))])
-                                      [(n.dec last-idx)
-                                       (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path outer-arity lastP))))]
-                                      prevsP)]
-        (` ("lux case seq"
-            (~ tuple-path)
-            ("lux case pop")))))
+                                         (|> (list (if (n.= last-idx current-idx)
+                                                     (` ("lux case tuple right" (~ (code;nat current-idx))))
+                                                     (` ("lux case tuple left" (~ (code;nat current-idx))))))
+                                             (list/compose (path' outer-arity current-pattern))
+                                             (list/compose next))])
+                                      [last-idx (list popPS)]
+                                      (list;reverse membersP))]
+        tuple-path))
 
     (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
-    (` ("lux case seq"
-        (~ (if (n.= (n.dec num-tags) tag)
-             (` ("lux case variant right" (~ (code;nat tag)) (~ (path outer-arity memberP))))
-             (` ("lux case variant left" (~ (code;nat tag)) (~ (path outer-arity memberP))))))
-        ("lux case pop")))
+    (|> (list (if (n.= (n.dec num-tags) tag)
+                (` ("lux case variant right" (~ (code;nat tag))))
+                (` ("lux case variant left" (~ (code;nat tag))))))
+        (list/compose (path' outer-arity memberP))
+        (list& popPS))
 
     (^code ("lux case bind" (~ [_ (#;Nat register)])))
-    (` ("lux case seq"
-        ("lux case bind" (~ (if (functionS;nested? outer-arity)
-                              (code;nat (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register))
-                              (code;nat register))))
-        ("lux case pop")))
+    (list popPS
+          (` ("lux case bind" (~ (code;nat (if (functionS;nested? outer-arity)
+                                             (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register)
+                                             register))))))
 
     _
-    (` ("lux case seq"
-        (~ pattern)
-        ("lux case pop")))))
+    (list popPS pattern)))
+
+(def: (clean-unnecessary-pops paths)
+  (-> (List ls;Path) (List ls;Path))
+  (case paths
+    (#;Cons path paths')
+    (if (is popPS path)
+      (clean-unnecessary-pops paths')
+      paths)
+
+    #;Nil
+    paths))
+
+(def: #export (path outer-arity pattern body)
+  (-> ls;Arity la;Pattern ls;Synthesis ls;Path)
+  (|> (path' outer-arity pattern) clean-unnecessary-pops
+      (list/fold (function [pre post]
+                   (` ("lux case seq" (~ pre) (~ post))))
+                 (` ("lux case exec" (~ body))))))
 
 (def: #export (weave leftP rightP)
   (-> ls;Path ls;Path ls;Path)
   (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))]
     (case [leftP rightP]
-      (^template [<special>]
-        (^ [[_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat left-idx)] left-then))]
-            [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat right-idx)] right-then))]])
-        (if (n.= left-idx right-idx)
-          (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then))))
-          <default>))
-      (["lux case tuple left"]
-       ["lux case tuple right"]
-       ["lux case variant left"]
-       ["lux case variant right"])
-
       (^ [(^code ("lux case seq" (~ preL) (~ postL)))
           (^code ("lux case seq" (~ preR) (~ postR)))])
       (case (weave preL preR)
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux
index f761fb57c..30704a2d2 100644
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ b/new-luxc/source/luxc/lang/synthesis/expression.lux
@@ -86,10 +86,7 @@
       (#;Cons [lastP lastA] prevsPA)
       (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
                                 (function [pattern expr]
-                                  (|> (synthesize expr)
-                                      (~) ("lux case exec")
-                                      ("lux case seq" (~ (caseS;path outer-arity pattern)))
-                                      (`))))
+                                  (caseS;path outer-arity pattern (synthesize expr))))
             pathS (list/fold caseS;weave
                              (transform-branch lastP lastA)
                              (list/map (product;uncurry transform-branch) prevsPA))]
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux
index 7821db70d..cb0aa2198 100644
--- a/new-luxc/source/luxc/lang/translation/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux
@@ -108,57 +108,50 @@
                     ($i;IFEQ @else)))
 
     (^template [<special> <method>]
-      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))])
-      (do meta;Monad<Meta>
-        [subI (translate-path' translate stack-depth @else @end subP)]
-        (wrap (case idx
-                +0
-                (|>. peekI
-                     ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
-                     ($i;int 0)
-                     $i;AALOAD
-                     pushI
-                     subI)
-                
-                _
-                (|>. peekI
-                     ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
-                     ($i;int (nat-to-int idx))
-                     ($i;INVOKESTATIC hostL;runtime-class
-                                      <method>
-                                      ($t;method (list ../runtime;$Tuple $t;int)
-                                                 (#;Some $Object)
-                                                 (list))
-                                      false)
-                     pushI
-                     subI)))))
+      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))])
+      (meta/wrap (case idx
+                   +0
+                   (|>. peekI
+                        ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
+                        ($i;int 0)
+                        $i;AALOAD
+                        pushI)
+                   
+                   _
+                   (|>. peekI
+                        ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
+                        ($i;int (nat-to-int idx))
+                        ($i;INVOKESTATIC hostL;runtime-class
+                                         <method>
+                                         ($t;method (list ../runtime;$Tuple $t;int)
+                                                    (#;Some $Object)
+                                                    (list))
+                                         false)
+                        pushI))))
     (["lux case tuple left" "pm_left"]
      ["lux case tuple right" "pm_right"])
 
     (^template [<special> <flag>]
-      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))])
-      (do meta;Monad<Meta>
-        [subI (translate-path' translate stack-depth @else @end subP)]
-        (wrap (<| $i;with-label (function [@success])
-                  $i;with-label (function [@fail])
-                  (|>. peekI
-                       ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
-                       ($i;int (nat-to-int idx))
-                       <flag>
-                       ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
-                                        ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
-                                                   (#;Some ../runtime;$Datum)
-                                                   (list))
-                                        false)
-                       $i;DUP
-                       ($i;IFNULL @fail)
-                       ($i;GOTO @success)
-                       ($i;label @fail)
-                       $i;POP
-                       ($i;GOTO @else)
-                       ($i;label @success)
-                       pushI
-                       subI)))))
+      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))])
+      (meta/wrap (<| $i;with-label (function [@success])
+                     $i;with-label (function [@fail])
+                     (|>. peekI
+                          ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
+                          ($i;int (nat-to-int idx))
+                          <flag>
+                          ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
+                                           ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
+                                                      (#;Some ../runtime;$Datum)
+                                                      (list))
+                                           false)
+                          $i;DUP
+                          ($i;IFNULL @fail)
+                          ($i;GOTO @success)
+                          ($i;label @fail)
+                          $i;POP
+                          ($i;GOTO @else)
+                          ($i;label @success)
+                          pushI))))
     (["lux case variant left" $i;NULL]
      ["lux case variant right" ($i;string "")])