destructuring :or, fn :pre/:post, deftype field access + map-like dispatch
General fixes shaken out running clojure.core.cache (66 -> 198 of its assertions):
- Map destructuring applied an :or default only for :keys/:strs/:syms, not a
direct {x :x} binding — so {x :x :or {x 9}} (and the & {…} kwargs form) ignored
the default. Apply it for the direct binding too.
- fn didn't implement :pre/:post: a leading conditions map was evaluated as a body
literal (so % was unbound and (.q %) blew up). Recognize it and assert pre
before the body, bind % to the result, assert post, return %.
- (.q inst) on a deftype field with no matching method reads the field, like the
JVM (was "No method q").
- A deftype implementing the clojure.lang collection interfaces now dispatches
dissoc (without), contains? (containsKey), peek/pop (IPersistentStack), and
keys/vals (via its Seqable seq) through its methods — they were field-only, so
core.cache's caches and data.priority-map didn't behave as maps.
JVM-certified corpus rows for each. make test + shakesmoke green.
This commit is contained in:
Yogthos
parent
93b4d101a1
commit
b21b99b275
5 changed files with 342 additions and 273 deletions
|
|
@ -85,17 +85,40 @@
|
|||
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
||||
((jrec? coll) (length (jrec-pairs coll)))
|
||||
(else (%r-jolt-count coll)))))
|
||||
;; contains?: a deftype implementing Associative/containsKey (e.g. core.cache's
|
||||
;; caches) answers through that; a plain defrecord checks its fields.
|
||||
(define %r-jolt-contains? jolt-contains?)
|
||||
(set! jolt-contains? (lambda (coll k) (if (jrec? coll) (jrec-has? coll k) (%r-jolt-contains? coll k))))
|
||||
(set! jolt-contains? (lambda (coll k)
|
||||
(cond ((jrec-cl coll "containsKey") => (lambda (m) (if (jolt-truthy? (jolt-invoke m coll k)) #t #f)))
|
||||
((jrec? coll) (jrec-has? coll k))
|
||||
(else (%r-jolt-contains? coll k)))))
|
||||
(define %r-jolt-assoc1 jolt-assoc1)
|
||||
(set! jolt-assoc1 (lambda (coll k v)
|
||||
(cond ((jrec-cl coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
|
||||
((jrec? coll) (make-jrec (jrec-tag coll) (jrec-replace (jrec-pairs coll) k v)))
|
||||
(else (%r-jolt-assoc1 coll k v)))))
|
||||
;; dissoc: a deftype implementing IPersistentMap/without answers through it; a
|
||||
;; plain defrecord drops the field pair.
|
||||
(define %r-jolt-dissoc jolt-dissoc)
|
||||
(set! jolt-dissoc (lambda (coll . ks)
|
||||
(cond ((jrec-cl coll "without")
|
||||
=> (lambda (m) (fold-left (lambda (c k) (jolt-invoke m c k)) coll ks)))
|
||||
((jrec? coll)
|
||||
(fold-left (lambda (c k) (make-jrec (jrec-tag c)
|
||||
(filter (lambda (p) (not (jolt=2 (car p) k))) (jrec-pairs c))))
|
||||
coll ks))
|
||||
(else (apply %r-jolt-dissoc coll ks)))))
|
||||
;; keys/vals over a jrec read its entry seq (jolt-seq is method-first, so a
|
||||
;; map-like deftype delegates to its Seqable; a defrecord's seq is its fields, so
|
||||
;; the result is unchanged for records).
|
||||
(define (jrec-seq-col m which)
|
||||
(let loop ((s (jolt-seq m)) (acc '()))
|
||||
(if (jolt-nil? s) (list->cseq (reverse acc))
|
||||
(loop (jolt-seq (seq-more s)) (cons (jolt-nth (seq-first s) which) acc)))))
|
||||
(define %r-jolt-keys jolt-keys)
|
||||
(set! jolt-keys (lambda (m) (if (jrec? m) (list->cseq (map car (jrec-pairs m))) (%r-jolt-keys m))))
|
||||
(set! jolt-keys (lambda (m) (if (jrec? m) (jrec-seq-col m 0) (%r-jolt-keys m))))
|
||||
(define %r-jolt-vals jolt-vals)
|
||||
(set! jolt-vals (lambda (m) (if (jrec? m) (list->cseq (map cdr (jrec-pairs m))) (%r-jolt-vals m))))
|
||||
(set! jolt-vals (lambda (m) (if (jrec? m) (jrec-seq-col m 1) (%r-jolt-vals m))))
|
||||
(define %r-jolt-seq jolt-seq)
|
||||
(set! jolt-seq (lambda (x)
|
||||
(cond ((jrec-cl x "seq") => (lambda (m) (jolt-seq (jolt-invoke m x))))
|
||||
|
|
@ -106,6 +129,16 @@
|
|||
(cond ((jrec-cl coll "cons") => (lambda (m) (jolt-invoke m coll x)))
|
||||
((jrec? coll) (jolt-assoc1 coll (jolt-nth x 0) (jolt-nth x 1)))
|
||||
(else (%r-jolt-conj1 coll x)))))
|
||||
;; peek/pop on a deftype implementing IPersistentStack (data.priority-map, which
|
||||
;; core.cache's LRU/LU caches lean on) dispatch to its methods.
|
||||
(define %r-jolt-peek jolt-peek)
|
||||
(set! jolt-peek (lambda (coll)
|
||||
(cond ((jrec-cl coll "peek") => (lambda (m) (jolt-invoke m coll)))
|
||||
(else (%r-jolt-peek coll)))))
|
||||
(define %r-jolt-pop jolt-pop)
|
||||
(set! jolt-pop (lambda (coll)
|
||||
(cond ((jrec-cl coll "pop") => (lambda (m) (jolt-invoke m coll)))
|
||||
(else (%r-jolt-pop coll)))))
|
||||
(register-pr-arm! jrec? jrec-pr)
|
||||
|
||||
;; records are map? and coll? (Clojure: a record IS an associative map). The
|
||||
|
|
@ -359,6 +392,11 @@
|
|||
(jolt-class obj))
|
||||
((and (jrec? obj) (find-method-any-protocol (jrec-tag obj) method-name))
|
||||
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
||||
;; (.field inst): a deftype/record field read with no matching method.
|
||||
;; Clojure reads the field for (.q x) just like (.-q x); a declared method
|
||||
;; (above) wins, this is the field-accessor fallback.
|
||||
((and (jrec? obj) (null? rest) (jrec-has? obj (keyword #f method-name)))
|
||||
(jrec-lookup obj (keyword #f method-name) jolt-nil))
|
||||
((reified-methods obj)
|
||||
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
|
||||
(if f (apply jolt-invoke f obj rest) (error #f (string-append "No method " method-name))))))
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -255,7 +255,13 @@
|
|||
(and kns (= kn "strs")) (group a (get pat k) :str kns)
|
||||
(and kns (= kn "syms")) (group a (get pat k) :sym kns)
|
||||
:else a))
|
||||
(proc k `(get ~gm ~(get pat k)) a)))
|
||||
;; a direct binding {x :x}: apply its :or default
|
||||
;; (keyed by the local symbol) when the key is absent.
|
||||
(let* [fo (if (symbol? k) (find-or or-map (name k)) [false nil])]
|
||||
(proc k (if (nth fo 0)
|
||||
`(get ~gm ~(get pat k) ~(nth fo 1))
|
||||
`(get ~gm ~(get pat k)))
|
||||
a))))
|
||||
g3 (keys pat)))
|
||||
:else (throw (str "unsupported destructuring pattern: " (pr-str pat)))))
|
||||
ploop
|
||||
|
|
@ -315,6 +321,21 @@
|
|||
(if (if (seq? x) (= 'with-meta (first x)) false)
|
||||
(nth x 1)
|
||||
x))
|
||||
;; a :pre/:post conditions map (a leading map when the body has more forms
|
||||
;; after it) becomes assertions: pre before the body, then bind % to the
|
||||
;; result, post after, return %. (map? is a native, so this is tier-safe;
|
||||
;; the assert/map calls only run when a conditions map is actually present.)
|
||||
wrap-conds
|
||||
(fn* [body]
|
||||
(if (if (map? (first body)) (next body) false)
|
||||
(let [conds (first body)
|
||||
real (next body)
|
||||
mka (fn* [cs] (map (fn* [c] `(assert ~c)) cs))]
|
||||
`(~@(mka (get conds :pre))
|
||||
(let [~'% (do ~@real)]
|
||||
~@(mka (get conds :post))
|
||||
~'%)))
|
||||
body))
|
||||
md (fn* go [ps nps lets]
|
||||
(if (seq ps)
|
||||
(if (symbol? (first ps))
|
||||
|
|
@ -327,8 +348,11 @@
|
|||
mk (fn* [sig]
|
||||
(let [ps (unhint (first sig))
|
||||
hinted (not (= ps (first sig)))
|
||||
r (md (seq ps) [] [])]
|
||||
(if (if (empty? (nth r 1)) (not hinted) false)
|
||||
r (md (seq ps) [] [])
|
||||
raw-body (rest sig)
|
||||
body (wrap-conds raw-body)
|
||||
conds? (not (= body raw-body))]
|
||||
(if (if (empty? (nth r 1)) (if (not hinted) (not conds?) false) false)
|
||||
sig
|
||||
;; build the params/let vectors via [~@..] so they are tuple forms
|
||||
;; (the accumulators are plain seqs, the wrong representation).
|
||||
|
|
@ -337,8 +361,8 @@
|
|||
(let [pv `[~@(nth r 0)]
|
||||
lv `[~@(nth r 1)]]
|
||||
(if (empty? (nth r 1))
|
||||
`(~pv ~@(rest sig))
|
||||
`(~pv (let ~lv ~@(rest sig))))))))]
|
||||
`(~pv ~@body)
|
||||
`(~pv (let ~lv ~@body)))))))]
|
||||
(if (vector? (unhint (first aftn)))
|
||||
(let [a (mk aftn)]
|
||||
(if nm `(fn* ~nm ~@a) `(fn* ~@a)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,11 @@
|
|||
[
|
||||
{:suite "destructure / :or" :label "map default when key absent" :expected "9" :actual "(let [{x :x :or {x 9}} {}] x)"}
|
||||
{:suite "destructure / :or" :label "kwargs default when key absent" :expected "9" :actual "((fn [& {x :x :or {x 9}}] x))"}
|
||||
{:suite "destructure / :or" :label "default not used when key present" :expected "5" :actual "(let [{x :x :or {x 9}} {:x 5}] x)"}
|
||||
{:suite "deftype / field access" :label ".field reads a deftype field" :expected "7" :actual "(do (deftype FldT [q]) (.q (->FldT 7)))"}
|
||||
{:suite "fn / pre-post" :label ":pre + :post pass" :expected "5" :actual "(do (defn ppf [x] {:pre [(pos? x)] :post [(= % x)]} x) (ppf 5))"}
|
||||
{:suite "fn / pre-post" :label ":pre failure throws" :expected ":blocked" :actual "(do (defn ppg [x] {:pre [(pos? x)]} x) (try (ppg -1) (catch Throwable _ :blocked)))"}
|
||||
{:suite "deftype / map-like dispatch" :label "dissoc + keys via IPersistentMap/Seqable methods" :expected "[:b]" :actual "(do (deftype MapT [m] clojure.lang.Seqable (seq [_] (seq m)) clojure.lang.IPersistentMap (without [_ k] (->MapT (dissoc m k))) (assoc [_ k v] (->MapT (assoc m k v)))) (vec (keys (dissoc (->MapT {:a 1 :b 2}) :a))))"}
|
||||
{:suite "interop / Class.forName" :label "unknown class throws ClassNotFoundException" :expected ":nf" :actual "(try (Class/forName \"no.such.Klass\") (catch ClassNotFoundException _ :nf))"}
|
||||
{:suite "interop / Class.forName" :label "known class resolves" :expected "\"java.lang.String\"" :actual "(.getName (Class/forName \"java.lang.String\"))"}
|
||||
{:suite "clojure.string / replace" :label "char match and replacement" :expected "\"a-b-c\"" :actual "(clojure.string/replace \"a/b/c\" \\/ \\-)"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue