- Restructuring how sums & products work [part 2]

8 files changed, 76 insertions, 39 deletions

diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index aab25d741..212f02665 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -25,6 +25,7 @@
    "RealTotal"
    "CharTotal"
    "TextTotal"
+   "UnitTotal"
    "ProdTotal"
    "SumTotal"]
   )
@@ -36,6 +37,7 @@
    "RealTestAC"
    "CharTestAC"
    "TextTestAC"
+   "UnitTestAC"
    "ProdTestAC"
    "SumTestAC"]
   )
@@ -113,11 +115,14 @@
         type* (adjust-type type)
         idx (&module/tag-index =module =name)
         group (&module/tag-group =module =name)
+        ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))]
         case-type (&type/variant-case idx type*)]
     (return ($$ &/P idx (&/|length group) case-type))))
 
 (defn ^:private analyse-pattern [value-type pattern kont]
-  (|let [[_ pattern*] pattern]
+  (|let [[_ pattern*] pattern
+         ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))]
+         ]
     (|case pattern*
       (&/$SymbolS "" name)
       (|do [=kont (&env/with-local name value-type
@@ -153,6 +158,11 @@
             =kont kont]
         (return (&/P (&/S $TextTestAC ?value) =kont)))
 
+      (&/$TupleS (&/$Nil))
+      (|do [_ (&type/check value-type &type/Unit)
+            =kont kont]
+        (return (&/P (&/S $UnitTestAC nil) =kont)))
+      
       (&/$TupleS (&/$Cons ?_left ?tail))
       (|do [value-type* (adjust-type value-type)]
         (|case value-type*
@@ -168,7 +178,7 @@
                                                                                _
                                                                                (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))]
                                                           (return (&/P =right =kont))))]
-            (return (&/P (&/S $ProdTestAC =left =right) =kont)))
+            (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont)))
 
           _
           (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*)))))
@@ -182,8 +192,7 @@
             [=test =kont] (analyse-pattern case-type unit kont)]
         (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont)))
 
-      (&/$FormS (&/$Cons [_ (&/$TagS ?ident)]
-                         ?values))
+      (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))
       (|do [[idx group-count case-type] (resolve-tag ?ident value-type)
             [=test =kont] (case (&/|length ?values)
                             0 (analyse-pattern case-type unit kont)
@@ -240,6 +249,12 @@
         [($TextTotal total? ?values) ($TextTestAC ?value)]
         (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values))))
 
+        [($DefaultTotal total?) ($UnitTestAC)]
+        (return (&/S $UnitTotal nil))
+
+        [($UnitTotal) ($UnitTestAC)]
+        (return (&/S $UnitTotal nil))
+
         [($DefaultTotal total?) ($ProdTestAC ?left ?right)]
         (|do [:let [_default (&/S $DefaultTotal total?)]
               =left (merge-total _default (&/P ?left ?body))
@@ -301,6 +316,9 @@
     ($TextTotal ?total _)
     (return ?total)
 
+    ($UnitTotal)
+    (return true)
+
     ($ProdTotal ?total ?_left ?_right)
     (if ?total
       (return true)
@@ -329,7 +347,7 @@
                          (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.")
 
                          _
-                         (check-totality ?right ($SumTotal ?total ?tail)))]
+                         (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))]
             (return (and =left =right)))
 
           _
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index 696c816e9..b30953f67 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -30,10 +30,10 @@
                                               (->> frame (&/$get-closure) (&/$get-counter))
                                               register))
                         register-type)]
-    (do (prn 'close-over 'updating-closure
-             [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)]
-             [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text)
-              (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)])
+    (do ;; (prn 'close-over 'updating-closure
+        ;;      [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)]
+        ;;      [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text)
+        ;;       (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)])
       ($$ &/P register* (&/$update-closure #(->> %
                                                  (&/$update-counter inc)
                                                  (&/$update-mappings (fn [mps] (&/|put name register* mps))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 909e7e2c4..bc9647f9f 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -349,20 +349,17 @@
                    nil))
         (fail* (str "[Lux Error] Unknown module: " module))))))
 
-(defn tag-index [module tag-name]
-  "(-> Text Text (Lux Int))"
-  (fn [state]
-    (if-let [=module (->> state (&/$get-modules) (&/|get module))]
-      (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
-        (return* state (aget idx+tags 0))
-        (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
-      (fail* (str "[Module Error] Unknown module: " module)))))
-
-(defn tag-group [module tag-name]
-  "(-> Text Text (Lux (List Ident)))"
-  (fn [state]
-    (if-let [=module (->> state (&/$get-modules) (&/|get module))]
-      (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
-        (return* state (aget idx+tags 1))
-        (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
-      (fail* (str "[Module Error] Unknown module: " module)))))
+(do-template [<name> <member> <type>]
+  (defn <name> [module tag-name]
+    <type>
+    (fn [state]
+      (if-let [=module (->> state (&/$get-modules) (&/|get module))]
+        (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))]
+          (|let [[idx tags type] idx+tags]
+            (return* state <member>))
+          (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name)))))
+        (fail* (str "[Module Error] Unknown module: " module)))))
+
+  tag-index idx  "(-> Text Text (Lux Int))"
+  tag-group tags "(-> Text Text (Lux (List Ident)))"
+  )
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 2f0925586..d261145ae 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -21,7 +21,7 @@
 (defmacro deftags [names]
   (assert (vector? names))
   `(do ~@(for [[name idx] (map vector names (range (count names)))]
-           `(def ~(symbol (str "$" name)) ~idx))))
+           `(def ~(symbol (str "$" name)) (int ~idx)))))
 
 (defn ^:private unfold-accesses
   ([elems]
@@ -793,7 +793,7 @@
 
 (defn with-writer [writer body]
   (fn [state]
-    (prn 'with-writer writer body)
+    ;; (prn 'with-writer writer body)
     (let [output (body ($update-host #($set-writer (Some$ writer) %) state))]
       (|case output
         ($Right ?state ?value)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 72d569ed1..e327d1de4 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -94,6 +94,7 @@
 (do-template [<name> <class> <sig> <method>]
   (defn <name> [^MethodVisitor writer]
     (doto writer
+      (.visitTypeInsn Opcodes/CHECKCAST <class>)
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> (str "()" <sig>))))
 
   unwrap-boolean "java/lang/Boolean"   "Z" "booleanValue"
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index b30fcb4f8..0a928a056 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -84,27 +84,36 @@
         (.visitInsn Opcodes/POP)
         (.visitJumpInsn Opcodes/GOTO $target))
 
+      (&a-case/$UnitTestAC)
+      (doto writer
+        (.visitInsn Opcodes/POP)
+        (.visitJumpInsn Opcodes/GOTO $target))
+
       (&a-case/$ProdTestAC left right)
       (let [$post-left (new Label)
-            $post-right (new Label)]
+            $post-right (new Label)
+            $pre-else (new Label)]
         (doto writer
           (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
           (.visitInsn Opcodes/DUP)
           (.visitLdcInsn (int 0))
           (.visitInsn Opcodes/AALOAD)
-          (compile-match left $post-left $else)
+          (compile-match left $post-left $pre-else)
           (.visitLabel $post-left)
           (.visitInsn Opcodes/DUP)
           (.visitLdcInsn (int 1))
           (.visitInsn Opcodes/AALOAD)
-          (compile-match right $post-right $else)
+          (compile-match right $post-right $pre-else)
           (.visitLabel $post-right)
           (.visitInsn Opcodes/POP)
-          (.visitJumpInsn Opcodes/GOTO $target)))
+          (.visitJumpInsn Opcodes/GOTO $target)
+          (.visitLabel $pre-else)
+          (.visitInsn Opcodes/POP)
+          (.visitJumpInsn Opcodes/GOTO $else)))
 
       (&a-case/$SumTestAC ?tag ?count ?test)
       (let [$value-then (new Label)
-            $sum-else (new Label)]
+            $pre-else (new Label)]
         (doto writer
           (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
           (.visitInsn Opcodes/DUP)
@@ -112,15 +121,15 @@
           (.visitInsn Opcodes/AALOAD)
           (&&/unwrap-int)
           (.visitLdcInsn (int ?tag))
-          (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else)
+          (.visitJumpInsn Opcodes/IF_ICMPNE $else)
           (.visitInsn Opcodes/DUP)
           (.visitLdcInsn (int 1))
           (.visitInsn Opcodes/AALOAD)
-          (compile-match ?test $value-then $sum-else)
+          (compile-match ?test $value-then $pre-else)
           (.visitLabel $value-then)
           (.visitInsn Opcodes/POP)
           (.visitJumpInsn Opcodes/GOTO $target)
-          (.visitLabel $sum-else)
+          (.visitLabel $pre-else)
           (.visitInsn Opcodes/POP)
           (.visitJumpInsn Opcodes/GOTO $else)))
       )))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 79383acc0..10ee40839 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -138,7 +138,7 @@
                       (.visitInsn Opcodes/DUP) ;; VV
                       (.visitLdcInsn (int 0)) ;; VVI
                       (.visitLdcInsn &/$TypeD) ;; VVIT
-                      (&&/wrap-long)
+                      (&&/wrap-int)
                       (.visitInsn Opcodes/AASTORE) ;; V
                       (.visitInsn Opcodes/DUP) ;; VV
                       (.visitLdcInsn (int 1)) ;; VVI
@@ -165,7 +165,7 @@
                         (.visitInsn Opcodes/DUP) ;; VV
                         (.visitLdcInsn (int 0)) ;; VVI
                         (.visitLdcInsn &/$ValueD) ;; VVIT
-                        (&&/wrap-long)
+                        (&&/wrap-int)
                         (.visitInsn Opcodes/AASTORE) ;; V
                         (.visitInsn Opcodes/DUP) ;; VV
                         (.visitLdcInsn (int 1)) ;; VVI
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 4193d8df4..91bc6e480 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -548,6 +548,12 @@
 (defn type= [x y]
   (or (clojure.lang.Util/identical x y)
       (let [output (|case [x y]
+                     [(&/$UnitT) (&/$UnitT)]
+                     true
+
+                     [(&/$VoidT) (&/$VoidT)]
+                     true
+
                      [(&/$DataT xname) (&/$DataT yname)]
                      (.equals ^Object xname yname)
 
@@ -704,6 +710,9 @@
   (if (clojure.lang.Util/identical expected actual)
     (return (&/P fixpoints nil))
     (|case [expected actual]
+      [(&/$UnitT) (&/$UnitT)]
+      (return (&/P fixpoints nil))
+
       [(&/$VarT ?eid) (&/$VarT ?aid)]
       (if (.equals ^Object ?eid ?aid)
         (return (&/P fixpoints nil))
@@ -840,7 +849,7 @@
                 (println 'FIXPOINTS (->> (&/|keys fixpoints)
                                          (&/|map (fn [pair]
                                                    (|let [[e a] pair]
-                                                     (str (show-type e) ":+:"
+                                                     (str (show-type e) " :+: "
                                                           (show-type a)))))
                                          (&/|interpose "\n\n")
                                          (&/fold str "")))
@@ -909,6 +918,9 @@
       [_ (&/$NamedT ?aname ?atype)]
       (check* class-loader fixpoints expected ?atype)
 
+      [_ (&/$VoidT)]
+      (return (&/P fixpoints nil))
+
       [_ _]
       (fail (check-error expected actual))
       )))