Merge pull request #208 from jolt-lang/fix/destructure-or-prepost-deftype-dispatch

Destructuring :or, fn :pre/:post, deftype field access + map-like dispatch

host/chez/records.ss

@@ -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))))))

jolt-core/clojure/core/00-syntax.clj

@@ -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) [] [])]
+                   r (md (seq ps) [] [])
-               (if (if (empty? (nth r 1)) (not hinted) false)
+                   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 ~@body)
-                     `(~pv (let ~lv ~@(rest sig))))))))]
+                     `(~pv (let ~lv ~@body)))))))]
     (if (vector? (unhint (first aftn)))
       (let [a (mk aftn)]
         (if nm `(fn* ~nm ~@a) `(fn* ~@a)))

test/chez/corpus.edn

@@ -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\" \\/ \\-)"}