Add multimethods as opt-in runtime

defmulti, defmethod, hierarchy ops (isa?, derive, underive, parents,
ancestors, descendants, make-hierarchy), and method-table ops
(get-method, methods, remove-method, prefer-method, prefers) live in a
new src/squint/multi.js module, imported only when one of those forms
appears in user code — programs that don't use multimethods pay zero
bundle cost.

Author: borkdude

package.json

@@ -11,6 +11,7 @@
     "src/squint/set.js",
     "src/squint/html.js",
     "src/squint/math.js",
+    "src/squint/multi.js",
     "src/squint/test.js",
     "lib",
     "node_cli.js",
@@ -61,6 +62,7 @@
     "./src/squint/string.js": "./src/squint/string.js",
     "./node-api.js": "./node-api.js",
     "./src/squint/html.js": "./src/squint/html.js",
+    "./src/squint/multi.js": "./src/squint/multi.js",
     "./src/squint/test.js": "./src/squint/test.js"
   }
 }

src/squint/compiler.cljc

@@ -24,6 +24,7 @@
    [squint.internal.fn :refer [core-defmacro core-defn core-defn- core-fn]]
    [squint.internal.loop :as loop]
    [squint.internal.macros :as macros]
+   [squint.internal.multi :as multi]
    [squint.internal.protocols :as protocols]
    [squint.internal.test :as test])
   #?(:cljs (:require-macros [squint.resource :refer [edn-resource]])))
@@ -103,7 +104,22 @@
                              'assoc macros/assoc-inline
                              'assoc! macros/assoc!-inline
                              'get macros/get-inline
-                             'vswap! macros/vswap!}
+                             'vswap! macros/vswap!
+                             'defmulti multi/core-defmulti
+                             'defmethod multi/core-defmethod
+                             'get-method multi/core-get-method
+                             'methods multi/core-methods
+                             'remove-method multi/core-remove-method
+                             'remove-all-methods multi/core-remove-all-methods
+                             'prefer-method multi/core-prefer-method
+                             'prefers multi/core-prefers
+                             'isa? multi/core-isa?
+                             'derive multi/core-derive
+                             'underive multi/core-underive
+                             'make-hierarchy multi/core-make-hierarchy
+                             'parents multi/core-parents
+                             'ancestors multi/core-ancestors
+                             'descendants multi/core-descendants}
                             cc/common-macros))
 
 (def built-in-macro-nss
@@ -452,6 +468,7 @@
                cc/*repl* (:repl opts cc/*repl*)]
        (let [core-package (get import-maps cc/*core-package* cc/*core-package*)
              need-html-import (atom false)
+             need-multi-import (atom false)
              opts (merge {:ns-state (atom {})
                           :top-level true} opts)
              imported-vars (atom {})
@@ -478,7 +495,8 @@
                                                         :imports imports
                                                         :jsx false
                                                         :pragmas pragmas
-                                                        :need-html-import need-html-import))
+                                                        :need-html-import need-html-import
+                                                        :need-multi-import need-multi-import))
                  jsx *jsx*
                  _ (when (and jsx jsx-runtime)
                      (swap! imports str
@@ -500,6 +518,13 @@
                                 (if cc/*repl*
                                   (format "var squint_html = await import('%s');\n" html-pkg)
                                   (format "import * as squint_html from '%s';\n" html-pkg)))))
+                 _ (when @need-multi-import
+                     (swap! imports str
+                            (let [multi-pkg "squint-cljs/src/squint/multi.js"
+                                  multi-pkg (get import-maps multi-pkg multi-pkg)]
+                                (if cc/*repl*
+                                  (format "var squint_multi = await import('%s');\n" multi-pkg)
+                                  (format "import * as squint_multi from '%s';\n" multi-pkg)))))
                  pragmas (:js @pragmas)
                  imports (when-not elide-imports @imports)
                  exports (when-not elide-exports

src/squint/internal/multi.cljc

@@ -0,0 +1,96 @@
+(ns squint.internal.multi
+  (:refer-clojure :exclude [defmulti defmethod remove-method
+                            prefer-method prefers methods get-method
+                            remove-all-methods
+                            isa? derive underive make-hierarchy
+                            parents ancestors descendants])
+  (:require [clojure.core :as core]
+            [clojure.string :as str]))
+
+(core/defn- flag! [env]
+  (when-let [atm (:need-multi-import env)]
+    (reset! atm true)))
+
+(core/defn- multi-call [js-name args]
+  (let [tmpl (str "squint_multi." js-name "("
+                  (str/join ", " (repeat (count args) "~{}"))
+                  ")")]
+    `(~'js* ~tmpl ~@args)))
+
+(core/defn core-defmulti
+  "(defmulti name dispatch-fn) or
+   (defmulti name docstring? attr-map? dispatch-fn & options)"
+  [_&form env mm-name & args]
+  (flag! env)
+  (let [[args docstring] (if (string? (first args))
+                           [(next args) (first args)]
+                           [args nil])
+        [args attr-map] (if (map? (first args))
+                          [(next args) (first args)]
+                          [args nil])
+        dispatch-fn (first args)
+        opts (apply hash-map (next args))
+        opts-js (cond-> {}
+                  (contains? opts :default) (assoc "default" (:default opts))
+                  (contains? opts :hierarchy) (assoc "hierarchy" (:hierarchy opts)))
+        m (merge (if docstring {:doc docstring} {}) attr-map)
+        mm-name* (if (seq m) (with-meta mm-name m) mm-name)]
+    `(def ~mm-name* ~(multi-call "defmulti" [(str mm-name) dispatch-fn opts-js]))))
+
+(core/defn core-defmethod
+  "(defmethod multifn dispatch-val [args*] body)"
+  [_&form env multifn dispatch-val & fn-tail]
+  (flag! env)
+  (multi-call "defmethod" [multifn dispatch-val `(fn ~@fn-tail)]))
+
+(core/defn core-get-method [_&form env mf dv]
+  (flag! env)
+  (multi-call "get_method" [mf dv]))
+
+(core/defn core-methods [_&form env mf]
+  (flag! env)
+  (multi-call "methods" [mf]))
+
+(core/defn core-remove-method [_&form env mf dv]
+  (flag! env)
+  (multi-call "remove_method" [mf dv]))
+
+(core/defn core-remove-all-methods [_&form env mf]
+  (flag! env)
+  (multi-call "remove_all_methods" [mf]))
+
+(core/defn core-prefer-method [_&form env mf a b]
+  (flag! env)
+  (multi-call "prefer_method" [mf a b]))
+
+(core/defn core-prefers [_&form env mf]
+  (flag! env)
+  (multi-call "prefers" [mf]))
+
+(core/defn core-isa? [_&form env & args]
+  (flag! env)
+  (multi-call "isa_QMARK_" args))
+
+(core/defn core-derive [_&form env & args]
+  (flag! env)
+  (multi-call "derive" args))
+
+(core/defn core-underive [_&form env & args]
+  (flag! env)
+  (multi-call "underive" args))
+
+(core/defn core-make-hierarchy [_&form env]
+  (flag! env)
+  (multi-call "make_hierarchy" []))
+
+(core/defn core-parents [_&form env & args]
+  (flag! env)
+  (multi-call "parents" args))
+
+(core/defn core-ancestors [_&form env & args]
+  (flag! env)
+  (multi-call "ancestors" args))
+
+(core/defn core-descendants [_&form env & args]
+  (flag! env)
+  (multi-call "descendants" args))