clojure: records participate in polymorphic collection API (§4.10)
ober
1b66dfaa89f80fe899f0cf0fdce50d245a5a6808
--- a/docs/clojure-remaining.md +++ b/docs/clojure-remaining.md @@ -1774,6 +1774,37 @@ type information but is uniform. **Risks:** Substantial. Clojure's semantics here are subtle and most users rely on them. Probably best tackled as a separate design round. +**[landed]** Phase E.6 shipped the read-path record-as-map surface and +an assoc/dissoc escape hatch in `(std clojure)`: + +- `get`, `contains?`, `count`, `empty?`, `keys`, `vals` now dispatch on + `record?` (excluding persistent-map/set/sorted-set/concurrent-hash, + which are themselves records). They walk the rtd via Chez's + `record-type-field-names` + `record-accessor`, crossing the parent + chain so inherited fields are included in declaration order. +- Key coercion accepts symbols, strings, and keywords — `(get p 'x)`, + `(get p "x")`, and `(get p :x)` all hit the same field. +- `assoc`/`dissoc` on a record escape to a persistent-map containing + every field plus the new binding (or minus the dropped key). This + loses record type information but is uniform and doesn't require + per-type reconstruction code — matching the "Fallback" path from + the design above. The original record is unchanged. +- `get-in` now walks into records too: `(std misc nested)`'s + `nested-get` grew a `record?` branch, so records nested inside + pmaps, pmaps nested inside records, and records nested inside + records all traverse correctly. +- `persistent-map?` and `imap?` are now re-exported from `(std clojure)` + so code can ask whether an `assoc` call escaped the record type. + +Tests live in `tests/test-record-map.ss` (32 tests), covering +symbol/string key coercion, inherited fields, assoc/dissoc escape, +original-record immutability, regression on persistent types, and +nested `get-in` traversal. Known-field `assoc` reconstruction (which +would preserve the record type) is intentionally *not* implemented: +Chez's sealed-record model doesn't offer a generic way to rebuild +an instance, and the pmap fallback is a principled choice per the +design doc. + ### 4.11 IReduce and seq-over-map fast paths **The gap.** Clojure's `reduce` dispatches to an `IReduce` protocol @@ -1967,7 +1998,7 @@ in this doc. **[deferred]** items are non-goals. | Atom watches | [current] `(std misc atom)` | §4.7 landed | | Volatiles | [current] `(std misc atom)` | §4.7 landed | | Agents | [landed] `(std agent)` | §4.8 landed | -| Record-as-map | [gap] | §4.10 | +| Record-as-map | [landed] `(std clojure)` + `(std misc nested)` | §4.10 landed | | `#!clojure-reader` literal switch | [gap] (risky) | §4.9 | | `{}`/`#{}`/`[]`/`:kw` default reader | [deferred] | §4.9 | | CPS-transformed parked `go` | [deferred] | §3.8 | --- a/lib/std/clojure.sls +++ b/lib/std/clojure.sls @@ -67,10 +67,12 @@ println prn pr pr-str prn-str ;; ---- Re-exports from (std immutable) ---- - imap imap-set imap-ref imap-has? + imap imap? imap-set imap-ref imap-has? imap=? imap-hash in-imap in-imap-pairs in-imap-keys in-imap-values ivec ivec-set ivec-ref ivec-length + ;; ---- Re-exports from (std pmap) ---- + persistent-map? ;; ---- Re-exports from (std pset) ---- persistent-set persistent-set? persistent-set-contains? persistent-set->list @@ -129,6 +131,118 @@ (std sorted-set)) ;; ========================================================================= + ;; Record-as-map helpers (§4.10) + ;; + ;; Clojure's defrecord instances are *also* persistent maps — you can + ;; (get p :x), (keys p), etc. We extend Jerboa's polymorphic ops to + ;; the same on plain records (defstruct / define-record-type) by + ;; walking the rtd with `record-type-field-names` + `record-accessor`. + ;; + ;; The write side (assoc/dissoc on records) falls back to returning + ;; a persistent-map containing all the record's fields plus the new + ;; binding, matching Clojure's "escape to regular map" behaviour when + ;; you assoc an unknown key. For known keys we also return a pmap + ;; rather than trying to reconstruct the record — Chez doesn't + ;; provide a uniform way to rebuild sealed records given only an + ;; instance, so this keeps the implementation simple and uniform + ;; at the cost of losing type information after assoc. + ;; ========================================================================= + + ;; Normalize a user-provided record key to a symbol. Accepts + ;; symbol, string, or keyword. Returns #f for anything else. + (define (%record-key->symbol k) + (cond + [(symbol? k) k] + [(string? k) (string->symbol k)] + [(keyword? k) (string->symbol (keyword->string k))] + [else #f])) + + ;; Collect (field-name . accessor) pairs for a record instance, + ;; walking the parent chain so inherited fields are included in + ;; declaration order (parent first, child fields appended). + ;; Returns a fresh list each call; cache in a caller if hot. + (define (%record-fields-all rec) + (let ([rtd (record-rtd rec)]) + ;; `walk` receives the tail-so-far and prepends this rtd's fields + ;; (in reverse index order) to it. By walking the chain leaf-to- + ;; root and feeding each result as the tail, we end up with + ;; root-to-leaf declaration order overall. + (define (walk-rtd r tail) + (let* ([names (record-type-field-names r)] + [n (vector-length names)]) + (let loop ([i (- n 1)] [out tail]) + (if (< i 0) + out + (loop (- i 1) + (cons (cons (vector-ref names i) + (record-accessor r i)) + out)))))) + (let walk ([r rtd] [tail '()]) + (cond + [(not r) tail] + [else + (walk (record-type-parent r) + (walk-rtd r tail))])))) + + ;; Find a record's field-value by name (walking parent chain). + ;; Returns default if not found. + (define (%record-ref rec key default) + (let ([name (%record-key->symbol key)]) + (cond + [(not name) default] + [else + (let walk ([r (record-rtd rec)]) + (cond + [(not r) default] + [else + (let* ([names (record-type-field-names r)] + [n (vector-length names)]) + (let loop ([i 0]) + (cond + [(= i n) (walk (record-type-parent r))] + [(eq? (vector-ref names i) name) + ((record-accessor r i) rec)] + [else (loop (+ i 1))])))]))]))) + + ;; Check whether a record has a field with the given name. + (define (%record-has-field? rec key) + (let ([name (%record-key->symbol key)]) + (and name + (let walk ([r (record-rtd rec)]) + (cond + [(not r) #f] + [else + (let* ([names (record-type-field-names r)] + [n (vector-length names)]) + (let loop ([i 0]) + (cond + [(= i n) (walk (record-type-parent r))] + [(eq? (vector-ref names i) name) #t] + [else (loop (+ i 1))])))]))))) + + ;; Ordered list of a record's field name symbols (parent first). + (define (%record-keys rec) + (map car (%record-fields-all rec))) + + ;; Ordered list of a record's field values (parent first). + (define (%record-vals rec) + (map (lambda (pair) ((cdr pair) rec)) + (%record-fields-all rec))) + + ;; Escape a record to a persistent-map with its field bindings. + ;; Called by assoc/dissoc when they need to produce an updated + ;; collection but reconstructing the record is impractical. + ;; Field name symbols become the map keys; values become the + ;; map values. Inherited fields are included. + (define (%record->pmap rec) + (let loop ([fields (%record-fields-all rec)] [m pmap-empty]) + (if (null? fields) + m + (let ([pair (car fields)]) + (loop (cdr fields) + (persistent-map-set m (car pair) ((cdr pair) rec))))))) + + ;; ========================================================================= ;; Numerics ;; ========================================================================= (define (inc n) (+ n 1)) @@ -158,6 +272,8 @@ [(hash-table? coll) (zero? (hash-length coll))] [(vector? coll) (zero? (vector-length coll))] [(string? coll) (zero? (string-length coll))] + ;; Plain record — empty iff no fields (including inherited). + [(record? coll) (null? (%record-fields-all coll))] [else (error 'empty? "unsupported collection type" coll)])) ;; ========================================================================= @@ -175,6 +291,8 @@ [(hash-table? coll) (hash-length coll)] [(vector? coll) (vector-length coll)] [(string? coll) (string-length coll)] + ;; Plain record — number of fields including inherited ones. + [(record? coll) (length (%record-fields-all coll))] [else (error 'count "unsupported collection type" coll)])) ;; ========================================================================= @@ -191,6 +309,16 @@ (if (persistent-set-contains? coll key) key default)] [(sorted-set? coll) (if (sorted-set-contains? coll key) key default)] + ;; Record — check nested-get first (handles containers), then + ;; fall through to record-field lookup. `record?` is checked + ;; AFTER the type-specific branches in nested-get so it only + ;; catches user-defined records. + [(and (record? coll) + (not (persistent-map? coll)) + (not (persistent-set? coll)) + (not (sorted-set? coll)) + (not (concurrent-hash? coll))) + (%record-ref coll key default)] [else (nested-get coll key default)])])) (define (contains? coll key) @@ -204,6 +332,8 @@ (and (integer? key) (exact? key) (>= key 0) (< key (vector-length coll)))] [(pair? coll) (and (assq key coll) #t)] + ;; Plain user record — check if field exists. + [(record? coll) (%record-has-field? coll key)] [else #f])) ;; ========================================================================= @@ -246,6 +376,16 @@ [else (hash-put! coll (car rest) (cadr rest)) (loop (cddr rest))]))] + ;; Plain user record — escape to a persistent map containing + ;; all the record's fields plus the new bindings. This loses + ;; the record type information but matches Clojure's documented + ;; behaviour when you assoc a key a record doesn't support. + ;; Known-key assoc could theoretically rebuild the record, but + ;; Chez doesn't expose a uniform constructor-from-rtd, so we + ;; use the pmap escape uniformly. Use per-record struct updates + ;; (e.g. defstruct's setters) if you need to preserve type. + [(record? coll) + (apply assoc (%record->pmap coll) key val more)] [else (error 'assoc "unsupported collection type" coll)])) (define (dissoc coll . ks) @@ -261,6 +401,11 @@ [(hash-table? coll) (for-each (lambda (k) (hash-remove! coll k)) ks) coll] + ;; Plain user record — escape to pmap and dissoc from there. + ;; You can't actually remove a field from a record (it's part + ;; of the type), so we return a pmap with the field omitted. + [(record? coll) + (apply dissoc (%record->pmap coll) ks)] [else (error 'dissoc "unsupported collection type" coll)])) (define update @@ -308,6 +453,8 @@ [(persistent-map? coll) (persistent-map-keys coll)] [(concurrent-hash? coll) (concurrent-hash-keys coll)] [(hash-table? coll) (hash-keys coll)] + ;; Plain record — return field name symbols (parent chain first). + [(record? coll) (%record-keys coll)] [else (error 'keys "unsupported collection type" coll)])) (define (vals coll) @@ -315,6 +462,8 @@ [(persistent-map? coll) (persistent-map-values coll)] [(concurrent-hash? coll) (concurrent-hash-values coll)] [(hash-table? coll) (hash-values coll)] + ;; Plain record — return field values (same order as keys). + [(record? coll) (%record-vals coll)] [else (error 'vals "unsupported collection type" coll)])) ;; ========================================================================= --- a/lib/std/misc/nested.sls +++ b/lib/std/misc/nested.sls @@ -86,8 +86,38 @@ ;; Alist — fall back to assoc (let ([pair (assoc key container)]) (if pair (cdr pair) default))] + [(record? container) + ;; Record — look up field by name (accepts symbol, string, keyword). + ;; Walks the parent chain so inherited fields are reachable. + ;; This powers get-in over nested records / defstruct instances. + (%nested-record-ref container key default)] [else default])) + (define (%nested-record-key->symbol k) + (cond + [(symbol? k) k] + [(string? k) (string->symbol k)] + [(keyword? k) (string->symbol (keyword->string k))] + [else #f])) + + (define (%nested-record-ref rec key default) + (let ([name (%nested-record-key->symbol key)]) + (cond + [(not name) default] + [else + (let walk ([r (record-rtd rec)]) + (cond + [(not r) default] + [else + (let* ([names (record-type-field-names r)] + [n (vector-length names)]) + (let loop ([i 0]) + (cond + [(= i n) (walk (record-type-parent r))] + [(eq? (vector-ref names i) name) + ((record-accessor r i) rec)] + [else (loop (+ i 1))])))]))]))) + (define (nested-empty-like container) ;; Return a fresh empty container of the same type as `container`. ;; Used by assoc-in! / update-in! to create intermediates. new file mode 100644 --- /dev/null +++ b/tests/test-record-map.ss @@ -0,0 +1,204 @@ +#!chezscheme +;;; Tests for §4.10 record-as-map — Jerboa records participating in +;;; the (std clojure) polymorphic collection API. + +(import (except (jerboa prelude) hash-map) + (std clojure)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- record-as-map (§4.10) ---~%~%") + +;;; ---- Define test records --------------------------------------- + +(defstruct point (x y z)) +(defstruct user (name email age)) + +;;; ---- get on records -------------------------------------------- + +(define p (make-point 1 2 3)) + +(test "get by symbol" + (get p 'x) + 1) + +(test "get second field" + (get p 'y) + 2) + +(test "get third field" + (get p 'z) + 3) + +(test "get missing field returns #f by default" + (get p 'w) + #f) + +(test "get missing field returns default" + (get p 'w 'none) + 'none) + +(test "get by string key (coerced to symbol)" + (get p "x") + 1) + +;;; ---- contains? ------------------------------------------------- + +(test "contains? true for known field" + (contains? p 'x) + #t) + +(test "contains? false for unknown field" + (contains? p 'w) + #f) + +(test "contains? true for string key of known field" + (contains? p "y") + #t) + +;;; ---- count / empty? -------------------------------------------- + +(test "count returns number of fields" + (count p) + 3) + +(test "empty? false for record with fields" + (empty? p) + #f) + +;;; ---- keys / vals ----------------------------------------------- + +(test "keys returns field name symbols" + (keys p) + '(x y z)) + +(test "vals returns field values in field order" + (vals p) + '(1 2 3)) + +(test "keys on user record" + (keys (make-user "Alice" "a@x" 30)) + '(name email age)) + +(test "vals on user record" + (vals (make-user "Alice" "a@x" 30)) + '("Alice" "a@x" 30)) + +;;; ---- assoc escapes to pmap ------------------------------------- +;;; +;;; assoc on a record returns a persistent-map containing all the +;;; record's fields plus the new binding. This loses the record +;;; type but is uniform and doesn't require per-record reconstruction. + +(test "assoc on record returns a persistent-map" + (persistent-map? (assoc p 'new-key 99)) + #t) + +(test "assoc preserves existing fields in the pmap" + (let ([m (assoc p 'new-key 99)]) + (list (get m 'x) (get m 'y) (get m 'z) (get m 'new-key))) + '(1 2 3 99)) + +(test "assoc of known field updates value in pmap escape" + (let ([m (assoc p 'x 100)]) + (list (get m 'x) (get m 'y) (get m 'z))) + '(100 2 3)) + +(test "original record unchanged after assoc" + (let ([m (assoc p 'x 100)]) + (point-x p)) + 1) + +(test "assoc multiple bindings in one call" + (let ([m (assoc p 'a 1 'b 2 'c 3)]) + (list (get m 'a) (get m 'b) (get m 'c) (get m 'x))) + '(1 2 3 1)) + +;;; ---- dissoc escapes to pmap ------------------------------------ + +(test "dissoc returns a persistent-map" + (persistent-map? (dissoc p 'x)) + #t) + +(test "dissoc removes the named field from the pmap" + (let ([m (dissoc p 'x)]) + (list (contains? m 'x) (contains? m 'y) (contains? m 'z))) + '(#f #t #t)) + +(test "dissoc multiple fields" + (let ([m (dissoc p 'x 'y)]) + (list (contains? m 'x) (contains? m 'y) (contains? m 'z))) + '(#f #f #t)) + +(test "original record unchanged after dissoc" + (let ([m (dissoc p 'x)]) + (point-x p)) + 1) + +;;; ---- Persistent types still work ------------------------------- +;;; +;;; Make sure the record-as-map fallback didn't accidentally catch +;;; persistent-map, persistent-set, or other typed containers. + +(define pm (hash-map "a" 1 "b" 2)) +(define ps (hash-set 1 2 3)) + +(test "pmap get still works" + (get pm "a") + 1) + +(test "pmap contains? still works" + (contains? pm "b") + #t) + +(test "pmap count still works" + (count pm) + 2) + +(test "pmap assoc still returns pmap" + (let ([m2 (assoc pm "c" 3)]) + (list (persistent-map? m2) (get m2 "c"))) + '(#t 3)) + +(test "pset count still works" + (count ps) + 3) + +(test "pset contains still works" + (contains? ps 2) + #t) + +;;; ---- get-in walks records -------------------------------------- +;;; +;;; get-in should handle records-in-records, records-in-pmaps, +;;; pmaps-in-records, etc. + +(defstruct address (city zip)) + +(define user-with-addr + (make-user "Bob" "b@x" (make-address "NYC" "10001"))) + +(test "get-in walks into a record nested inside a record" + (get-in user-with-addr '(age city)) + "NYC") + +(test "get-in returns default on missing path" + (get-in user-with-addr '(age zipcode) 'missing) + 'missing) + +;;; ---- Summary --------------------------------------------------- +(printf "~%record-as-map: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))