Fix "if", cleanup clj-kondo warnings, pointless indirection

.vscode/settings.json

@@ -0,0 +1,14 @@
+{
+    "calva.replConnectSequences": [
+        {
+            "name": "Experiment",
+            "autoSelectForJackIn": true,
+            "projectType": "shadow-cljs",
+            "cljsType": "shadow-cljs",
+            "menuSelections": {
+                "cljsDefaultBuild": "experiment",
+                "cljsLaunchBuilds": ["experiment"]
+            }
+        }
+    ]
+}

src/main/tock/compiler.cljc

@@ -49,8 +49,8 @@
         (typecheck specials)
         (collect-definitions program))))
 
-(defn compile 
+(defn compile-wasm
-  ([forms] (compile forms specials))
+  ([forms] (compile-wasm forms specials))
   ([forms specials]
    (-> (reduce compile-form (make-empty-program specials) forms)
        generate-wasm)))

src/main/tock/compiler/bind.cljc

@@ -1,7 +1,7 @@
 (ns tock.compiler.bind
   (:require [meander.epsilon :as m]
             [tock.compiler.util :refer [get-special new-scope bind! lookup]]
-            [tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield]]))
+            [tock.compiler.meander :refer [bottom-up all-subexpressions merge-metafield]]))
 
 (defn decorate-ctx [specials ctx form]
   (let [special (get-special specials form)

src/main/tock/compiler/desugar.cljc

@@ -1,7 +1,6 @@
 (ns tock.compiler.desugar
   (:require [meander.epsilon :as m]
             [meander.strategy.epsilon :as r]
-            [tock.compiler.specials :refer [specials]]
             [tock.compiler.meander :refer [parse-type to-sym label]]))
 
 (def leaf-pass
@@ -23,35 +22,32 @@
       ; [vectors] and {maps} are _not_ expressions and are parsed by special form's desugaring only
     ?syntax ?syntax)))
 
-(defn make-desugar-pass [specials]
+(defn desugar-pass [form specials]
-  (let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))]
+  (let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))
-    (r/until =
+        pass (r/until =
-             (r/rewrite
+                      (r/rewrite
-              ((m/cata ?special) ?m . (m/cata !args) ...)
+                       ((m/cata ?special) ?m . (m/cata !args) ...)
-              (m/app desugar-strat (?special ?m . !args ...))
+                       (m/app desugar-strat (?special ?m . !args ...))
              
-              ?form ?form))))
+                       ?form ?form))]
+    (pass form)))
 
-(defn make-call-pass [specials]
+(defn call-pass [form specials]
-  (let [special? (fn [key] (and (symbol? key) (contains? specials key)))]
+  (let [special? (fn [key] (and (symbol? key) (contains? specials key)))
-    (r/rewrite
+        pass (r/rewrite
-     (m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/lookup {:name ?sym & ?m})
+              (m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/lookup {:name ?sym & ?m})
              
-     ((m/pred special? ?special) ?m . (m/cata !args) ...)
+              ((m/pred special? ?special) ?m . (m/cata !args) ...)
-     (?special ?m . !args ...)
+              (?special ?m . !args ...)
              
-     ((m/cata ?func) ?m . (m/cata !args) ...)
+              ((m/cata ?func) ?m . (m/cata !args) ...)
-     ('l/call ?m (label ?func "function") . (label !args "argument") ...)
+              ('l/call ?m (label ?func "function") . (label !args "argument") ...)
              
-     ?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"}))))
+              ?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"}))]
+    (pass form)))
 
-(defn desugar 
+(defn desugar [form specials]
-  ([form] (desugar form specials))
+  (-> form
-  ([form specials]
+      leaf-pass
-   (let [desugar-pass (make-desugar-pass specials)
+      (desugar-pass specials)
-         call-pass (make-call-pass specials)]
+      (call-pass specials)))
-     (-> form
-         leaf-pass
-         desugar-pass
-         call-pass
-         ))))

src/main/tock/compiler/meander.cljc

@@ -10,6 +10,8 @@
     (list? form)   (apply list (first form) (merge (second form) m) (rest (rest form)))
     :else (do (print "m+ " form meta "\n") form)))
 
+(declare m+ label typed)
+
 (m/defsyntax m+ 
   [meta-pattern pattern]
   (case (::r.syntax/phase &env)

src/main/tock/compiler/specials.cljc

@@ -2,7 +2,8 @@
   (:require [meander.epsilon :as m]
             [meander.strategy.epsilon :as r]
             [helins.wasm.bin :as op]
-            [tock.compiler.meander :refer [parse-type to-sym label m+]]))
+            [tock.compiler.meander :refer [parse-type to-sym label m+]]
+            [tock.compiler.wasm :refer [type-to-wasmtype]]))
 
 ;; no namespace - source symbol
 ;; l/sym - "lowered" form - special form not directly writable from source
@@ -45,7 +46,7 @@
             (m/match form
               ('l/if {:type ?type} ?cond ?l ?r)
               (concat (emit ?cond)
-                      [[op/if- [:wasm/valtype ?type] (emit ?l) (emit ?r)]])))}
+                      [[op/if- [:wasm/valtype (type-to-wasmtype ?type)] (emit ?l) (emit ?r)]])))}
 
    'l/fn
    {:desugar (r/rewrite

src/main/tock/compiler/util.cljc

@@ -1,9 +1,5 @@
 (ns tock.compiler.util)
 
-(defn compile-error [term message]
-  ; todo: extract location of error term
-  (js/Error. [term message]))
-
 ; ctx is a vector of atoms of maps
 (defn new-scope
   ([ctx base] (conj ctx (atom base)))

src/main/tock/experiment.cljs

@@ -1,24 +1,25 @@
 (ns tock.experiment
   (:require [helins.wasm :as wasm]
             [helins.binf :as binf]
-            [tock.compiler :refer [compile]]
+            [tock.compiler :refer [compile-wasm]]))
-            [cljs.pprint :as pp]))
 
 
-;; ; https://github.com/kalai-transpiler/kalai
 
 (def test-wasm
-  (compile 
+  (compile-wasm
    '[(fn add [^f64 left ^f64 right -> f64] (+ left right))
      (fn double [^f64 val -> f64] (* val 2))
-     (fn add_double [^f64 left ^f64 right -> f64] (double (add left right)))]))
+     (fn add_double [^bool add-first? ^f64 left ^f64 right -> f64] 
+       (if add-first?
+         (double (add left right))
+         (add (double left) right)))]))
 
-(defn decompile-url [url]
+;; (defn decompile-url [url]
-  (-> (js/fetch url)
+;;   (-> (js/fetch url)
-      (.then #(.arrayBuffer %))
+;;       (.then #(.arrayBuffer %))
-      (.then #(let [v (binf/view %)]
+;;       (.then #(let [v (binf/view %)]
-                (binf/endian-set v :little-endian)
+;;                 (binf/endian-set v :little-endian)
-                (wasm/decompile v)))))
+;;                 (wasm/decompile v)))))
 
 (defn instantiate-wasm [wasm importObject]
   (-> (wasm/compile wasm)
@@ -29,7 +30,7 @@
 (defn main []
   (js/console.log test-wasm)
   (-> (instantiate-wasm test-wasm #js {})
-      (.then #(js/console.log (-> % (.-instance) (.-exports) (.add-double 2 3)))))
+      (.then (fn [^js x] (js/console.log (-> x (.-instance) (.-exports) (.add-double false 2 3))))))
   ;; (-> (decompile-url "release.wasm")
   ;;     (.then #(js/console.log (-> % :wasm/exportsec :wasm.export/func (get 0)))))
   )