Merge pull request #65 from jolt-lang/bug-batch

core: three bug fixes — ifn?, prefer-method dispatch, reader comments in map values

jolt-core/clojure/core/20-coll.clj

@@ -838,3 +838,10 @@
      ([x y z] (f (g x y z)))
      ([x y z & args] (f (apply g x y z args)))))
   ([f g & fs] (reduce comp (comp f g) fs)))
+
+;; Canonical IFn set (jolt-1vx): fns, keywords, symbols, maps (sorted incl.),
+;; sets, vectors, and vars — NOT lists ((ifn? '(1 2)) is false in Clojure).
+;; Mutable-mode caveat: vectors and lists share the array representation
+;; there, so vector? can't separate them and lists read as ifn?.
+(defn ifn? [x]
+  (or (fn? x) (keyword? x) (symbol? x) (map? x) (set? x) (vector? x) (var? x)))

jolt-core/clojure/core/30-macros.clj

@@ -45,6 +45,11 @@
 (defmacro methods [mm]
   `(methods-setup (quote ~mm)))
 
+;; prefers reads the store off the VAR (the multifn value can't carry it) —
+;; same symbol-passing shape as the other multimethod table ops.
+(defmacro prefers [mm]
+  `(prefers-setup (quote ~mm)))
+
 ;; instance?: class names don't evaluate to values on jolt, so the type arg is
 ;; passed quoted to the ctx-capturing checker; the value evaluates normally.
 (defmacro instance? [t x]

src/jolt/core.janet

@@ -2379,9 +2379,8 @@
 
 # Associative = maps and (real) vectors only. pvec is a literal/built vector;
 # tuples and lists are seq results, not associative.
-(defn core-ifn? [x]
+# ifn? now lives in the Clojure collection tier — canonical IFn set (fns,
-  (or (function? x) (cfunction? x) (keyword? x) (phm? x) (set? x) (tuple? x) (array? x) (pvec? x)
+# keywords, symbols, maps, sets, vectors, vars); lists are NOT IFn.
-      (and (struct? x) (= :symbol (x :jolt/type)))))
 # With a single item, Clojure returns it WITHOUT calling f. On ties, the last
 # extremal item wins (>=/<= update), matching Clojure.
 # Clojure's min-key/max-key: the 2-arg base compares with strict < / > (so the
@@ -2644,7 +2643,7 @@
 (defn core-hash-unordered-coll [coll]
   (var h 0) (each x (realize-for-iteration coll) (set h (band (+ h (h24 x)) 0xffffff))) h)
 
-(defn core-prefers [mm-var] (or (get mm-var :jolt/prefers) {}))
+# prefers is a macro over prefers-setup now (the store lives on the VAR).
 
 
 
@@ -2778,7 +2777,6 @@
     "hash-combine" core-hash-combine
     "hash-ordered-coll" core-hash-ordered-coll
     "hash-unordered-coll" core-hash-unordered-coll
-    "prefers" core-prefers
     "gensym" gensym
     "int?" core-integer?
     "compare" core-compare
@@ -2807,7 +2805,6 @@
     "reduced" core-reduced
     "reduced?" core-reduced?
     "rseq" core-rseq
-    "ifn?" core-ifn?
     "ex-info" core-ex-info
     "__with-out-str" core-with-out-str
     "delay?" core-delay?

src/jolt/evaluator.janet

@@ -887,6 +887,8 @@
   (def methods @{})
   (def isa-cache @[nil])
   (def dispatch-cache @{})
+  # the prefers table, shared with the var (prefer-method-setup mutates it)
+  (def v-box @[nil])
   (def mm-fn
     (fn [& args]
       (let [dv (apply dispatch-fn args)
@@ -909,13 +911,39 @@
                           (hierarchy :value)
                           hierarchy)
                         nil)
-                    found (do (var f nil) (var i 0)
+                    # Collect EVERY isa-matching method key, then pick the
-                            (let [ks (keys methods)]
+                    # dominant one: x dominates y when x is prefer-method'd
-                              (while (and (nil? f) (< i (length ks)))
+                    # over y (direct preference) or (isa? x y). Two matches
-                                (if (if h (isa-fn h dv (in ks i)) (isa-fn dv (in ks i)))
+                    # with no dominant is an ambiguity ERROR, as in Clojure —
-                                  (set f (get methods (in ks i))))
+                    # this used to silently take whichever key the table
-                                (++ i)))
+                    # yielded first, ignoring prefer-method (jolt-heo).
-                            f)]
+                    found (do
+                            (def matches @[])
+                            (each k (keys methods)
+                              (when (if h (isa-fn h dv k) (isa-fn dv k))
+                                (array/push matches k)))
+                            (defn pref? [x y]
+                              (def px (get (or (get v-box 0) @{}) x))
+                              (and px (not (nil? (get px y)))))
+                            (defn dom? [x y]
+                              (or (pref? x y) (if h (isa-fn h x y) (isa-fn x y))))
+                            (case (length matches)
+                              0 nil
+                              1 (get methods (in matches 0))
+                              (do
+                                (var best (in matches 0))
+                                (var i 1)
+                                (while (< i (length matches))
+                                  (when (dom? (in matches i) best) (set best (in matches i)))
+                                  (++ i))
+                                (var amb nil)
+                                (each k matches
+                                  (when (and (nil? amb) (not (deep= k best)) (not (dom? best k)))
+                                    (set amb k)))
+                                (when amb
+                                  (error (string "Multiple methods in multimethod '" (name-sym :name)
+                                                 "' match dispatch value — neither is preferred")))
+                                (get methods best))))]
                 (if found
                   (do (put dispatch-cache dv found) (apply found args))
                   (let [dm (get methods default-key)]
@@ -923,6 +951,11 @@
                       (error (string "No method in multimethod " (name-sym :name)
                                      " for dispatch value: " dv))))))))))))
   (def v (ns-intern ns (name-sym :name) mm-fn))
+  # pre-create the prefers store so the dispatch closure and
+  # prefer-method-setup share one table
+  (def prefs-tbl (or (get v :jolt/prefers)
+                     (do (put v :jolt/prefers @{}) (get v :jolt/prefers))))
+  (put v-box 0 prefs-tbl)
   (put v :jolt/methods methods)
   (put v :jolt/dispatch-cache dispatch-cache)
   (put v :jolt/default default-key)
@@ -1090,7 +1123,10 @@
       (def mm-var (mm-var-of mm-sym true))
       (def prefs (or (get mm-var :jolt/prefers)
                      (do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers))))
-      (put prefs dval-a dval-b)
+      # {x -> {y true ...}}: x is preferred over each y (Clojure's {x #{y}})
+      (def sub (or (get prefs dval-a)
+                   (do (put prefs dval-a @{}) (get prefs dval-a))))
+      (put sub dval-b true)
       (clear-dispatch-cache! mm-var)
       mm-var))
   (ns-intern core "remove-method-setup"
@@ -1108,6 +1144,10 @@
         (put mm-var :jolt/methods @{})
         (clear-dispatch-cache! mm-var))
       mm-var))
+  (ns-intern core "prefers-setup"
+    (fn [mm-sym]
+      (def mm-var (mm-var-of mm-sym false))
+      (or (and mm-var (get mm-var :jolt/prefers)) {})))
   (ns-intern core "get-method-setup"
     (fn [mm-sym dval]
       (def mm-var (mm-var-of mm-sym false))

src/jolt/reader.janet

@@ -291,15 +291,29 @@
             (if (and (struct? key) (= :jolt/splice (key :jolt/type)))
               (read-kvs s new-pos (array/concat kvs (key :items)))
               (let [pos (skip-whitespace s new-pos)
-                    [val new-pos2] (read-form s pos)]
+                    # The VALUE slot must skip comments/#_ while KEEPING the
-                (if (and (struct? val) (= :jolt/skip (val :jolt/type)))
+                    # pending key: dropping both (the old behavior) desynced
-                  (read-kvs s new-pos2 kvs)
+                    # the kv pairing — {:a ; comment\n 1} read 1 as the next
-                  (if (and (struct? val) (= :jolt/splice (val :jolt/type)))
+                    # KEY and the closing } landed in value position
+                    # ("Unmatched closing brace", jolt-ou8 / Selmer deps.edn).
+                    [val new-pos2]
+                    (do
+                      (var vp pos)
+                      (var v nil)
+                      (var looking true)
+                      (while looking
+                        (def [f np] (read-form s vp))
+                        (set vp np)
+                        (if (and (struct? f) (= :jolt/skip (f :jolt/type)))
+                          (set vp (skip-whitespace s np))
+                          (do (set v f) (set looking false))))
+                      [v vp])]
+                (if (and (struct? val) (= :jolt/splice (val :jolt/type)))
                     # Only push key if splice contributes items
                     (if (> (length (val :items)) 0)
                       (do (array/push kvs key) (read-kvs s new-pos2 (array/concat kvs (val :items))))
                       (read-kvs s new-pos2 kvs))
-                    (read-kvs s new-pos2 (-> kvs (array/push key) (array/push val))))))))))))
+                    (read-kvs s new-pos2 (-> kvs (array/push key) (array/push val)))))))))))
   (read-kvs s (+ pos 1) @[]))
 
 (defn read-set [s pos]

test/integration/conformance-test.janet

@@ -129,6 +129,10 @@
    ["native bit-not"       "-6"  "(bit-not 5)"]
    ["native shifts"        "[16 2]" "[(bit-shift-left 4 2) (bit-shift-right 8 2)]"]
 
+   ### ---- multimethod preferences (jolt-heo) ----
+   ["prefer-method breaks tie" ":rect"
+    "(do (derive :cm/sq :cm/rect) (derive :cm/sq :cm/shape) (defmulti cmf identity) (defmethod cmf :cm/rect [x] :rect) (defmethod cmf :cm/shape [x] :shape) (prefer-method cmf :cm/rect :cm/shape) (cmf :cm/sq))"]
+
    ### ---- HIGH: str semantics ----
    ["str nil empty"      "\"\""       "(str nil)"]
    ["str concat nil"     "\"a1\""     "(str \"a\" 1 nil)"]
@@ -171,8 +175,9 @@
    ["remove-method"      "nil"   "(do (defmulti t6g :k) (defmethod t6g :b [x] 2) (remove-method t6g :b) (get (methods t6g) :b))"]
    ["remove-all-methods" "nil"   "(do (defmulti t6h :k) (defmethod t6h :c [x] 3) (remove-all-methods t6h) (get (methods t6h) :c))"]
    # NOTE: dispatch does not yet CONSULT prefers in ambiguous isa dispatch
-   # (jolt-bug filed) — this asserts prefer-method records the preference.
+   # prefer-method records {x -> set-of-dominated} (Clojure's {x #{y}} shape;
-   ["prefer-method records" ":shape" "(do (defmulti t6p identity) (prefer-method t6p :rect :shape) (get (get (var t6p) :jolt/prefers) :rect))"]
+   # jolt-heo upgraded the store from single-value and dispatch consults it).
+   ["prefer-method records" "true" "(do (defmulti t6p identity) (prefer-method t6p :rect :shape) (contains? (get (prefers t6p) :rect) :shape))"]
    ["instance? deftype"  "true"  "(do (deftype T6i [a]) (instance? T6i (->T6i 1)))"]
    ["instance? String"   "true"  "(instance? String \"s\")"]
    ["locking evals body" "3"     "(locking :anything (+ 1 2))"]

test/spec/multimethods-spec.janet

@@ -30,3 +30,19 @@
    "(do (defmulti classify :type :default :other) (defmethod classify :a [_] :alpha) (defmethod classify :other [_] :unknown) (classify {:type :zzz}))"]
   ["explicit :hierarchy"  "\"a\""
    "(do (def h (derive (make-hierarchy) ::dog ::animal)) (defmulti snd identity :hierarchy h) (defmethod snd ::animal [_] \"a\") (snd ::dog))"])
+
+# prefer-method breaks isa-dispatch ties; ambiguity without a preference is
+# an ERROR (jolt-heo — this used to silently take an arbitrary method).
+(defspec "multimethods / prefer-method"
+  ["preference picks the winner" ":rect"
+   "(do (derive :p/sq :p/rect) (derive :p/sq :p/shape) (defmulti pm1 identity) (defmethod pm1 :p/rect [x] :rect) (defmethod pm1 :p/shape [x] :shape) (prefer-method pm1 :p/rect :p/shape) (pm1 :p/sq))"]
+  ["reverse preference" ":shape"
+   "(do (derive :q/sq :q/rect) (derive :q/sq :q/shape) (defmulti pm2 identity) (defmethod pm2 :q/rect [x] :rect) (defmethod pm2 :q/shape [x] :shape) (prefer-method pm2 :q/shape :q/rect) (pm2 :q/sq))"]
+  ["ambiguity throws" :throws
+   "(do (derive :r/sq :r/rect) (derive :r/sq :r/shape) (defmulti pm3 identity) (defmethod pm3 :r/rect [x] :rect) (defmethod pm3 :r/shape [x] :shape) (pm3 :r/sq))"]
+  ["isa dominance needs no preference" ":child"
+   "(do (derive :s/c :s/p) (defmulti pm4 identity) (defmethod pm4 :s/c [x] :child) (defmethod pm4 :s/p [x] :parent) (pm4 :s/c))"]
+  ["prefers map shape" "true"
+   "(do (defmulti pm5 identity) (defmethod pm5 :a [x] 1) (defmethod pm5 :b [x] 2) (prefer-method pm5 :a :b) (contains? (get (prefers pm5) :a) :b))"]
+  ["exact match needs no preference" ":exact"
+   "(do (derive :t/sq :t/rect) (defmulti pm6 identity) (defmethod pm6 :t/sq [x] :exact) (defmethod pm6 :t/rect [x] :parent) (pm6 :t/sq))"])

test/spec/predicates-spec.janet

@@ -184,3 +184,19 @@
   ["int? Inf false"     "false" "(int? ##Inf)"]
   ["integer? Inf false" "false" "(integer? ##Inf)"]
   ["integer? NaN false" "false" "(integer? ##NaN)"])
+
+# ifn? is the canonical IFn set (jolt-1vx): lists are NOT IFn.
+(defspec "predicates / ifn?"
+  ["fn"        "true"  "(ifn? inc)"]
+  ["keyword"   "true"  "(ifn? :k)"]
+  ["symbol"    "true"  "(ifn? (quote s))"]
+  ["map"       "true"  "(ifn? {})"]
+  ["sorted map" "true" "(ifn? (sorted-map))"]
+  ["set"       "true"  "(ifn? #{1})"]
+  ["vector"    "true"  "(ifn? [1])"]
+  ["var"       "true"  "(ifn? (var first))"]
+  ["list NOT"  "false" "(ifn? (list 1 2))"]
+  ["lazy NOT"  "false" "(ifn? (map inc [1]))"]
+  ["string NOT" "false" "(ifn? \"s\")"]
+  ["number NOT" "false" "(ifn? 5)"]
+  ["nil NOT"   "false" "(ifn? nil)"])

test/spec/reader-syntax-spec.janet

@@ -58,3 +58,15 @@
   ["tagged literal var" "true"      "(var? #'+)"]
   ["deref sugar"        "5"         "(let [a (atom 5)] @a)"]
   ["meta sugar"         "{:t 1}"    "(meta ^{:t 1} [])"])
+
+# Comments and #_ discards in a map's VALUE slot keep the pending key
+# (jolt-ou8: dropping both desynced kv pairing — Selmer's deps.edn, with a
+# "; for development (REPL, etc)" comment between key and value, read its
+# closing brace in value position: 'Unmatched closing brace').
+(defspec "reader / comments inside maps"
+  ["comment in value slot"   "{:a 1}"  "{:a ; note\n 1}"]
+  ["comment before key"      "{:a 1}"  "{; lead\n :a 1}"]
+  ["comment between entries" "{:a 1 :b 2}" "{:a 1 ; mid\n :b 2}"]
+  ["discard in value slot"   "{:a 1}"  "{:a #_9 1}"]
+  ["comment with parens"     "{:a {:b 1}}" "{:a ; dev (REPL, etc)\n {:b 1}}"]
+  ["nested with comments"    "{:x {:y 2}}" "{:x ; outer\n {:y ; inner\n 2}}"])