core: three bug fixes — ifn?, prefer-method dispatch, reader comments in map values
ifn? (jolt-1vx) is the canonical IFn set in the overlay: fns, keywords,
symbols, maps (sorted included), sets, vectors, and vars — NOT lists. The
seed version said true for lists and false for struct maps and vars.
Mutable-mode caveat documented (vectors and lists share the array repr
there). 13 predicate rows.
Multimethod dispatch (jolt-heo) now collects EVERY isa-matching method key
and picks the dominant one — x dominates y when prefer-method'd over it or
(isa? x y) — and two matches with no dominant is an ambiguity ERROR, as in
Clojure. It used to take whichever key the table yielded first, silently
ignoring prefer-method. The prefers store upgrades to Clojure's
{x -> set-of-dominated} shape, shared between the dispatch closure and
prefer-method-setup via the var; prefers becomes a macro over a setup fn
(the store lives on the VAR — the multifn value can't carry it, so the old
fn read {} forever). 6 multimethod rows + the conformance row updated to
the canonical shape (335x3).
The reader (jolt-ou8) kept the pending KEY when a comment or #_ sits in a
map's VALUE slot: the old code dropped both, desyncing kv pairing — the
real value became the next key and the closing brace landed in value
position ('Unmatched closing brace'). Selmer's deps.edn (a '; for
development (REPL, etc)' comment between key and value) now parses; 6
reader rows incl. nested commented maps.
Gate: jpm exit 0, conformance 335x3, all tests passed.
This commit is contained in:
Yogthos
parent
19606730a3
commit
c06af7c9f4
9 changed files with 133 additions and 21 deletions
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
(or (function? x) (cfunction? x) (keyword? x) (phm? x) (set? x) (tuple? x) (array? x) (pvec? x)
|
||||
(and (struct? x) (= :symbol (x :jolt/type)))))
|
||||
# ifn? now lives in the Clojure collection tier — canonical IFn set (fns,
|
||||
# keywords, symbols, maps, sets, vectors, vars); lists are NOT IFn.
|
||||
# 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?
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(let [ks (keys methods)]
|
||||
(while (and (nil? f) (< i (length ks)))
|
||||
(if (if h (isa-fn h dv (in ks i)) (isa-fn dv (in ks i)))
|
||||
(set f (get methods (in ks i))))
|
||||
(++ i)))
|
||||
f)]
|
||||
# Collect EVERY isa-matching method key, then pick the
|
||||
# dominant one: x dominates y when x is prefer-method'd
|
||||
# over y (direct preference) or (isa? x y). Two matches
|
||||
# with no dominant is an ambiguity ERROR, as in Clojure —
|
||||
# this used to silently take whichever key the table
|
||||
# yielded first, ignoring prefer-method (jolt-heo).
|
||||
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))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
(if (and (struct? val) (= :jolt/skip (val :jolt/type)))
|
||||
(read-kvs s new-pos2 kvs)
|
||||
(if (and (struct? val) (= :jolt/splice (val :jolt/type)))
|
||||
# The VALUE slot must skip comments/#_ while KEEPING the
|
||||
# pending key: dropping both (the old behavior) desynced
|
||||
# the kv pairing — {:a ; comment\n 1} read 1 as the next
|
||||
# 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]
|
||||
|
|
|
|||
|
|
@ -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" ":shape" "(do (defmulti t6p identity) (prefer-method t6p :rect :shape) (get (get (var t6p) :jolt/prefers) :rect))"]
|
||||
# prefer-method records {x -> set-of-dominated} (Clojure's {x #{y}} shape;
|
||||
# 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))"]
|
||||
|
|
|
|||
|
|
@ -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))"])
|
||||
|
|
|
|||
|
|
@ -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)"])
|
||||
|
|
|
|||
|
|
@ -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}}"])
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue