Emit JVM-compatible case* from case macro

The case macro now expands to (let* [G e] (case* G shift mask default imap ...))
matching JVM Clojure's format. This enables code-walking tools like riddley
and cloverage that have a case-handler expecting the JVM case* structure.

Author: borkdude

CHANGELOG.md

@@ -12,6 +12,7 @@ SCI is used in [babashka](https://github.com/babashka/babashka),
 
 ## Unreleased
 
+- `case` now macroexpands to JVM-compatible `case*` format, enabling tools like riddley and cloverage to work with SCI
 - Fix `.method` on class objects (e.g. `(.getDeclaredField String "value")`) routing to static instead of instance method path
 - Support [#564](https://github.com/babashka/sci/issues/564): `this-as` in ClojureScript
 

src/sci/impl/analyzer.cljc

@@ -839,43 +839,20 @@
       (throw-error-with-location "Too many arguments to if" expr))))
 
 (defn analyze-case*
+  ;; JVM case* format: (case* ge shift mask default imap switch-type check-type skip-check)
+  ;; imap: {key [test-constant result-expr], ...}
   [ctx expr]
-  (let [ctx-wo-rt (without-recur-target ctx)
-        case-val (analyze ctx-wo-rt (second expr))
-        clauses (nnext expr)
-        match-clauses (take-nth 2 clauses)
-        result-clauses (analyze-children ctx (take-nth 2 (rest clauses)))
-        [default? case-default] (when (odd? (count clauses))
-                                  [true (analyze ctx (last clauses))])
-        cases (interleave match-clauses result-clauses)
-        assoc-new (fn [m k v]
-                    (if-not (contains? m k)
-                      (assoc m k v)
-                      (throw-error-with-location (str "Duplicate case test constant " k)
-                                                 expr)))
-        case-map (loop [cases (seq cases)
-                        ret-map {}]
-                   (if cases
-                     (let [[k v & cases] cases]
-                       (if (seq? k)
-                         (recur
-                          cases
-                          (reduce (fn [acc k]
-                                    (assoc-new acc k v))
-                                  ret-map
-                                  k))
-                         (recur
-                          cases
-                          (assoc-new ret-map k v))))
-                     ret-map))
-        f (if default?
-            (sci.impl.types/->Node
-             (eval/eval-case ctx bindings case-map case-val case-default)
-             nil)
-            (sci.impl.types/->Node
-             (eval/eval-case ctx bindings case-map case-val)
-             nil))]
-    f))
+  (let [[_ ge _shift _mask default imap] expr
+        ctx-wo-rt (without-recur-target ctx)
+        case-val (analyze ctx-wo-rt ge)
+        case-default (analyze ctx default)
+        case-map (reduce-kv
+                   (fn [m _k [test result]]
+                     (assoc m test (analyze ctx result)))
+                   {} imap)]
+    (sci.impl.types/->Node
+     (eval/eval-case ctx bindings case-map case-val case-default)
+     nil)))
 
 (defn analyze-try
   [ctx expr]
@@ -1457,8 +1434,7 @@
     def (analyze-def ctx expr)
     loop* (analyze-loop* ctx expr)
     if (return-if ctx expr)
-    ;; case macro expands into case* with no changes via fast-path
-    (case case*) (analyze-case* ctx expr)
+    case* (analyze-case* ctx expr)
     try (analyze-try ctx expr)
     throw (analyze-throw ctx expr)
     expand-dot* (expand-dot* ctx expr)

src/sci/impl/copy_vars.cljc

@@ -46,7 +46,6 @@
           inline (contains? inlined-vars sym)
           fast-path (or (= 'or sym)
                         (= 'and sym)
-                        (= 'case sym)
                         (= 'ns sym)
                         (= 'lazy-seq sym))
           varm (merge (cond-> {:name (or nm (list 'quote (symbol (name sym))))}

src/sci/impl/namespaces.cljc

@@ -999,8 +999,34 @@
       (if and# (and ~@next) and#))))
 
 (defn case**
-  "This is a macro for compatiblity. Only there for docs and macroexpand, faster impl in analyzer.cljc"
-  [_ _ & body] `(case* ~@body))
+  [_ _ e & clauses]
+  (let [ge (gensym)
+        ex-class #?(:clj 'java.lang.IllegalArgumentException :cljs 'js/Error)
+        default (if (odd? (count clauses))
+                  (last clauses)
+                  `(throw (new ~ex-class (str "No matching clause: " ~ge))))
+        clauses (if (odd? (count clauses)) (butlast clauses) clauses)
+        pairs (partition 2 clauses)
+        expanded (mapcat (fn [[test expr]]
+                           (if (seq? test)
+                             (map (fn [t] [t expr]) test)
+                             [[test expr]]))
+                         pairs)
+        imap (loop [expanded (seq expanded)
+                    imap {}
+                    seen #{}
+                    i 0]
+               (if expanded
+                 (let [[test expr] (first expanded)]
+                   (when (contains? seen test)
+                     (throw (#?(:clj IllegalArgumentException. :cljs js/Error.)
+                             (str "Duplicate case test constant: " test))))
+                   (recur (next expanded)
+                          (assoc imap i [test expr])
+                          (conj seen test)
+                          (inc i)))
+                 imap))]
+    `(let* [~ge ~e] (case* ~ge 0 0 ~default ~imap :sparse :hash-equiv nil))))
 
 (defn loaded-libs** [syms]
   (utils/dynamic-var

src/sci/impl/utils.cljc

@@ -213,7 +213,7 @@
 
 (def ana-macros
   '#{do if and or fn fn* def defn
-     lazy-seq case try defmacro
+     lazy-seq try defmacro
      expand-dot* expand-constructor new . import in-ns ns var
      set! resolve})
 

test/sci/core_test.cljc

@@ -828,6 +828,15 @@
   (catch java.lang.IllegalArgumentException e
     (throw (Exception. (ex-message e)))))")
           :cljs (eval* "(case (inc 2), 1 true, 2 (+ 1 2 3))"))))
+  (testing "case macroexpands to JVM-compatible case*"
+    (let [expanded (eval* "(macroexpand '(case x 1 :a 2 :b :default))")]
+      (is (= 'let* (first expanded)))
+      (let [body (nth expanded 2)]
+        (is (= 'case* (first body)))
+        ;; imap is 5th element: {key [test-constant result-expr], ...}
+        (let [imap (nth body 5)]
+          (is (map? imap))
+          (is (every? (fn [[_k v]] (and (vector? v) (= 2 (count v)))) imap))))))
   #?(:clj
      (testing "case generated by macro"
        (is (= :yolo