Fixes for pattern-matching/case synthesis & translation.

9 files changed, 173 insertions, 234 deletions

diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 9bf515bdb..e5a992052 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -827,27 +827,27 @@
  ("lux check" Macro
   ([_ tokens]
    ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))
-     (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier "" ""))
+     (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""]))
                                                              (#Cons arg #Nil))))
                                         (#Cons ({#Nil
                                                  body
 
                                                  _
-                                                 (_ann (#Form (#Cons (_ann (#Identifier "lux" "function''"))
+                                                 (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"]))
                                                                      (#Cons (_ann (#Tuple args'))
                                                                             (#Cons body #Nil)))))}
                                                 args')
                                                #Nil))))
                     #Nil))
 
-     (#Cons [_ (#Identifier "" self)] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)))
-     (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier "" self))
+     (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)))
+     (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self]))
                                                              (#Cons arg #Nil))))
                                         (#Cons ({#Nil
                                                  body
 
                                                  _
-                                                 (_ann (#Form (#Cons (_ann (#Identifier "lux" "function''"))
+                                                 (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"]))
                                                                      (#Cons (_ann (#Tuple args'))
                                                                             (#Cons body #Nil)))))}
                                                 args')
diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux
index 19ef64af2..7663f6950 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis.lux
@@ -25,9 +25,16 @@
 
 (type: #export Tag Nat)
 
+(type: #export (Variant a)
+  {#lefts Nat
+   #right? Bit
+   #value a})
+
+(type: #export (Tuple a) (List a))
+
 (type: #export (Composite a)
-  (#Sum (Either a a))
-  (#Product [a a]))
+  (#Variant (Variant a))
+  (#Tuple (Tuple a)))
 
 (type: #export #rec Pattern
   (#Simple Primitive)
@@ -90,13 +97,6 @@
   [text Text #Text]
   )
 
-(type: #export (Variant a)
-  {#lefts Nat
-   #right? Bit
-   #value a})
-
-(type: #export (Tuple a) (List a))
-
 (type: #export Arity Nat)
 
 (type: #export (Abstraction c) [Environment Arity c])
@@ -112,92 +112,10 @@
       (#..Function (list))
       (#..Apply value)))
 
-(do-template [<name> <type> <structure> <prep-value>]
-  [(def: #export (<name> size tag value)
-     (-> Nat Tag <type> <type>)
-     (let [left (function.constant (|>> #.Left #Sum <structure>))
-           right (|>> #.Right #Sum <structure>)]
-       (if (last? size tag)
-         (list/fold left
-                    (right value)
-                    (list.indices (dec tag)))
-         (list/fold left
-                    (case value
-                      (<structure> (#Sum _))
-                      (<prep-value> value)
-
-                      _
-                      value)
-                    (list.indices (inc tag))))))]
-
-  [sum-analysis Analysis #Structure ..no-op]
-  [sum-pattern  Pattern  #Complex   id]
-  )
-
-(do-template [<name> <type> <primitive> <structure>]
-  [(def: #export (<name> members)
-     (-> (Tuple <type>) <type>)
-     (case (list.reverse members)
-       #.Nil
-       (<primitive> #Unit)
-
-       (#.Cons singleton #.Nil)
-       singleton
-
-       (#.Cons last prevs)
-       (list/fold (function (_ left right) (<structure> (#Product left right)))
-                  last prevs)))]
-
-  [product-analysis Analysis #Primitive #Structure]
-  [product-pattern  Pattern  #Simple    #Complex]
-  )
-
 (def: #export (apply [func args])
   (-> (Application Analysis) Analysis)
   (list/fold (function (_ arg func) (#Apply arg func)) func args))
 
-(do-template [<name> <type> <tag>]
-  [(def: #export (<name> value)
-     (-> <type> (Tuple <type>))
-     (case value
-       (<tag> (#Product left right))
-       (#.Cons left (<name> right))
-
-       _
-       (list value)))]
-
-  [tuple         Analysis #Structure]
-  [tuple-pattern Pattern  #Complex]
-  )
-
-(do-template [<name> <type> <tag>]
-  [(def: #export (<name> value)
-     (-> <type> (Maybe (Variant <type>)))
-     (loop [lefts 0
-            variantA value]
-       (case variantA
-         (<tag> (#Sum (#.Left valueA)))
-         (case valueA
-           (<tag> (#Sum _))
-           (recur (inc lefts) valueA)
-
-           _
-           (#.Some {#lefts lefts
-                    #right? #0
-                    #value valueA}))
-         
-         (<tag> (#Sum (#.Right valueA)))
-         (#.Some {#lefts lefts
-                  #right? #1
-                  #value valueA})
-
-         _
-         #.None)))]
-
-  [variant         Analysis #Structure]
-  [variant-pattern Pattern  #Complex]
-  )
-
 (def: #export (application analysis)
   (-> Analysis (Application Analysis))
   (case analysis
@@ -208,6 +126,26 @@
     _
     [analysis (list)]))
 
+(do-template [<name> <tag>]
+  [(template: #export (<name> content)
+     (.<| #Complex
+          <tag>
+          content))]
+
+  [pattern/variant #..Variant]
+  [pattern/tuple   #..Tuple]
+  )
+
+(do-template [<name> <tag>]
+  [(template: #export (<name> content)
+     (.<| #..Structure
+          <tag>
+          content))]
+
+  [variant #..Variant]
+  [tuple   #..Tuple]
+  )
+
 (template: #export (pattern/unit)
   (#..Simple #..Unit))
 
@@ -223,6 +161,9 @@
   [pattern/text #..Text]
   )
 
+(template: #export (pattern/bind register)
+  (#..Bind register))
+
 (def: #export (with-source-code source action)
   (All [a] (-> Source (Operation a) (Operation a)))
   (function (_ [bundle state])
@@ -314,13 +255,11 @@
     
     (#Structure structure)
     (case structure
-      (#Sum _)
-      (let [[lefts right? value] (maybe.assume (..variant analysis))]
-        (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")"))
+      (#Variant [lefts right? value])
+      (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")")
       
-      (#Product _)
-      (|> analysis
-          ..tuple
+      (#Tuple members)
+      (|> members
           (list/map %analysis)
           (text.join-with " ")
           (text.enclose ["[" "]"])))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux
index 5b5b2038c..0d3536db3 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/case.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/case.lux
@@ -208,7 +208,7 @@
                                              [nextA next]
                                              (wrap [(list) nextA]))
                                            (list.reverse matches))]
-              (wrap [(//.product-pattern memberP+)
+              (wrap [(//.pattern/tuple memberP+)
                      thenA])))
 
           _
@@ -246,8 +246,12 @@
                                                   (type.variant (list.drop (dec num-cases) flat-sum))
                                                   (` [(~+ values)])
                                                   next)
-                                 (analyse-pattern #.None caseT (` [(~+ values)]) next))]
-                (wrap [(//.sum-pattern num-cases idx testP)
+                                 (analyse-pattern #.None caseT (` [(~+ values)]) next))
+                 #let [right? (n/= (dec num-cases) idx)
+                       lefts (if right?
+                               (dec idx)
+                               idx)]]
+                (wrap [(//.pattern/variant [lefts right? testP])
                        nextA]))
 
               _
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
index df09bb0ec..6b2f307ac 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
@@ -17,30 +17,13 @@
   ["." //// ("operation/." Monad<Operation>)]
   ["." /// (#+ Pattern Variant Operation)])
 
+(exception: #export (invalid-tuple-pattern)
+  "Tuple size must be >= 2")
+
 (def: cases
   (-> (Maybe Nat) Nat)
   (|>> (maybe.default 0)))
 
-(def: (variant sum-side)
-  (-> (Either Pattern Pattern) (Variant Pattern))
-  (loop [lefts 0
-         variantP sum-side]
-    (case variantP
-      (#.Left valueP)
-      (case valueP
-        (#///.Complex (#///.Sum value-side))
-        (recur (inc lefts) value-side)
-
-        _
-        {#///.lefts lefts
-         #///.right? #0
-         #///.value valueP})
-      
-      (#.Right valueP)
-      {#///.lefts lefts
-       #///.right? #1
-       #///.value valueP})))
-
 ## 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.
@@ -96,31 +79,39 @@
 
     ## Tuple patterns can be exhaustive if there is exhaustiveness for all of
     ## their sub-patterns.
-    (#///.Complex (#///.Product [left right]))
-    (do ////.Monad<Operation>
-      [left (determine left)
-       right (determine right)]
-      (case right
-        (#Exhaustive _)
-        (wrap left)
-
-        _
-        (wrap (#Seq left right))))
-
-    (#///.Complex (#///.Sum sum-side))
-    (let [[variant-lefts variant-right? variant-value] (variant sum-side)]
-      ## Variant patterns can be shown to be exhaustive if all the possible
-      ## cases are handled exhaustively.
+    (#///.Complex (#///.Tuple membersP+))
+    (case (list.reverse membersP+)
+      (^or #.Nil (#.Cons _ #.Nil))
+      (////.throw invalid-tuple-pattern [])
+      
+      (#.Cons lastP prevsP+)
       (do ////.Monad<Operation>
-        [value-coverage (determine variant-value)
-         #let [variant-idx (if variant-right?
-                             (inc variant-lefts)
-                             variant-lefts)]]
-        (wrap (#Variant (if variant-right?
-                          (#.Some variant-idx)
-                          #.None)
-                        (|> (dict.new number.Hash<Nat>)
-                            (dict.put variant-idx value-coverage))))))))
+        [lastC (determine lastP)]
+        (monad.fold ////.Monad<Operation>
+                    (function (_ leftP rightC)
+                      (do ////.Monad<Operation>
+                        [leftC (determine leftP)]
+                        (case rightC
+                          #Exhaustive
+                          (wrap leftC)
+
+                          _
+                          (wrap (#Seq leftC rightC)))))
+                    lastC prevsP+)))
+
+    ## Variant patterns can be shown to be exhaustive if all the possible
+    ## cases are handled exhaustively.
+    (#///.Complex (#///.Variant [lefts right? value]))
+    (do ////.Monad<Operation>
+      [value-coverage (determine value)
+       #let [idx (if right?
+                   (inc lefts)
+                   lefts)]]
+      (wrap (#Variant (if right?
+                        (#.Some idx)
+                        #.None)
+                      (|> (dict.new number.Hash<Nat>)
+                          (dict.put idx value-coverage)))))))
 
 (def: (xor left right)
   (-> Bit Bit Bit)
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/structure.lux b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux
index 1ef523c76..3988349e0 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/structure.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux
@@ -2,12 +2,14 @@
   [lux #*
    [control
     ["." monad (#+ do)]
-    ["ex" exception (#+ exception:)]]
+    ["ex" exception (#+ exception:)]
+    ["." state]]
    [data
     ["." name]
     ["." number]
     ["." product]
     ["." maybe]
+    ["." error]
     [text
      format]
     [collection
@@ -86,13 +88,18 @@
       (case expectedT
         (#.Sum _)
         (let [flat (type.flatten-variant expectedT)
-              type-size (list.size flat)]
+              type-size (list.size flat)
+              right? (n/= (dec type-size)
+                          tag)
+              lefts (if right?
+                      (dec tag)
+                      tag)]
           (case (list.nth tag flat)
             (#.Some variant-type)
             (do @
               [valueA (//type.with-type variant-type
                         (analyse valueC))]
-              (wrap (//.sum-analysis type-size tag valueA)))
+              (wrap (//.variant [lefts right? valueA])))
 
             #.None
             (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT])))
@@ -151,44 +158,32 @@
         _
         (///.throw invalid-variant-type [expectedT tag valueC])))))
 
-(def: (typed-product analyse membersC+)
+(def: (typed-product analyse members)
   (-> Phase (List Code) (Operation Analysis))
   (do ///.Monad<Operation>
-    [expectedT (extension.lift macro.expected-type)]
-    (loop [expectedT expectedT
-           membersC+ membersC+]
-      (case [expectedT membersC+]
-        ## If the tuple runs out, whatever expression is the last gets
-        ## matched to the remaining type.
-        [tailT (#.Cons tailC #.Nil)]
-        (//type.with-type tailT
-          (analyse tailC))
-
-        ## If the type and the code are still ongoing, match each
-        ## sub-expression to its corresponding type.
-        [(#.Product leftT rightT) (#.Cons leftC rightC)]
-        (do @
-          [leftA (//type.with-type leftT
-                   (analyse leftC))
-           rightA (recur rightT rightC)]
-          (wrap (#//.Structure (#//.Product leftA rightA))))
-
-        ## If, however, the type runs out but there is still enough
-        ## tail, the remaining elements get packaged into another
-        ## tuple.
-        ## The reason for this is that it is assumed that the type of
-        ## the tuple represents the expectations of the user.
-        ## If the type is for a 3-tuple, but a 5-tuple is provided, it
-        ## is assumed that the user intended the following layout:
-        ## [+0, +1, [+2, +3, +4]]
-        ## but that, for whatever reason, it was written in a flat
-        ## way.
-        [tailT tailC]
-        (|> tailC
-            code.tuple
-            analyse
-            (//type.with-type tailT)
-            (:: @ map (|>> //.no-op)))))))
+    [expectedT (extension.lift macro.expected-type)
+     membersA+ (: (Operation (List Analysis))
+                  (loop [membersT+ (type.flatten-tuple expectedT)
+                         membersC+ members]
+                    (case [membersT+ membersC+]
+                      [(#.Cons memberT #.Nil) _]
+                      (//type.with-type memberT
+                        (:: @ map (|>> list) (analyse (code.tuple membersC+))))
+                      
+                      [_ (#.Cons memberC #.Nil)]
+                      (//type.with-type (type.tuple membersT+)
+                        (:: @ map (|>> list) (analyse memberC)))
+                      
+                      [(#.Cons memberT membersT+') (#.Cons memberC membersC+')]
+                      (do @
+                        [memberA (//type.with-type memberT
+                                   (analyse memberC))
+                         memberA+ (recur membersT+' membersC+')]
+                        (wrap (#.Cons memberA memberA+)))
+
+                      _
+                      (///.throw cannot-analyse-tuple [expectedT members]))))]
+    (wrap (//.tuple membersA+))))
 
 (def: #export (product analyse membersC)
   (-> Phase (List Code) (Operation Analysis))
@@ -220,7 +215,7 @@
                _ (//type.with-env
                    (check.check expectedT
                                 (type.tuple (list/map product.left membersTA))))]
-              (wrap (//.product-analysis (list/map product.right membersTA))))))
+              (wrap (//.tuple (list/map product.right membersTA))))))
 
         (^template [<tag> <instancer>]
           (<tag> _)
@@ -268,8 +263,12 @@
       (do @
         [#let [case-size (list.size group)]
          inferenceT (inference.variant idx case-size variantT)
-         [inferredT valueA+] (inference.general analyse inferenceT (list valueC))]
-        (wrap (//.sum-analysis case-size idx (|> valueA+ list.head maybe.assume))))
+         [inferredT valueA+] (inference.general analyse inferenceT (list valueC))
+         #let [right? (n/= (dec case-size) idx)
+               lefts (if right?
+                       (dec idx)
+                       idx)]]
+        (wrap (//.variant [lefts right? (|> valueA+ list.head maybe.assume)])))
 
       _
       (..sum analyse idx valueC))))
@@ -353,7 +352,7 @@
           (do @
             [inferenceT (inference.record recordT)
              [inferredT membersA] (inference.general analyse inferenceT membersC)]
-            (wrap (//.product-analysis membersA)))
+            (wrap (//.tuple membersA)))
 
           _
           (..product analyse membersC))))))
diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux
index 069ec4e1a..5406ac20a 100644
--- a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux
+++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux
@@ -1138,7 +1138,7 @@
   (|> inputsA
       (list.zip2 (list/map analysis.text typesT))
       (list/map (function (_ [type value])
-                  (analysis.product-analysis (list type value))))))
+                  (analysis.tuple (list type value))))))
 
 (def: invoke::static
   Handler
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux
index 3e59637a8..c9de46ac9 100644
--- a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux
+++ b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux
@@ -19,18 +19,22 @@
     [//
      ["." reference]]]])
 
-(def: (path' pattern bodyC)
-  (-> Pattern (Operation Path) (Operation Path))
+(def: clean-up
+  (-> Path Path)
+  (|>> (#//.Seq #//.Pop)))
+
+(def: (path' pattern end? thenC)
+  (-> Pattern Bit (Operation Path) (Operation Path))
   (case pattern
     (#analysis.Simple simple)
     (case simple
       #analysis.Unit
-      bodyC
+      thenC
       
       (^template [<from> <to>]
         (<from> value)
         (operation/map (|>> (#//.Seq (#//.Test (|> value <to>))))
-                       bodyC))
+                       thenC))
       ([#analysis.Bit  #//.Bit]
        [#analysis.Nat  (<| #//.I64 .i64)]
        [#analysis.Int  (<| #//.I64 .i64)]
@@ -45,40 +49,33 @@
                                             (n/+ (dec arity) register)
                                             register)))))
         //.with-new-local
-        bodyC)
-
-    (#analysis.Complex _)
-    (case (analysis.variant-pattern pattern)
-      (#.Some [lefts right? value-pattern])
-      (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right?
-                                                           (#.Right lefts)
-                                                           (#.Left lefts))))))
-                     (path' value-pattern bodyC))
-      
-      #.None
-      (let [tuple (analysis.tuple-pattern pattern)
-            tuple/last (dec (list.size tuple))]
-        (list/fold (function (_ [tuple/idx tuple/member] thenC)
-                     (case tuple/member
-                       (#analysis.Simple #analysis.Unit)
-                       thenC
-
-                       _
-                       (let [last? (n/= tuple/last tuple/idx)]
-                         (|> (if (or last?
-                                     (is? bodyC thenC))
-                               thenC
-                               (operation/map (|>> (#//.Seq #//.Pop)) thenC))
-                             (path' tuple/member)
-                             (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if last?
-                                                                                    (#.Right (dec tuple/idx))
-                                                                                    (#.Left tuple/idx)))))))))))
-                   bodyC
-                   (list.reverse (list.enumerate tuple)))))))
+        thenC)
+
+    (#analysis.Complex (#analysis.Variant [lefts right? value-pattern]))
+    (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right?
+                                                             (#.Right lefts)
+                                                             (#.Left lefts)))))))
+        (path' value-pattern end?)
+        (when (not end?) (operation/map ..clean-up))
+        thenC)
+
+    (#analysis.Complex (#analysis.Tuple tuple))
+    (let [tuple::last (dec (list.size tuple))]
+      (list/fold (function (_ [tuple::lefts tuple::member] nextC)
+                   (let [right? (n/= tuple::last tuple::lefts)
+                         end?' (and end? right?)]
+                     (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if right?
+                                                                                (#.Right (dec tuple::lefts))
+                                                                                (#.Left tuple::lefts)))))))
+                         (path' tuple::member end?')
+                         (when (not end?') (operation/map ..clean-up))
+                         nextC)))
+                 thenC
+                 (list.reverse (list.enumerate tuple))))))
 
 (def: #export (path synthesize pattern bodyA)
   (-> Phase Pattern Analysis (Operation Path))
-  (path' pattern (operation/map (|>> #//.Then) (synthesize bodyA))))
+  (path' pattern true (operation/map (|>> #//.Then) (synthesize bodyA))))
 
 (def: #export (weave leftP rightP)
   (-> Path Path Path)
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux b/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux
index e7db982d8..cd57c1d29 100644
--- a/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux
+++ b/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux
@@ -43,10 +43,10 @@
 
     (#//.Structure structure)
     (case structure
-      (#//.Variant variantS)
+      (#analysis.Variant variantS)
       (proper? (get@ #analysis.value variantS))
       
-      (#//.Tuple membersS+)
+      (#analysis.Tuple membersS+)
       (list.every? proper? membersS+))
 
     (#//.Control controlS)
@@ -197,18 +197,18 @@
     (case exprS
       (#//.Structure structureS)
       (case structureS
-        (#//.Variant variantS)
+        (#analysis.Variant variantS)
         (do maybe.Monad<Maybe>
           [valueS' (|> variantS (get@ #analysis.value) recur)]
           (wrap (|> variantS
                     (set@ #analysis.value valueS')
-                    #//.Variant
+                    #analysis.Variant
                     #//.Structure)))
         
-        (#//.Tuple membersS+)
+        (#analysis.Tuple membersS+)
         (|> membersS+
             (monad.map maybe.Monad<Maybe> recur)
-            (maybe/map (|>> #//.Tuple #//.Structure))))
+            (maybe/map (|>> #analysis.Tuple #//.Structure))))
 
       (#//.Reference reference)
       (case reference
diff --git a/stdlib/source/lux/compiler/default/reference.lux b/stdlib/source/lux/compiler/default/reference.lux
index cde1f5b5c..b945c1327 100644
--- a/stdlib/source/lux/compiler/default/reference.lux
+++ b/stdlib/source/lux/compiler/default/reference.lux
@@ -77,3 +77,12 @@
     
     (#Foreign foreign)
     (format "-" (%n foreign))))
+
+(def: #export (%reference reference)
+  (Format Reference)
+  (case reference
+    (#Variable variable)
+    (%variable variable)
+    
+    (#Constant constant)
+    (%name constant)))