- Simplified the analytic model of tuples into products, and variants into sums.

6 files changed, 110 insertions, 86 deletions

diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 90140afb4..2be2b6da6 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -61,7 +61,7 @@
              (analyse singleton)
 
              (^ (#;Tuple elems))
-             (&&struct;analyse-tuple analyse elems)
+             (&&struct;analyse-product analyse elems)
 
              (^ (#;Record pairs))
              (&&struct;analyse-record analyse pairs)
@@ -93,11 +93,11 @@
 
              (^ (#;Form (list [_ (#;Nat tag)]
                               value)))
-             (&&struct;analyse-variant analyse tag value)
+             (&&struct;analyse-sum analyse tag value)
 
              (^ (#;Form (list [_ (#;Tag tag)]
                               value)))
-             (&&struct;analyse-tagged-variant analyse tag value)
+             (&&struct;analyse-tagged-sum analyse tag value)
 
              (^ (#;Form (list& func args)))
              (do Monad<Lux>
diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux
index 48be75c3c..26580a503 100644
--- a/new-luxc/source/luxc/analyser/primitive.lux
+++ b/new-luxc/source/luxc/analyser/primitive.lux
@@ -31,4 +31,4 @@
     [expected macro;expected-type
      _ (&;within-type-env
         (TC;check expected Unit))]
-    (wrap (#la;Tuple (list)))))
+    (wrap #la;Unit)))
diff --git a/new-luxc/source/luxc/analyser/struct.lux b/new-luxc/source/luxc/analyser/struct.lux
index 185b8747f..562e30294 100644
--- a/new-luxc/source/luxc/analyser/struct.lux
+++ b/new-luxc/source/luxc/analyser/struct.lux
@@ -3,6 +3,7 @@
   (lux (control monad
                 pipe)
        [io #- run]
+       [function]
        (concurrency ["A" atom])
        (data [text "T/" Eq<Text>]
              text/format
@@ -17,58 +18,40 @@
        [type]
        (type ["TC" check]))
   (luxc ["&" base]
-        (lang ["la" analysis #+ Analysis])
+        (lang ["la" analysis #+ Analysis]
+              ["lp" pattern])
         ["&;" module]
         ["&;" env]
         (analyser ["&;" common]
                   ["&;" inference])))
 
 ## [Analysers]
-(def: (analyse-typed-tuple analyse members)
+(def: (analyse-typed-product analyse members)
   (-> &;Analyser (List Code) (Lux Analysis))
   (do Monad<Lux>
     [expected macro;expected-type]
-    (let [member-types (type;flatten-tuple expected)
-          num-types (list;size member-types)
-          num-members (list;size members)]
-      (cond (n.= num-types num-members)
-            (do @
-              [=tuple (: (Lux (List Analysis))
-                         (mapM @
-                               (function [[expected member]]
-                                 (&;with-expected-type expected
-                                   (analyse member)))
-                               (list;zip2 member-types members)))]
-              (wrap (#la;Tuple =tuple)))
-
-            (n.< num-types num-members)
-            (do @
-              [#let [[head-ts tail-ts] (list;split (n.- +2 num-members)
-                                                   member-types)]
-               =prevs (mapM @
-                            (function [[expected member]]
-                              (&;with-expected-type expected
-                                (analyse member)))
-                            (list;zip2 head-ts members))
-               =last (&;with-expected-type (type;tuple tail-ts)
-                       (analyse (default (undefined)
-                                  (list;last members))))]
-              (wrap (#la;Tuple (L/append =prevs (list =last)))))
-
-            ## (n.> num-types num-members)
-            (do @
-              [#let [[head-xs tail-xs] (list;split (n.- +2 num-types)
-                                                   members)]
-               =prevs (mapM @
-                            (function [[expected member]]
-                              (&;with-expected-type expected
-                                (analyse member)))
-                            (list;zip2 member-types head-xs))
-               =last (&;with-expected-type (default (undefined)
-                                             (list;last member-types))
-                       (analyse-typed-tuple analyse tail-xs))]
-              (wrap (#la;Tuple (L/append =prevs (list =last)))))
-            ))))
+    (loop [expected expected
+           members members]
+      (case [expected members]
+        [(#;Product leftT rightT) (#;Cons leftC rightC)]
+        (do @
+          [leftA (&;with-expected-type leftT
+                   (analyse leftC))
+           rightA (recur rightT rightC)]
+          (wrap (#la;Product leftA rightA)))
+
+        [tailT (#;Cons tailC #;Nil)]
+        (&;with-expected-type tailT
+          (analyse tailC))
+
+        [tailT tailC]
+        (do @
+          [g!tail (macro;gensym "tail")]
+          (&;with-expected-type tailT
+            (analyse (` ((~' _lux_case) [(~@ tailC)]
+                         (~ g!tail)
+                         (~ g!tail))))))
+        ))))
 
 (def: #export (normalize-record pairs)
   (-> (List [Code Code]) (Lux (List [Ident Code])))
@@ -125,7 +108,19 @@
     _
     (:: Monad<Lux> wrap [(list) Unit])))
 
-(def: #export (analyse-tuple analyse members)
+(def: (tuple members)
+  (-> (List Analysis) Analysis)
+  (case members
+    #;Nil
+    #la;Unit
+
+    (#;Cons singleton #;Nil)
+    singleton
+
+    (#;Cons left right)
+    (#la;Product left (tuple right))))
+
+(def: #export (analyse-product analyse membersC)
   (-> &;Analyser (List Code) (Lux Analysis))
   (do Monad<Lux>
     [expected macro;expected-type]
@@ -133,11 +128,11 @@
       (function [_] (format "Invalid type for tuple: " (%type expected)))
       (case expected
         (#;Product _)
-        (analyse-typed-tuple analyse members)
+        (analyse-typed-product analyse membersC)
 
         (#;Named name unnamedT)
         (&;with-expected-type unnamedT
-          (analyse-tuple analyse members))
+          (analyse-product analyse membersC))
 
         (#;Var id)
         (do @
@@ -148,27 +143,27 @@
               [expected' (&;within-type-env
                           (TC;read-var id))]
               (&;with-expected-type expected'
-                (analyse-tuple analyse members)))
+                (analyse-product analyse membersC)))
             (do @
-              [=members (mapM @ (|>. analyse &common;with-unknown-type)
-                              members)
-               #let [tuple-type (type;tuple (L/map product;left =members))]
+              [membersTA (mapM @ (|>. analyse &common;with-unknown-type)
+                               membersC)
                _ (&;within-type-env
-                  (TC;check expected tuple-type))]
-              (wrap (#la;Tuple (L/map product;right =members))))))
+                  (TC;check expected
+                            (type;tuple (L/map product;left membersTA))))]
+              (wrap (tuple (L/map product;right membersTA))))))
 
         (#;UnivQ _)
         (do @
           [[var-id var] (&;within-type-env
                          TC;existential)]
           (&;with-expected-type (assume (type;apply-type expected var))
-            (analyse-tuple analyse members)))
+            (analyse-product analyse membersC)))
 
         (#;ExQ _)
         (&common;with-var
           (function [[var-id var]]
             (&;with-expected-type (assume (type;apply-type expected var))
-              (analyse-tuple analyse members))))
+              (analyse-product analyse membersC))))
         
         _
         (&;fail "")
@@ -258,9 +253,34 @@
      [inferredT membersA] (&inference;apply-function analyse functionT members)
      _ (&;within-type-env
         (TC;check expectedT inferredT))]
-    (wrap (#la;Tuple membersA))))
-
-(def: #export (analyse-tagged-variant analyse tag value)
+    (wrap (tuple membersA))))
+
+(do-template [<name> <side>]
+  [(def: (<name> inner)
+     (-> Analysis Analysis)
+     (#la;Sum (<side> inner)))]
+
+  [sum-left  #;Left]
+  [sum-right #;Right])
+
+(def: (variant tag size temp value)
+  (-> Nat Nat Nat Analysis Analysis)
+  (let [last-tag (n.dec size)]
+    (if (n.= last-tag tag)
+      (L/fold (function;const sum-left)
+              (sum-right value)
+              (list;n.range +0 last-tag))
+      (L/fold (function;const sum-left)
+              (case value
+                (#la;Sum _)
+                (#la;Case value (list [(#lp;Bind temp)
+                                       (#la;Relative (#;Local temp))]))
+
+                _
+                value)
+              (list;n.range +0 tag)))))
+
+(def: #export (analyse-tagged-sum analyse tag value)
   (-> &;Analyser Ident Code (Lux Analysis))
   (do Monad<Lux>
     [tag (macro;normalize tag)
@@ -270,10 +290,11 @@
      [inferredT valueA+] (&inference;apply-function analyse functionT (list value))
      expectedT macro;expected-type
      _ (&;within-type-env
-        (TC;check expectedT inferredT))]
-    (wrap (#la;Variant idx case-size (|> valueA+ list;head assume)))))
+        (TC;check expectedT inferredT))
+     temp &env;next-local]
+    (wrap (variant idx case-size temp (|> valueA+ list;head assume)))))
 
-(def: #export (analyse-variant analyse tag value)
+(def: #export (analyse-sum analyse tag valueC)
   (-> &;Analyser Nat Code (Lux Analysis))
   (do Monad<Lux>
     [expected macro;expected-type]
@@ -286,16 +307,17 @@
           (case (list;nth tag flat)
             (#;Some variant-type)
             (do @
-              [=value (&;with-expected-type variant-type
-                        (analyse value))]
-              (wrap (#la;Variant tag type-size =value)))
+              [valueA (&;with-expected-type variant-type
+                        (analyse valueC))
+               temp &env;next-local]
+              (wrap (variant tag type-size temp valueA)))
 
             #;None
             (out-of-bounds-error expected type-size tag)))
 
         (#;Named name unnamedT)
         (&;with-expected-type unnamedT
-          (analyse-variant analyse tag value))
+          (analyse-sum analyse tag valueC))
 
         (#;Var id)
         (do @
@@ -306,7 +328,7 @@
               [expected' (&;within-type-env
                           (TC;read-var id))]
               (&;with-expected-type expected'
-                (analyse-variant analyse tag value)))
+                (analyse-sum analyse tag valueC)))
             (&;fail (format "Invalid type for variant: " (%type expected)))))
 
         (#;UnivQ _)
@@ -314,13 +336,13 @@
           [[var-id var] (&;within-type-env
                          TC;existential)]
           (&;with-expected-type (assume (type;apply-type expected var))
-            (analyse-variant analyse tag value)))
+            (analyse-sum analyse tag valueC)))
 
         (#;ExQ _)
         (&common;with-var
           (function [[var-id var]]
             (&;with-expected-type (assume (type;apply-type expected var))
-              (analyse-variant analyse tag value))))
+              (analyse-sum analyse tag valueC))))
         
         _
         (&;fail "")))))
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
index 8cfc9b108..4e823276d 100644
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ b/new-luxc/source/luxc/lang/analysis.lux
@@ -11,8 +11,9 @@
   (#Real Real)
   (#Char Char)
   (#Text Text)
-  (#Variant Nat Nat Analysis)
-  (#Tuple (List Analysis))
+  #Unit
+  (#Sum (Either Analysis Analysis))
+  (#Product Analysis Analysis)
   (#Case Analysis (List [lp;Pattern Analysis]))
   (#Function Scope Analysis)
   (#Apply Analysis Analysis)
diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux
index e844c194d..6053e2fd7 100644
--- a/new-luxc/test/test/luxc/analyser/primitive.lux
+++ b/new-luxc/test/test/luxc/analyser/primitive.lux
@@ -48,6 +48,7 @@
                                         false))
                              )]
 
+                    ["unit" Unit #~;Unit []     (function [value] @;analyse-unit)]
                     ["bool" Bool #~;Bool %bool% @;analyse-bool]
                     ["nat"  Nat  #~;Nat  %nat%  @;analyse-nat]
                     ["int"  Int  #~;Int  %int%  @;analyse-int]
@@ -57,13 +58,4 @@
                     ["text" Text #~;Text %text% @;analyse-text]
                     )]
     ($_ seq
-        (assert (format "Can analyse unit.")
-                (|> (@common;with-unknown-type
-                      @;analyse-unit)
-                    (macro;run init-compiler)
-                    (case> (^ (#R;Success [_type (#~;Tuple (list))]))
-                           (Type/= Unit _type)
-
-                           _
-                           false)))
         <primitives>)))
diff --git a/new-luxc/test/test/luxc/analyser/struct.lux b/new-luxc/test/test/luxc/analyser/struct.lux
index 869b2b0d1..8bf7957b5 100644
--- a/new-luxc/test/test/luxc/analyser/struct.lux
+++ b/new-luxc/test/test/luxc/analyser/struct.lux
@@ -11,7 +11,7 @@
        [macro #+ Monad<Lux>]
        test)
   (luxc ["&" base]
-        (lang ["~" analysis])
+        (lang ["la" analysis])
         [analyser]
         (analyser ["@" struct]
                   ["@;" common]))
@@ -21,18 +21,27 @@
   &;Analyser
   (analyser;analyser (:!! [])))
 
+(def: (flatten-tuple analysis)
+  (-> la;Analysis (List la;Analysis))
+  (case analysis
+    (#la;Product left right)
+    (#;Cons left (flatten-tuple right))
+
+    _
+    (list analysis)))
+
 (test: "Tuples"
   [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
    primitives (r;list size gen-simple-primitive)]
   ($_ seq
       (assert "Can analyse tuple."
               (|> (@common;with-unknown-type
-                    (@;analyse-tuple analyse (L/map product;right primitives)))
+                    (@;analyse-product analyse (L/map product;right primitives)))
                   (macro;run init-compiler)
-                  (case> (#R;Success [_type (#~;Tuple elems)])
+                  (case> (#R;Success [_type tupleA])
                          (and (Type/= (type;tuple (L/map product;left primitives))
                                       _type)
-                              (n.= size (list;size elems)))
+                              (n.= size (list;size (flatten-tuple tupleA))))
 
                          _
                          false))