Now using the new syntax for variants (even though they still work the old way... for now)

5 files changed, 138 insertions, 125 deletions

diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
index f3dc89993..297fc7075 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
@@ -47,6 +47,24 @@
    #right? Bit
    #value a})
 
+(def: #export (tag lefts right?)
+  (-> Nat Bit Nat)
+  (if right?
+    (inc lefts)
+    lefts))
+
+(def: (lefts tag right?)
+  (-> Nat Bit Nat)
+  (if right?
+    (dec tag)
+    tag))
+
+(def: #export (choice options pick)
+  (-> Nat Nat [Nat Bit])
+  (let [right? (n.= (dec options) pick)]
+    [(..lefts pick right?)
+     right?]))
+
 (type: #export (Tuple a)
   (List a))
 
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux
index 21a2b4d3f..8ca459028 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux
@@ -54,17 +54,23 @@
 (def: (compile|structure archive compile else code')
   (-> Archive Phase (Fix (-> (Code' (Ann Cursor)) (Operation Analysis))))
   (case code'
-    (^template [<tag> <analyser>]
-      (^ (#.Form (list& [_ (<tag> tag)]
-                        values)))
-      (case values
-        (#.Cons value #.Nil)
-        (<analyser> compile tag archive value)
-
-        _
-        (<analyser> compile tag archive (` [(~+ values)]))))
-    ([#.Nat /structure.sum]
-     [#.Tag /structure.tagged-sum])
+    (^ (#.Form (list& [_ (#.Tag tag)]
+                      values)))
+    (case values
+      (#.Cons value #.Nil)
+      (/structure.tagged-sum compile tag archive value)
+
+      _
+      (/structure.tagged-sum compile tag archive (` [(~+ values)])))
+
+    (^ (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)]
+                      values)))
+    (case values
+      (#.Cons value #.Nil)
+      (/structure.sum compile lefts right? archive value)
+
+      _
+      (/structure.sum compile lefts right? archive (` [(~+ values)])))
 
     (#.Tag tag)
     (/structure.tagged-sum compile tag archive (' []))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux
index 4638c33d9..01afd6142 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux
@@ -84,7 +84,7 @@
           (recur envs caseT')
 
           _
-          (/.throw cannot-simplify-for-pattern-matching caseT)))
+          (/.throw ..cannot-simplify-for-pattern-matching caseT)))
 
       (#.Named name unnamedT)
       (recur envs unnamedT)
@@ -119,7 +119,7 @@
           (recur envs outputT)
 
           #.None
-          (/.throw cannot-simplify-for-pattern-matching caseT)))
+          (/.throw ..cannot-simplify-for-pattern-matching caseT)))
 
       (#.Product _)
       (|> caseT
@@ -219,7 +219,7 @@
                      thenA])))
 
           _
-          (/.throw cannot-match-with-pattern [inputT' pattern])
+          (/.throw ..cannot-match-with-pattern [inputT' pattern])
           )))
 
     [cursor (#.Record record)]
@@ -239,7 +239,7 @@
     (/.with-cursor cursor
       (analyse-pattern #.None inputT (` ((~ pattern))) next))
 
-    (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))])
+    (^ [cursor (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] values))])
     (/.with-cursor cursor
       (do ///.monad
         [inputT' (simplify-case inputT)]
@@ -247,7 +247,8 @@
           (#.Sum _)
           (let [flat-sum (type.flatten-variant inputT')
                 size-sum (list.size flat-sum)
-                num-cases (maybe.default size-sum num-tags)]
+                num-cases (maybe.default size-sum num-tags)
+                idx (/.tag lefts right?)]
             (.case (list.nth idx flat-sum)
               (^multi (#.Some caseT)
                       (n.< num-cases idx))
@@ -258,16 +259,12 @@
                                                   (type.variant (list.drop (dec num-cases) flat-sum))
                                                   (` [(~+ values)])
                                                   next)
-                                 (analyse-pattern #.None caseT (` [(~+ values)]) next))
-                 #let [right? (n.= (dec num-cases) idx)
-                       lefts (if right?
-                               (dec idx)
-                               idx)]]
+                                 (analyse-pattern #.None caseT (` [(~+ values)]) next))]
                 (wrap [(/.pattern/variant [lefts right? testP])
                        nextA]))
 
               _
-              (/.throw sum-has-no-case [idx inputT])))
+              (/.throw ..sum-has-no-case [idx inputT])))
 
           (#.UnivQ _)
           (do ///.monad
@@ -279,7 +276,7 @@
                              next))
           
           _
-          (/.throw cannot-match-with-pattern [inputT' pattern]))))
+          (/.throw ..cannot-match-with-pattern [inputT' pattern]))))
 
     (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
     (/.with-cursor cursor
@@ -287,11 +284,12 @@
         [tag (///extension.lift (macro.normalize tag))
          [idx group variantT] (///extension.lift (macro.resolve-tag tag))
          _ (//type.with-env
-             (check.check inputT variantT))]
-        (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
+             (check.check inputT variantT))
+         #let [[lefts right?] (/.choice (list.size group) idx)]]
+        (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat lefts)) (~ (code.bit right?)) (~+ values))) next)))
 
     _
-    (/.throw not-a-pattern pattern)
+    (/.throw ..not-a-pattern pattern)
     ))
 
 (def: #export (case analyse branches archive inputC)
@@ -318,4 +316,4 @@
       (wrap (#/.Case inputA [outputH outputT])))
 
     #.Nil
-    (/.throw cannot-have-empty-branches "")))
+    (/.throw ..cannot-have-empty-branches "")))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux
index 095120ac5..f4bae0122 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux
@@ -145,7 +145,7 @@
         (general archive analyse outputT args)
 
         #.None
-        (/.throw invalid-type-application inferT))
+        (/.throw ..invalid-type-application inferT))
 
       ## Arguments are inferred back-to-front because, by convention,
       ## Lux functions take the most important arguments *last*, which
@@ -170,10 +170,10 @@
           (general archive analyse inferT' args)
 
           _
-          (/.throw cannot-infer [inferT args])))
+          (/.throw ..cannot-infer [inferT args])))
 
       _
-      (/.throw cannot-infer [inferT args]))
+      (/.throw ..cannot-infer [inferT args]))
     ))
 
 (def: (substitute-bound target sub)
@@ -222,7 +222,7 @@
       (record' target originalT outputT)
 
       #.None
-      (/.throw invalid-type-application inferT))
+      (/.throw ..invalid-type-application inferT))
 
     (#.Product _)
     (///@wrap (|> inferT
@@ -230,7 +230,7 @@
                   (substitute-bound target originalT)))
 
     _
-    (/.throw not-a-record-type inferT)))
+    (/.throw ..not-a-record-type inferT)))
 
 (def: #export (record inferT)
   (-> Type (Operation Type))
@@ -271,10 +271,10 @@
                                 (replace' currentT)))))
 
                 #.None
-                (/.throw variant-tag-out-of-bounds [expected-size tag inferT]))
+                (/.throw ..variant-tag-out-of-bounds [expected-size tag inferT]))
               
               (n.< expected-size actual-size)
-              (/.throw smaller-variant-than-expected [expected-size actual-size])
+              (/.throw ..smaller-variant-than-expected [expected-size actual-size])
 
               (n.= boundary tag)
               (let [caseT (type.variant (list.drop boundary cases))]
@@ -285,7 +285,7 @@
                                 (replace' currentT))))))
               
               ## else
-              (/.throw variant-tag-out-of-bounds [expected-size tag inferT])))
+              (/.throw ..variant-tag-out-of-bounds [expected-size tag inferT])))
 
       (#.Apply inputT funcT)
       (case (type.apply (list inputT) funcT)
@@ -293,7 +293,7 @@
         (variant tag expected-size outputT)
 
         #.None
-        (/.throw invalid-type-application inferT))
+        (/.throw ..invalid-type-application inferT))
 
       _
-      (/.throw not-a-variant-type inferT))))
+      (/.throw ..not-a-variant-type inferT))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux
index 7201a68ee..68da1dd68 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux
@@ -87,86 +87,80 @@
                                                    [(code.tag keyI) valueC]))
                                        code.record))]))
 
-(def: #export (sum analyse tag archive)
-  (-> Phase Nat Phase)
-  (function (recur valueC)
-    (do {@ ///.monad}
-      [expectedT (///extension.lift macro.expected-type)
-       expectedT' (//type.with-env
-                    (check.clean expectedT))]
-      (/.with-stack ..cannot-analyse-variant [expectedT' tag valueC]
-        (case expectedT
-          (#.Sum _)
-          (let [flat (type.flatten-variant expectedT)
-                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 archive valueC))]
-                (wrap (/.variant [lefts right? valueA])))
+(def: #export (sum analyse lefts right? archive)
+  (-> Phase Nat Bit Phase)
+  (let [tag (/.tag lefts right?)]
+    (function (recur valueC)
+      (do {@ ///.monad}
+        [expectedT (///extension.lift macro.expected-type)
+         expectedT' (//type.with-env
+                      (check.clean expectedT))]
+        (/.with-stack ..cannot-analyse-variant [expectedT' tag valueC]
+          (case expectedT
+            (#.Sum _)
+            (let [flat (type.flatten-variant expectedT)]
+              (case (list.nth tag flat)
+                (#.Some variant-type)
+                (do @
+                  [valueA (//type.with-type variant-type
+                            (analyse archive valueC))]
+                  (wrap (/.variant [lefts right? valueA])))
+
+                #.None
+                (/.throw //inference.variant-tag-out-of-bounds [(list.size flat) tag expectedT])))
+
+            (#.Named name unnamedT)
+            (//type.with-type unnamedT
+              (recur valueC))
+
+            (#.Var id)
+            (do @
+              [?expectedT' (//type.with-env
+                             (check.read id))]
+              (case ?expectedT'
+                (#.Some expectedT')
+                (//type.with-type expectedT'
+                  (recur valueC))
 
-              #.None
-              (/.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT])))
+                ## 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.
+                _
+                (/.throw ..cannot-infer-numeric-tag [expectedT tag valueC])))
 
-          (#.Named name unnamedT)
-          (//type.with-type unnamedT
-            (recur valueC))
+            (^template [<tag> <instancer>]
+              (<tag> _)
+              (do @
+                [[instance-id instanceT] (//type.with-env <instancer>)]
+                (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT))
+                  (recur valueC))))
+            ([#.UnivQ check.existential]
+             [#.ExQ check.var])
+
+            (#.Apply inputT funT)
+            (case funT
+              (#.Var funT-id)
+              (do @
+                [?funT' (//type.with-env (check.read funT-id))]
+                (case ?funT'
+                  (#.Some funT')
+                  (//type.with-type (#.Apply inputT funT')
+                    (recur valueC))
 
-          (#.Var id)
-          (do @
-            [?expectedT' (//type.with-env
-                           (check.read id))]
-            (case ?expectedT'
-              (#.Some expectedT')
-              (//type.with-type expectedT'
-                (recur valueC))
+                  _
+                  (/.throw ..invalid-variant-type [expectedT tag valueC])))
 
               _
-              ## 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.
-              (/.throw cannot-infer-numeric-tag [expectedT tag valueC])
-              ))
-
-          (^template [<tag> <instancer>]
-            (<tag> _)
-            (do @
-              [[instance-id instanceT] (//type.with-env <instancer>)]
-              (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT))
-                (recur valueC))))
-          ([#.UnivQ check.existential]
-           [#.ExQ check.var])
-
-          (#.Apply inputT funT)
-          (case funT
-            (#.Var funT-id)
-            (do @
-              [?funT' (//type.with-env (check.read funT-id))]
-              (case ?funT'
-                (#.Some funT')
-                (//type.with-type (#.Apply inputT funT')
+              (case (type.apply (list inputT) funT)
+                (#.Some outputT)
+                (//type.with-type outputT
                   (recur valueC))
 
-                _
-                (/.throw invalid-variant-type [expectedT tag valueC])))
-
+                #.None
+                (/.throw ..not-a-quantified-type funT)))
+            
             _
-            (case (type.apply (list inputT) funT)
-              (#.Some outputT)
-              (//type.with-type outputT
-                (recur valueC))
-
-              #.None
-              (/.throw not-a-quantified-type funT)))
-          
-          _
-          (/.throw invalid-variant-type [expectedT tag valueC]))))))
+            (/.throw ..invalid-variant-type [expectedT tag valueC])))))))
 
 (def: (typed-product archive analyse members)
   (-> Archive Phase (List Code) (Operation Analysis))
@@ -192,7 +186,7 @@
                         (wrap (#.Cons memberA memberA+)))
 
                       _
-                      (/.throw cannot-analyse-tuple [expectedT members]))))]
+                      (/.throw ..cannot-analyse-tuple [expectedT members]))))]
     (wrap (/.tuple membersA+))))
 
 (def: #export (product archive analyse membersC)
@@ -247,7 +241,7 @@
                 (product archive analyse membersC))
 
               _
-              (/.throw invalid-tuple-type [expectedT membersC])))
+              (/.throw ..invalid-tuple-type [expectedT membersC])))
 
           _
           (case (type.apply (list inputT) funT)
@@ -256,10 +250,10 @@
               (product archive analyse membersC))
 
             #.None
-            (/.throw not-a-quantified-type funT)))
+            (/.throw ..not-a-quantified-type funT)))
         
         _
-        (/.throw invalid-tuple-type [expectedT membersC])
+        (/.throw ..invalid-tuple-type [expectedT membersC])
         ))))
 
 (def: #export (tagged-sum analyse tag archive valueC)
@@ -267,21 +261,18 @@
   (do {@ ///.monad}
     [tag (///extension.lift (macro.normalize tag))
      [idx group variantT] (///extension.lift (macro.resolve-tag tag))
+     #let [case-size (list.size group)
+           [lefts right?] (/.choice case-size idx)]
      expectedT (///extension.lift macro.expected-type)]
     (case expectedT
       (#.Var _)
       (do @
-        [#let [case-size (list.size group)]
-         inferenceT (//inference.variant idx case-size variantT)
-         [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))
-         #let [right? (n.= (dec case-size) idx)
-               lefts (if right?
-                       (dec idx)
-                       idx)]]
+        [inferenceT (//inference.variant idx case-size variantT)
+         [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))]
         (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)])))
 
       _
-      (..sum analyse idx archive valueC))))
+      (..sum analyse lefts right? archive valueC))))
 
 ## There cannot be any ambiguity or improper syntax when analysing
 ## records, so they must be normalized for further analysis.
@@ -298,7 +289,7 @@
                    (wrap [key val]))
 
                  _
-                 (/.throw record-keys-must-be-tags [key record])))
+                 (/.throw ..record-keys-must-be-tags [key record])))
              record))
 
 ## Lux already possesses the means to analyse tuples, so
@@ -319,7 +310,7 @@
              size-ts (list.size tag-set)]
        _ (if (n.= size-ts size-record)
            (wrap [])
-           (/.throw record-size-mismatch [size-ts size-record recordT record]))
+           (/.throw ..record-size-mismatch [size-ts size-record recordT record]))
        #let [tuple-range (list.indices size-ts)
              tag->idx (dictionary.from-list name.hash (list.zip2 tag-set tuple-range))]
        idx->val (monad.fold @
@@ -329,11 +320,11 @@
                                 (case (dictionary.get key tag->idx)
                                   (#.Some idx)
                                   (if (dictionary.contains? idx idx->val)
-                                    (/.throw cannot-repeat-tag [key record])
+                                    (/.throw ..cannot-repeat-tag [key record])
                                     (wrap (dictionary.put idx val idx->val)))
 
                                   #.None
-                                  (/.throw tag-does-not-belong-to-record [key recordT]))))
+                                  (/.throw ..tag-does-not-belong-to-record [key recordT]))))
                             (: (Dictionary Nat Code)
                                (dictionary.new n.hash))
                             record)