Merge pull request #258 from jolt-lang/conformance/data-priority-map

data.priority-map: deftype interop fixes (rseq, arity-overload, empty, Sorted)

docs/libraries.md

@@ -63,6 +63,8 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
 * [data.csv](https://github.com/clojure/data.csv) — reading and writing CSV.
 * [data.codec](https://github.com/clojure/data.codec) — base64 encode/decode over
   byte arrays.
+* [data.priority-map](https://github.com/clojure/data.priority-map) — priority
+  maps (incl. keyfn / custom comparator), with `subseq`/`rsubseq`.
 * [test.check](https://github.com/clojure/test.check) — property-based testing
   (generators, `quick-check`, shrinking).
 * [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`;

host/chez/java/dot-forms.ss

@@ -96,9 +96,21 @@
         ;; (.getClass x) universal — the class token for any value, before the
         ;; collection/map field-lookup arms below would read it as a missing key.
         ((string=? method-name "getClass") (jolt-class obj))
+        ;; a deftype/record's OWN declared method (matched by name AND arity) wins
+        ;; over the generic collection interop below — e.g. data.priority-map
+        ;; declares both seq[this] (Seqable) and seq[this ascending] (Sorted), and
+        ;; (.seq pm false) must reach the 2-arg one, not dot-coll's plain seq.
+        ((and (not field?) (jrec? obj)
+              (find-method-any-protocol-arity (jrec-tag obj) mname (+ 1 (length rest))))
+         => (lambda (f) (apply jolt-invoke f obj rest)))
         ;; collection interop first (entry count / seq / nth / get / containsKey).
         ((and (dot-coll? obj) (dot-coll-method obj mname rest))
          => (lambda (box) (car box)))
+        ;; clojure.lang.Sorted (comparator / entryKey / seqFrom) on a sorted
+        ;; map/set, before the map arm below reads the method name as a key.
+        ;; data.priority-map's subseq/rsubseq reach for these.
+        ((and (not field?) (htable-sorted? obj) (sorted-iface-method? mname))
+         (sorted-iface-dispatch obj mname rest))
         ;; (.-field obj) / (. obj -field): field read on a record or map.
         (field? (jolt-get obj (keyword #f mname) jolt-nil))
         ;; non-record map: a universal object-method (getMessage/...) wins first,

host/chez/java/host-static.ss

@@ -56,6 +56,40 @@
 
 ;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
 ;; through the tag's method table.
+;; clojure.lang.Sorted on jolt's sorted-map / sorted-set: comparator / entryKey /
+;; seqFrom / seq. data.priority-map's subseq/rsubseq reach for these (its
+;; PersistentPriorityMap delegates .comparator to the backing sorted-map). The
+;; comparator is returned as a small Comparator object whose .compare runs the
+;; map's 3-way fn, since (.. sc comparator (compare a b)) is the calling form.
+(define sorted-cmp-kw (keyword #f "cmp"))
+(register-host-methods! "jolt-comparator"
+  (list (cons "compare" (lambda (self a b) (jolt-invoke (jhost-state self) a b)))))
+(define (sorted-comparator-of sc)
+  (let ((c (jolt-ref-get sc sorted-cmp-kw)))
+    (make-jhost "jolt-comparator" (if (jolt-nil? c) jolt-compare c))))
+(define (sorted-iface-method? m)
+  (or (string=? m "comparator") (string=? m "entryKey")
+      (string=? m "seqFrom") (string=? m "seq")))
+(define (sorted-iface-dispatch obj method rest)
+  (cond
+    ((string=? method "comparator") (sorted-comparator-of obj))
+    ((string=? method "entryKey") (jolt-first (car rest)))   ; map entry -> its key
+    ((string=? method "seq")                                 ; (.seq sc) or (.seq sc ascending?)
+     (if (or (null? rest) (jolt-truthy? (car rest))) (jolt-seq obj) (jolt-rseq obj)))
+    ;; (.seqFrom sc k ascending?) — the entries from k onward, in order. Done with a
+    ;; comparator filter over the seq (jolt has no tree cursor), like subseq.
+    ((string=? method "seqFrom")
+     (let* ((k (car rest)) (asc (jolt-truthy? (cadr rest)))
+            (cmp (jolt-ref-get obj sorted-cmp-kw))
+            (cmpf (if (jolt-nil? cmp) jolt-compare cmp))
+            (es (seq->list (jolt-seq obj)))
+            (keep (filter (lambda (e)
+                            (let ((c (jnum->exact (jolt-invoke cmpf (jolt-first e) k))))
+                              (if asc (>= c 0) (<= c 0))))
+                          es)))
+       (list->cseq (if asc keep (reverse keep)))))
+    (else (error #f (string-append "No method " method " on sorted collection")))))
+
 (define %hs-record-method-dispatch record-method-dispatch)
 (set! record-method-dispatch
   (lambda (obj method-name rest-args)

host/chez/natives-seq.ss

@@ -224,9 +224,14 @@
 
 ;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
 (define (jolt-rseq coll)
-  (if (or (pvec? coll) (htable-sorted? coll))
-      (list->cseq (reverse (seq->list (jolt-seq coll))))
-      (jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
+  (cond
+    ((or (pvec? coll) (htable-sorted? coll))
+     (list->cseq (reverse (seq->list (jolt-seq coll)))))
+    ;; a deftype/record implementing clojure.lang.Reversible (rseq) — e.g.
+    ;; data.priority-map — drives rseq through its own method.
+    ((and (jrec? coll) (find-method-any-protocol (jrec-tag coll) "rseq"))
+     => (lambda (f) (jolt-invoke f coll)))
+    (else (jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map))))))
 (def-var! "clojure.core" "rseq" jolt-rseq)
 
 ;; clojure.core/unchecked-* — host-defined wrapping (Java long) arithmetic from

host/chez/records.ss

@@ -441,9 +441,28 @@
               (and (pair? protos)
                    (let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
                      (or f (loop (cdr protos)))))))))
+;; A deftype can implement a method NAME at two arities from two interfaces (e.g.
+;; data.priority-map's seq: Seqable.seq[this] and Sorted.seq[this ascending]),
+;; registered under different protocols. Pick the impl whose procedure accepts
+;; the call's arg count (this + args); fall back to any same-named impl.
+(define (proc-accepts? f n)
+  (and (procedure? f) (bitwise-bit-set? (procedure-arity-mask f) n)))
+(define (find-method-any-protocol-arity type-tag method nargs)
+  (let ((ti (hashtable-ref type-registry type-tag #f)))
+    (and ti (let loop ((protos (vector->list (hashtable-keys ti))) (fallback #f))
+              (if (null? protos)
+                  fallback
+                  (let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
+                    (cond ((and f (proc-accepts? f nargs)) f)
+                          (else (loop (cdr protos) (or fallback f))))))))))
 (define (type-satisfies? type-tag proto)
   (let ((ti (hashtable-ref type-registry type-tag #f)))
     (and ti (hashtable-ref ti proto #f) #t)))
+;; True when a deftype/record instance DECLARES a method by this name (an inline
+;; protocol impl), so clojure.core can prefer it over generic collection behavior
+;; — e.g. (empty priority-map) must use the type's own empty, not return {}.
+(def-var! "jolt.host" "jrec-method?"
+  (lambda (v name) (if (and (jrec? v) (find-method-any-protocol (jrec-tag v) name)) #t #f)))
 
 ;; host type-tag candidates for a non-record value (extend-protocol on builtins).
 (define (value-host-tags obj)
@@ -768,7 +787,7 @@
       ;; which .getName/.getSimpleName work via the String method shim).
       ((and (string=? method-name "getClass") (not (jrec? obj)) (not (jreify? obj)))
        (jolt-class obj))
-      ((and (jrec? obj) (find-method-any-protocol (jrec-tag obj) method-name))
+      ((and (jrec? obj) (find-method-any-protocol-arity (jrec-tag obj) method-name (+ 1 (length rest))))
        => (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

host/chez/seed/prelude.ss

@@ -487,7 +487,7 @@
 (guard (e (#t #f))
   (def-var! "clojure.core" "reverse" (letrec ((reverse (lambda (coll) (let fnrec4586 ((coll coll)) (jolt-reduce jolt-conj (jolt-list ) coll))))) reverse)))
 (guard (e (#t #f))
-  (def-var! "clojure.core" "empty" (letrec ((empty (lambda (coll) (let fnrec4587 ((coll coll)) (if (jolt-nil? coll) jolt-nil (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "sorted?") coll)) (jolt-invoke (jolt-get (jolt-invoke (var-deref "jolt.host" "ref-get") coll (keyword #f "ops")) (keyword #f "empty")) coll) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") coll)) (let* ((_a$4588 (var-deref "clojure.core" "with-meta")) (_a$4589 (jolt-hash-map)) (_a$4590 (jolt-invoke (var-deref "clojure.core" "meta") coll))) (jolt-invoke _a$4588 _a$4589 _a$4590)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "set?") coll)) (let* ((_a$4591 (var-deref "clojure.core" "with-meta")) (_a$4592 (jolt-hash-set)) (_a$4593 (jolt-invoke (var-deref "clojure.core" "meta") coll))) (jolt-invoke _a$4591 _a$4592 _a$4593)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") coll)) (let* ((_a$4594 (var-deref "clojure.core" "with-meta")) (_a$4595 (jolt-vector)) (_a$4596 (jolt-invoke (var-deref "clojure.core" "meta") coll))) (jolt-invoke _a$4594 _a$4595 _a$4596)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "coll?") coll)) (jolt-invoke (var-deref "clojure.core" "with-meta") (jolt-list ) (jolt-invoke (var-deref "clojure.core" "meta") coll)) (if (jolt-truthy? (keyword #f "else")) jolt-nil jolt-nil))))))))))) empty)))
+  (def-var! "clojure.core" "empty" (letrec ((empty (lambda (coll) (let fnrec4587 ((coll coll)) (if (jolt-nil? coll) jolt-nil (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "jrec-method?") coll "empty")) (record-method-dispatch coll "empty" (jolt-vector)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "sorted?") coll)) (jolt-invoke (jolt-get (jolt-invoke (var-deref "jolt.host" "ref-get") coll (keyword #f "ops")) (keyword #f "empty")) coll) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") coll)) (let* ((_a$4588 (var-deref "clojure.core" "with-meta")) (_a$4589 (jolt-hash-map)) (_a$4590 (jolt-invoke (var-deref "clojure.core" "meta") coll))) (jolt-invoke _a$4588 _a$4589 _a$4590)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "set?") coll)) (let* ((_a$4591 (var-deref "clojure.core" "with-meta")) (_a$4592 (jolt-hash-set)) (_a$4593 (jolt-invoke (var-deref "clojure.core" "meta") coll))) (jolt-invoke _a$4591 _a$4592 _a$4593)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") coll)) (let* ((_a$4594 (var-deref "clojure.core" "with-meta")) (_a$4595 (jolt-vector)) (_a$4596 (jolt-invoke (var-deref "clojure.core" "meta") coll))) (jolt-invoke _a$4594 _a$4595 _a$4596)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "coll?") coll)) (jolt-invoke (var-deref "clojure.core" "with-meta") (jolt-list ) (jolt-invoke (var-deref "clojure.core" "meta") coll)) (if (jolt-truthy? (keyword #f "else")) jolt-nil jolt-nil)))))))))))) empty)))
 (guard (e (#t #f))
   (def-var! "clojure.core" "assoc-in" (letrec ((assoc-in (lambda (m G__130 v) (let fnrec4597 ((m m) (G__130 G__130) (v v)) (let* ((G__131 G__130) (k (jolt-nth G__131 0 jolt-nil)) (ks (jolt-invoke (var-deref "clojure.core" "nthnext") G__131 1))) (if (jolt-truthy? ks) (jolt-assoc m k (assoc-in (jolt-get m k) ks v)) (jolt-assoc m k v))))))) assoc-in)))
 (guard (e (#t #f))

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

@@ -133,6 +133,9 @@
 (defn empty [coll]
   (cond
     (nil? coll) nil
+    ;; a deftype/record with its own empty (IPersistentCollection) — e.g.
+    ;; data.priority-map — uses it, before the generic map/set/vector arms.
+    (jolt.host/jrec-method? coll "empty") (.empty coll)
     (sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll)
     (map? coll) (with-meta {} (meta coll))
     (set? coll) (with-meta #{} (meta coll))