[Bugs]

- Fixed the errors in the compiler due to its restructuring as monadic code.
- Fixed a bug in the analyser where 'case' forms has "Nothing" as their type.
[Refactor]
- Now there only one way to raise/fold lambda-bodies.

2 files changed, 170 insertions, 201 deletions

diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 14bb533dc..d44c333b1 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -14,6 +14,8 @@
 ;; [Util]
 (def +int-class+ "java.lang.Integer")
 
+(def +dont-care-type+ [::&type/object "java.lang.Object" []])
+
 (defn ^:private annotated [form type]
   {:form form
    :type type})
@@ -411,7 +413,7 @@
   (exec [[=test] (analyse-ast ?test)
          [=then] (analyse-ast ?then)
          [=else] (analyse-ast ?else)]
-    (return (list (annotated [::if =test =then =else] ::&type/nothing)))))
+    (return (list (annotated [::if =test =then =else] +dont-care-type+)))))
 
 (defn ^:private analyse-do [analyse-ast ?exprs]
   (exec [=exprs (do-all-m* (map analyse-ast ?exprs))]
@@ -646,7 +648,7 @@
                                                                  ))
                                                              (partition 2 ?branches))]
                                        (return (->decision-tree $scope $base =branches)))]
-      (return (list (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing))))))
+      (return (list (annotated [::case (dec $base) =variant registers mappings tree] +dont-care-type+))))))
 
 (defn ^:private analyse-let [analyse-ast ?label ?value ?body]
   (exec [[=value] (analyse-ast ?value)
@@ -655,53 +657,82 @@
                    (analyse-ast ?body))]
     (return (list (annotated [::let idx ?label =value =body] (:type =body))))))
 
-(declare raise-bindings)
-(defn ^:private raise-tree-bindings [outer-scope ?tree]
-  (case (:type ?tree)
-    ::adt*
-    (update-in ?tree [:patterns]
-               #(into {} (for [[?tag ?unapply] %
-                               :let [=unapply (update-in ?unapply [:parts] (partial map (partial raise-tree-bindings outer-scope)))]]
-                           [?tag =unapply])))
-    
-    ::defaults
-    (update-in ?tree [:stores]
-               #(into {} (for [[?store ?branches] %
-                               :let [=store (raise-bindings outer-scope {:form ?store :type ::&type/nothing})]]
-                           [(:form =store) ?branches])))
-    ;; else
-    (assert false (pr-str ?tree))
-    ))
+(defn ^:private raise-tree-bindings [raise-expr outer-scope ?tree]
+  (let [partial-f (partial raise-expr outer-scope)
+        tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+    (case (:type ?tree)
+      ::adt*
+      (update-in ?tree [:patterns]
+                 #(into {} (for [[?tag ?unapply] %]
+                             [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
+      
+      ::defaults
+      (update-in ?tree [:stores]
+                 #(into {} (for [[?store ?branches] %
+                                 :let [=store (partial-f {:form ?store :type ::&type/nothing})]]
+                             [(:form =store) ?branches])))
+      ;; else
+      (assert false (pr-str ?tree))
+      )))
 
-(defn ^:private raise-bindings [outer-scope body]
+(defn ^:private raise-expr [outer-scope syntax]
   ;; (prn 'raise-bindings body)
-  (match (:form body)
-    [::local ?scope ?idx]
-    {:form [::local outer-scope (inc ?idx)]
-     :type (:type body)}
-    
-    [::captured _ _ ?source]
-    ?source
-
-    [::jvm:iadd ?x ?y]
-    {:form [::jvm:iadd
-            (raise-bindings outer-scope ?x)
-            (raise-bindings outer-scope ?y)]
-     :type (:type body)}
-
-    [::case ?base ?variant ?registers ?mappings ?tree]
-    (let [=variant (raise-bindings outer-scope ?variant)
-          =mappings (into {} (for [[idx syntax] ?mappings]
-                               [idx (raise-bindings outer-scope syntax)]))
-          =tree (raise-tree-bindings outer-scope ?tree)]
-      {:form [::case ?base =variant ?registers =mappings =tree]
-       :type (:type body)})
-
-    [::call ?func ?args]
-    {:form [::call (raise-bindings outer-scope ?func)
-            (map (partial raise-bindings outer-scope) ?args)]
-     :type (:type body)}
-    ))
+  (let [partial-f (partial raise-expr outer-scope)
+        tree-partial-f (partial raise-tree-bindings raise-expr outer-scope)]
+    (match (:form syntax)
+      [::literal ?value]
+      syntax
+      
+      [::tuple ?members]
+      {:form [::tuple (map partial-f ?members)]
+       :type (:type syntax)}
+
+      [::variant ?tag ?members]
+      {:form [::variant ?tag (map partial-f ?members)]
+       :type (:type syntax)}
+      
+      [::local ?scope ?idx]
+      {:form [::local outer-scope (inc ?idx)]
+       :type (:type syntax)}
+      
+      [::captured _ _ ?source]
+      ?source
+
+      [::self ?self-name ?curried]
+      {:form [::self outer-scope (mapv partial-f ?curried)]
+       :type (:type syntax)}
+
+      [::jvm:iadd ?x ?y]
+      {:form [::jvm:iadd (partial-f ?x) (partial-f ?y)]
+       :type (:type syntax)}
+
+      [::let ?idx ?name ?value ?body]
+      {:form [::let ?idx ?name (partial-f ?value) (partial-f ?body)]
+       :type (:type syntax)}
+
+      [::case ?base ?variant ?registers ?mappings ?tree]
+      (let [=variant (partial-f ?variant)
+            =mappings (into {} (for [[idx syntax] ?mappings]
+                                 [idx (partial-f syntax)]))
+            =tree (tree-partial-f ?tree)]
+        {:form [::case ?base =variant ?registers =mappings =tree]
+         :type (:type syntax)})
+
+      [::lambda ?scope ?captured ?args ?value]
+      {:form [::lambda outer-scope
+              (into {} (for [[?name ?sub-syntax] ?captured]
+                         [?name (partial-f ?sub-syntax)]))
+              ?args
+              ?value]
+       :type (:type syntax)}
+
+      [::call ?func ?args]
+      {:form [::call (partial-f ?func) (map partial-f ?args)]
+       :type (:type syntax)}
+
+      _
+      (assert false (pr-str (:form syntax)))
+      )))
 
 (defn ^:private analyse-lambda [analyse-ast ?self ?arg ?body]
   (exec [[_ =arg =return :as =function] (within ::types &type/fresh-function)
@@ -717,8 +748,7 @@
          :let [;; _ (prn '(:form =body) (:form =body))
                =lambda (match (:form =body)
                     [::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body]
-                    (let [?sub-body* (raise-bindings =scope ?sub-body)]
-                      [::lambda =scope =captured (cons ?arg ?sub-args) ?sub-body*])
+                    [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr =scope ?sub-body)]
 
                     _
                     [::lambda =scope =captured (list ?arg) =body])]
@@ -726,72 +756,6 @@
          ]
     (return (list (annotated =lambda =function)))))
 
-(declare ->def-lambda)
-(defn ^:private ->def-lambda-tree [old-scope new-scope ?tree]
-  (case (:type ?tree)
-    ::adt*
-    (update-in ?tree [:patterns]
-               #(into {} (for [[?tag ?unapply] %
-                               :let [=unapply (update-in ?unapply [:parts] (partial map (partial ->def-lambda-tree old-scope new-scope)))]]
-                           [?tag =unapply])))
-    
-    ::defaults
-    (update-in ?tree [:stores]
-               #(into {} (for [[?store ?branches] %
-                               :let [=store (->def-lambda old-scope new-scope {:form ?store :type ::&type/nothing})]]
-                           [(:form =store) ?branches])))
-    ;; else
-    (assert false (pr-str ?tree))
-    ))
-
-(defn ^:private ->def-lambda [old-scope new-scope syntax]
-  (match (:form syntax)
-    [::literal _]
-    syntax
-
-    [::variant ?tag ?elems]
-    {:form [::variant ?tag (map (partial ->def-lambda old-scope new-scope) ?elems)]
-     :type (:type syntax)}
-    
-    [::local ?local-scope ?idx]
-    {:form [::local new-scope (inc ?idx)]
-     :type (:type syntax)}
-
-    [::self ?self-name ?curried]
-    (if (= ?self-name old-scope)
-      {:form [::self new-scope (mapv (partial ->def-lambda old-scope new-scope) ?curried)]
-       :type (:type syntax)}
-      syntax)
-    
-
-    [::jvm:iadd ?x ?y]
-    {:form [::jvm:iadd (->def-lambda old-scope new-scope ?x) (->def-lambda old-scope new-scope ?y)]
-     :type (:type syntax)}
-
-    [::case ?base ?variant ?registers ?mappings ?tree]
-    (let [=variant (->def-lambda old-scope new-scope ?variant)
-          =mappings (into {} (for [[idx syntax] ?mappings]
-                               [idx (->def-lambda old-scope new-scope syntax)]))
-          =tree (->def-lambda-tree old-scope new-scope ?tree)]
-      {:form [::case ?base =variant ?registers =mappings =tree]
-       :type (:type syntax)})
-
-    [::call ?func ?args]
-    {:form [::call (->def-lambda old-scope new-scope ?func)
-            (map (partial ->def-lambda old-scope new-scope) ?args)]
-     :type (:type syntax)}
-    
-    [::lambda ?scope ?captured ?args ?value]
-    {:form [::lambda new-scope
-            (into {} (for [[?name ?sub-syntax] ?captured]
-                       [?name (->def-lambda old-scope new-scope ?sub-syntax)]))
-            ?args
-            ?value]
-     :type (:type syntax)}
-    
-    _
-    (assert false (pr-str (:form syntax)))))
-
 (defn ^:private analyse-def [analyse-ast ?name ?value]
   (exec [def?? (defined? ?name)]
     (if def??
@@ -802,9 +766,10 @@
                         (analyse-ast ?value))
              ;; :let [_ (prn 'DEF/PRE =value)]
              :let [;; _ (prn 'analyse-def/=value =value)
+                   new-scope [$module ?name]
                    =value (match (:form =value)
-                            [::lambda ?scope ?env ?args ?body]
-                            {:form [::lambda ?scope ?env ?args (->def-lambda ?scope [$module ?name] ?body)]
+                            [::lambda ?old-scope ?env ?args ?body]
+                            {:form [::lambda new-scope ?env ?args (raise-expr new-scope ?body)]
                              :type (:type =value)}
                             
                             _
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index e9a445510..f6daaca0f 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -161,22 +161,23 @@
 
 (defn ^:private compile-tuple [compile *type* ?elems]
   (exec [*writer* get-writer
-         :let [_ (let [num-elems (count ?elems)]
-                   (let [tuple-class (str (str +prefix+ "/Tuple") num-elems)]
-                     (doto *writer*
-                       (.visitTypeInsn Opcodes/NEW tuple-class)
-                       (.visitInsn Opcodes/DUP)
-                       (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))
-                     (dotimes [idx num-elems]
-                       (.visitInsn *writer* Opcodes/DUP)
-                       (compile (nth ?elems idx))
-                       (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" (inc idx)) "Ljava/lang/Object;"))))]]
+         :let [num-elems (count ?elems)
+               tuple-class (str (str +prefix+ "/Tuple") num-elems)
+               _ (doto *writer*
+                   (.visitTypeInsn Opcodes/NEW tuple-class)
+                   (.visitInsn Opcodes/DUP)
+                   (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))]
+         _ (map-m (fn [idx]
+                    (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
+                           ret (compile (nth ?elems idx))
+                           :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" (inc idx)) "Ljava/lang/Object;")]]
+                      (return ret)))
+                  (range num-elems))]
     (return nil)))
 
 (defn ^:private compile-local [compile *type* ?env ?idx]
   (exec [*writer* get-writer
-         :let [_ (doto *writer*
-                   (.visitVarInsn Opcodes/ALOAD (int ?idx)))]]
+         :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]]
     (return nil)))
 
 (defn ^:private compile-captured [compile *type* ?scope ?captured-id ?source]
@@ -191,8 +192,7 @@
 
 (defn ^:private compile-global [compile *type* ?owner-class ?name]
   (exec [*writer* get-writer
-         :let [_ (doto *writer*
-                   (.visitFieldInsn Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;"))]]
+         :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;")]]
     (return nil)))
 
 (defn ^:private compile-global-fn [compile *type* ?owner-class ?name]
@@ -247,8 +247,7 @@
 
 (defn ^:private compile-jvm-getstatic [compile *type* ?owner ?field]
   (exec [*writer* get-writer
-         :let [_ (doto *writer*
-                   (.visitFieldInsn Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*)))]]
+         :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?owner) ?field (->java-sig *type*))]]
     (return nil)))
 
 (defn prepare-arg! [*writer* class-name]
@@ -310,30 +309,32 @@
 
 (defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
   (exec [*writer* get-writer
-         :let [_ (let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
-                   (compile ?object)
-                   (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))
-                   (doseq [[class-name arg] (map vector ?classes ?args)]
-                     (do (compile arg)
-                       (prepare-arg! *writer* class-name)))
-                   (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
-                   (prepare-return! *writer* *type*)
-                   )]]
+         :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+         _ (compile ?object)
+         :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
+         _ (map-m (fn [[class-name arg]]
+                    (exec [ret (compile arg)
+                           :let [_ (prepare-arg! *writer* class-name)]]
+                      (return ret)))
+                  (map vector ?classes ?args))
+         :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
+                   (prepare-return! *writer* *type*))]]
     (return nil)))
 
 (defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args]
   (exec [*writer* get-writer
-         :let [_ (let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
-                       class* (->class ?class)]
-                   (doto *writer*
-                     (.visitTypeInsn Opcodes/NEW class*)
-                     (.visitInsn Opcodes/DUP))
-                   (doseq [[class-name arg] (map vector ?classes ?args)]
-                     (do (compile arg)
-                       (prepare-arg! *writer* class-name)))
-                   (doto *writer*
-                     (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))
-                   )]]
+         :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
+               class* (->class ?class)
+               _ (doto *writer*
+                   (.visitTypeInsn Opcodes/NEW class*)
+                   (.visitInsn Opcodes/DUP))]
+         _ (map-m (fn [[class-name arg]]
+                    (exec [ret (compile arg)
+                           :let [_ (prepare-arg! *writer* class-name)]]
+                      (return ret)))
+                  (map vector ?classes ?args))
+         :let [_ (doto *writer*
+                   (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
     (return nil)))
 
 (defn ^:private compile-jvm-new-array [compile *type* ?class ?length]
@@ -345,18 +346,18 @@
 
 (defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem]
   (exec [*writer* get-writer
+         _ (compile ?array)
          :let [_ (doto *writer*
-                   (do (compile ?array))
                    (.visitInsn Opcodes/DUP)
-                   (.visitLdcInsn (int ?idx))
-                   (do (compile ?elem))
-                   (.visitInsn Opcodes/AASTORE))]]
+                   (.visitLdcInsn (int ?idx)))]
+         _ (compile ?elem)
+         :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
     (return nil)))
 
 (defn ^:private compile-jvm-aaload [compile *type* ?array ?idx]
   (exec [*writer* get-writer
+         _ (compile ?array)
          :let [_ (doto *writer*
-                   (do (compile ?array))
                    (.visitLdcInsn (int ?idx))
                    (.visitInsn Opcodes/AALOAD))]]
     (return nil)))
@@ -364,27 +365,29 @@
 (let [+bool-class+ (->class "java.lang.Boolean")]
   (defn ^:private compile-if [compile *type* ?test ?then ?else]
     (exec [*writer* get-writer
-           :let [_ (let [else-label (new Label)
-                         end-label (new Label)]
-                     (compile ?test)
-                     (doto *writer*
-                       (.visitTypeInsn Opcodes/CHECKCAST +bool-class+)
-                       (.visitMethodInsn Opcodes/INVOKEVIRTUAL +bool-class+ "booleanValue" "()Z")
-                       (.visitJumpInsn Opcodes/IFEQ else-label))
-                     (compile ?then)
-                     (doto *writer*
-                       (.visitJumpInsn Opcodes/GOTO end-label)
-                       (.visitLabel else-label))
-                     (compile ?else)
-                     (.visitLabel *writer* end-label))]]
+           :let [else-label (new Label)
+                 end-label (new Label)]
+           _ (compile ?test)
+           :let [_ (doto *writer*
+                     (.visitTypeInsn Opcodes/CHECKCAST +bool-class+)
+                     (.visitMethodInsn Opcodes/INVOKEVIRTUAL +bool-class+ "booleanValue" "()Z")
+                     (.visitJumpInsn Opcodes/IFEQ else-label))]
+           _ (compile ?then)
+           :let [_ (doto *writer*
+                     (.visitJumpInsn Opcodes/GOTO end-label)
+                     (.visitLabel else-label))]
+           _ (compile ?else)
+           :let [_ (.visitLabel *writer* end-label)]]
       (return nil))))
 
 (defn ^:private compile-do [compile *type* ?exprs]
   (exec [*writer* get-writer
-         :let [_ (do (doseq [expr (butlast ?exprs)]
-                       (compile expr)
-                       (.visitInsn *writer* Opcodes/POP))
-                   (compile (last ?exprs)))]]
+         _ (map-m (fn [expr]
+                    (exec [ret (compile expr)
+                           :let [_ (.visitInsn *writer* Opcodes/POP)]]
+                      (return ret)))
+                  (butlast ?exprs))
+         _ (compile (last ?exprs))]
     (return nil)))
 
 (let [+tag-sig+ (->type-signature "java.lang.String")
@@ -633,16 +636,16 @@
 
 (defn ^:private compile-let [compile *type* ?idx ?label ?value ?body]
   (exec [*writer* get-writer
-         :let [_ (let [start-label (new Label)
-                       end-label (new Label)
-                       ?idx (int ?idx)]
-                   (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)
-                   (compile ?value)
-                   (doto *writer*
-                     (.visitVarInsn Opcodes/ASTORE ?idx)
-                     (.visitLabel start-label))
-                   (compile ?body)
-                   (.visitLabel *writer* end-label))]]
+         :let [start-label (new Label)
+               end-label (new Label)
+               ?idx (int ?idx)
+               _ (.visitLocalVariable *writer* (normalize-ident ?label) (->java-sig (:type ?value)) nil start-label end-label ?idx)]
+         _ (compile ?value)
+         :let [_ (doto *writer*
+                   (.visitVarInsn Opcodes/ASTORE ?idx)
+                   (.visitLabel start-label))]
+         _ (compile ?body)
+         :let [_ (.visitLabel *writer* end-label)]]
     (return nil)))
 
 (defn compile-field [compile ?name body]
@@ -874,7 +877,7 @@
              (compile-method compile ?name ?value)
 
              _
-             (compile-field  compile ?name ?value))]
+             (compile-field compile ?name ?value))]
     (return nil)))
 
 (defn ^:private compile-defclass [compile *type* ?package ?name ?super-class ?members]
@@ -919,19 +922,20 @@
 
 (defn ^:private compile-variant [compile *type* ?tag ?members]
   (exec [*writer* get-writer
-         :let [_ (let [variant-class* (str (->class +variant-class+) (count ?members))]
-                   (doto *writer*
-                     (.visitTypeInsn Opcodes/NEW variant-class*)
-                     (.visitInsn Opcodes/DUP)
-                     (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
-                     (.visitInsn Opcodes/DUP)
-                     (.visitLdcInsn ?tag)
-                     (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String"))
-                     (-> (doto (.visitInsn Opcodes/DUP)
-                           (do (compile ?member))
-                           (.visitFieldInsn Opcodes/PUTFIELD variant-class* (str "_" (inc ?tfield)) "Ljava/lang/Object;"))
-                         (->> (doseq [[?tfield ?member] (mapv vector (range (count ?members)) ?members)]))))
-                   )]]
+         :let [variant-class* (str (->class +variant-class+) (count ?members))
+               _ (doto *writer*
+                   (.visitTypeInsn Opcodes/NEW variant-class*)
+                   (.visitInsn Opcodes/DUP)
+                   (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V")
+                   (.visitInsn Opcodes/DUP)
+                   (.visitLdcInsn ?tag)
+                   (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String")))]
+         _ (map-m (fn [[?tfield ?member]]
+                    (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)]
+                           ret (compile ?member)
+                           :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str "_" (inc ?tfield)) "Ljava/lang/Object;")]]
+                      (return ret)))
+                  (map vector (range (count ?members)) ?members))]
     (return nil)))
 
 (let [+int-class+ (->class "java.lang.Integer")]
@@ -958,7 +962,7 @@
     ^:private compile-jvm-irem Opcodes/IREM
     ))
 
-(defn compile-self-call [?scope ?assumed-args]
+(defn compile-self-call [compile ?scope ?assumed-args]
   (exec [*writer* get-writer
          :let [lambda-class (->class (reduce str "" (interpose "$" (map normalize-ident ?scope))))
                _ (doto *writer*
@@ -1058,7 +1062,7 @@
     (compile-defclass compile (:type syntax) ?package ?name ?super-class ?members)
 
     [::&analyser/self ?scope ?assumed-args]
-    (compile-self-call ?scope ?assumed-args)
+    (compile-self-call compile ?scope ?assumed-args)
     ))
 
 ;; [Interface]