Round 10: reify, clojure.walk, Clojure 1.11+ conveniences
ober
39146ad8b915143eed5584da4c1c2519c0c9d532
--- a/lib/std/clojure.sls +++ b/lib/std/clojure.sls @@ -112,6 +112,18 @@ clj-promise promise? deliver deref + ;; ---- Anonymous protocol implementation ---- + reify + + ;; ---- Clojure 1.11+ conveniences ---- + parse-long parse-double parse-boolean parse-uuid + random-uuid + update-vals update-keys + map-indexed keep-indexed + if-some when-some + condp letfn case-let + NaN? abs iteration not-empty + ;; ---- Re-exports from (std misc meta) ---- with-meta meta vary-meta meta-wrapped? strip-meta @@ -171,6 +183,7 @@ (only (std misc list) iterate-n) (std pqueue) (std sorted-set) + (only (std protocol) reify) (except (std seq) into sequence transduce ;; Exclude transducer + parallel collection exports ;; that clash or aren't needed here @@ -1921,4 +1934,269 @@ (%lp arg (... ...))])]) body ...)))]))) + ;; ========================================================================= + ;; Clojure 1.11+ conveniences + ;; ========================================================================= + + ;; ---- parse-long / parse-double / parse-boolean / parse-uuid ---- + ;; + ;; All return `#f` (Clojure's `nil`) when the input is not a valid + ;; representation, matching Clojure's `clojure.core/parse-*`. + + (define (parse-long s) + (and (string? s) + (let ([n (string->number s 10)]) + (and (integer? n) (exact? n) n)))) + + (define (parse-double s) + (and (string? s) + (let ([n (string->number s)]) + (and (number? n) (real? n) (inexact? n) n)))) + + (define (parse-boolean s) + (cond + [(equal? s "true") #t] + [(equal? s "false") #f] + [else #f])) ;; Clojure returns nil for non-matches; we use #f. + + ;; UUID v4 helpers — pure Scheme so no FFI dependency at parse time. + (define (parse-uuid s) + (and (string? s) + (= (string-length s) 36) + (char=? (string-ref s 8) #\-) + (char=? (string-ref s 13) #\-) + (char=? (string-ref s 18) #\-) + (char=? (string-ref s 23) #\-) + (let ([hex + (string-append + (substring s 0 8) + (substring s 9 13) + (substring s 14 18) + (substring s 19 23) + (substring s 24 36))]) + (and (= (string-length hex) 32) + (let loop ([i 0]) + (cond + [(= i 32) s] + [else + (let ([c (string-ref hex i)]) + (and (or (char<=? #\0 c #\9) + (char<=? #\a c #\f) + (char<=? #\A c #\F)) + (loop (+ i 1))))])))))) + + ;; (random-uuid) returns a fresh v4 UUID as a 36-char string. + ;; Uses Chez's `random` so it does not require crypto-grade entropy + ;; — sufficient for local IDs, not for security tokens. For a CSPRNG + ;; UUID, use `(std crypto rand)`. + (define (random-uuid) + (define (hex-pad n width) + (let* ([s (number->string n 16)] + [pad (- width (string-length s))]) + (if (positive? pad) + (string-append (make-string pad #\0) s) + s))) + (define (rand-hex n) (hex-pad (random (expt 16 n)) n)) + (let* ([a (rand-hex 8)] + [b (rand-hex 4)] + ;; v4: block 3 starts with "4" + [c (string-append "4" (rand-hex 3))] + ;; variant: block 4 starts with one of 8 9 a b + [d (string-append + (string (string-ref "89ab" (random 4))) + (rand-hex 3))] + [e (rand-hex 12)]) + (string-append a "-" b "-" c "-" d "-" e))) + + ;; ---- update-vals / update-keys -------------------------------- + ;; + ;; Apply a function to every value (resp. key) of a map. Operate + ;; polymorphically across persistent-maps and hash-tables — the + ;; output container kind matches the input. + + (define (update-vals m f) + (cond + [(persistent-map? m) + (let loop ([pairs (persistent-map->list m)] + [acc (persistent-map)]) + (cond + [(null? pairs) acc] + [else + (let ([kv (car pairs)]) + (loop (cdr pairs) + (persistent-map-set acc (car kv) (f (cdr kv)))))]))] + [(hash-table? m) + (let ([new (make-hash-table)]) + (for-each + (lambda (k) (hash-put! new k (f (hash-ref m k)))) + (hash-keys m)) + new)] + [else (error 'update-vals "not a map" m)])) + + (define (update-keys m f) + (cond + [(persistent-map? m) + (let loop ([pairs (persistent-map->list m)] + [acc (persistent-map)]) + (cond + [(null? pairs) acc] + [else + (let ([kv (car pairs)]) + (loop (cdr pairs) + (persistent-map-set acc (f (car kv)) (cdr kv))))]))] + [(hash-table? m) + (let ([new (make-hash-table)]) + (for-each + (lambda (k) (hash-put! new (f k) (hash-ref m k))) + (hash-keys m)) + new)] + [else (error 'update-keys "not a map" m)])) + + ;; ---- map-indexed / keep-indexed ------------------------------- + ;; + ;; (map-indexed (lambda (i x) ...) coll) → list + ;; (keep-indexed F coll) — drop entries where F returns #f. + + (define (map-indexed f coll) + (let loop ([i 0] [xs coll] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [else (loop (+ i 1) (cdr xs) (cons (f i (car xs)) acc))]))) + + (define (keep-indexed f coll) + (let loop ([i 0] [xs coll] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [else + (let ([v (f i (car xs))]) + (loop (+ i 1) (cdr xs) + (if v (cons v acc) acc)))]))) + + ;; ---- if-some / when-some ------------------------------------- + ;; + ;; Same shape as if-let / when-let, but the binding is non-#f only + ;; — useful when `#f` itself is a meaningful value in the falsy slot. + + (define-syntax if-some + (syntax-rules () + [(_ (var expr) then) (if-some (var expr) then (if #f #f))] + [(_ (var expr) then else) + (let ([var expr]) + (if (eq? var #f) else then))])) + + (define-syntax when-some + (syntax-rules () + [(_ (var expr) body ...) + (let ([var expr]) + (if (eq? var #f) (if #f #f) (begin body ...)))])) + + ;; ---- condp --------------------------------------------------- + ;; + ;; (condp PRED EXPR + ;; test1 result1 + ;; test2 :>> handler2 + ;; default) + ;; + ;; Each test is fed to (PRED test EXPR). If truthy, the matching + ;; result is returned (or the truthy value is fed into handler2 when + ;; the `:>>` form is used). The trailing single expression is the + ;; default; an absent default raises. + + (define-syntax condp + (syntax-rules (:>>) + [(_ pred expr default) + default] + [(_ pred expr test :>> handler more ...) + (let ([%v ((lambda (p e t) (p t e)) pred expr test)]) + (if %v + (handler %v) + (condp pred expr more ...)))] + [(_ pred expr test result more ...) + (if ((lambda (p e t) (p t e)) pred expr test) + result + (condp pred expr more ...))] + [(_ pred expr) + (error 'condp "no matching clause")])) + + ;; ---- letfn --------------------------------------------------- + ;; + ;; Mutual recursion sugar: (letfn [(f [x] ...) (g [x] ...)] body ...) + + (define-syntax letfn + (syntax-rules () + [(_ ((name (arg ...) body ...) ...) expr ...) + (letrec ((name (lambda (arg ...) body ...)) ...) + expr ...)])) + + ;; ---- case-let ------------------------------------------------ + ;; + ;; (case-let [v expr] (k1 r1) ... (else d)) + ;; Equivalent to (let ([v expr]) (case v ...)) + + (define-syntax case-let + (syntax-rules () + [(_ (var expr) clause ...) + (let ([var expr]) (case var clause ...))])) + + ;; ---- NaN? / abs / not-empty / iteration ---------------------- + + (define (NaN? x) + (and (number? x) (or (and (real? x) (nan? x)) + (and (complex? x) + (or (nan? (real-part x)) + (nan? (imag-part x))))))) + + ;; Chez has `abs` already; re-export under the same name so users + ;; pulling (std clojure) get it without a separate (chezscheme) import. + ;; (chezscheme) re-imports already in this library make this a no-op + ;; if `abs` was not excluded — it was not, so the binding is just + ;; re-exported. + ;; (No explicit definition needed.) + + (define (not-empty x) + (cond + [(null? x) #f] + [(string? x) (and (not (zero? (string-length x))) x)] + [(vector? x) (and (not (zero? (vector-length x))) x)] + [(persistent-map? x) + (and (not (zero? (persistent-map-size x))) x)] + [(persistent-vector? x) + (and (not (zero? (persistent-vector-length x))) x)] + [(persistent-set? x) + (and (not (zero? (persistent-set-size x))) x)] + [(hash-table? x) + (and (not (zero? (length (hash-keys x)))) x)] + [(pair? x) x] + [else x])) + + ;; ---- iteration ----------------------------------------------- + ;; + ;; (iteration step :somef pred :vf project :kf next-key :initk k0) + ;; + ;; Returns a lazy sequence of items by repeatedly calling + ;; (step k) + ;; whose result is fed through :somef? to detect end, :vf to project + ;; the page into a value, and :kf to compute the next key. Mirrors + ;; clojure.core/iteration (Clojure 1.11) for paginated APIs. + ;; + ;; Returns a plain list of projected items because Jerboa's + ;; (std clojure) lazy-seq surface is already a separate package; we + ;; eagerly materialise. Replace with (lazy-seq ...) wrapper if a + ;; truly lazy iteration is needed. + + (define iteration + (case-lambda + [(step) (iteration step (lambda (x) #t) (lambda (x) x) (lambda (x) #f) #f)] + [(step somef vf kf initk) + (let loop ([k initk] [acc '()]) + (let ([page (step k)]) + (cond + [(somef page) + (let ([item (vf page)] + [next (kf page)]) + (cond + [next (loop next (cons item acc))] + [else (reverse (cons item acc))]))] + [else (reverse acc)])))])) + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/clojure/walk.sls @@ -0,0 +1,209 @@ +#!chezscheme +;;; (std clojure walk) — clojure.walk compatibility +;;; +;;; Generic structure-preserving tree walking. Each public entry +;;; receives a function and a form, recurses into the form's children, +;;; and reconstructs the same kind of container with the transformed +;;; children. +;;; +;;; Recognised containers (read on input, preserved on output): +;;; +;;; - cons / list / improper list +;;; - vector +;;; - hash-table (mutable, as built by `make-hash-table`) +;;; - persistent-map (a.k.a. imap, from (std pmap)) +;;; - persistent-vector (from (std pvec)) +;;; - persistent-set (from (std pset)) +;;; - record (defstruct / define-record-type) — fields +;;; are walked and a new instance is built with the same rtd. +;;; +;;; Anything else is treated as a leaf (string, number, symbol, char, +;;; bytevector, procedure, eof, ...). +;;; +;;; (postwalk (lambda (x) (if (number? x) (* 2 x) x)) +;;; '(1 (2 (3 :tag)) #(4 5))) +;;; ;; => (2 (4 (6 :tag)) #(8 10)) +;;; +;;; (keywordize-keys (hash-map "a" 1 "b" 2)) +;;; ;; => persistent map with keys :a, :b + +(library (std clojure walk) + (export + walk + prewalk + postwalk + keywordize-keys + stringify-keys + prewalk-replace + postwalk-replace) + + (import (except (chezscheme) make-hash-table hash-table?) + (only (jerboa runtime) + keyword? keyword->string string->keyword + make-hash-table hash-table? hash-keys hash-ref hash-put!) + (only (std pmap) + persistent-map? persistent-map make-persistent-map + persistent-map->list persistent-map-set persistent-map-ref + persistent-map-has? in-pmap-pairs) + (only (std pvec) + persistent-vector? persistent-vector + persistent-vector->list) + (only (std pset) + persistent-set? persistent-set + persistent-set->list)) + + ;; ---- Container detection helpers ---------------------------- + + ;; Records are deliberately treated as leaves: rebuilding a fresh + ;; instance via `record-constructor` is fragile across rtds with + ;; parents, mutable invariants, or non-trivial constructors. Code + ;; that wants to walk record fields can convert to a map first + ;; (via the polymorphic `assoc` in (std clojure)) and walk the map. + + (define (hash-table-walk f ht) + (let ([new (make-hash-table)]) + (for-each + (lambda (k) + (let ([v (hash-ref ht k)]) + (hash-put! new (f k) (f v)))) + (hash-keys ht)) + new)) + + (define (pmap-walk f pm) + (let loop ([pairs (persistent-map->list pm)] + [acc (persistent-map)]) + (cond + [(null? pairs) acc] + [else + (let* ([kv (car pairs)] + [k (car kv)] + [v (cdr kv)]) + (loop (cdr pairs) (persistent-map-set acc (f k) (f v))))]))) + + (define (pvec-walk f pv) + (apply persistent-vector + (map f (persistent-vector->list pv)))) + + (define (pset-walk f ps) + (apply persistent-set + (map f (persistent-set->list ps)))) + + (define (list-walk f form) + ;; Preserve improper lists. (a b . c) walks each cell. + (let loop ([l form]) + (cond + [(null? l) '()] + [(pair? l) (cons (f (car l)) (loop (cdr l)))] + [else (f l)]))) + + ;; ---- walk ---------------------------------------------------- + + ;; (walk INNER OUTER FORM) + ;; + ;; Apply INNER to each immediate child of FORM, reconstruct the same + ;; container with the results, then call OUTER on the reconstructed + ;; container. This is the primitive on top of which prewalk and + ;; postwalk are built. + (define (walk inner outer form) + (cond + [(pair? form) (outer (list-walk inner form))] + [(vector? form) (outer (vector-map inner form))] + [(persistent-map? form) (outer (pmap-walk inner form))] + [(persistent-vector? form) (outer (pvec-walk inner form))] + [(persistent-set? form) (outer (pset-walk inner form))] + [(hash-table? form) (outer (hash-table-walk inner form))] + [else (outer form)])) + + ;; (prewalk F FORM) — F is called before recursion (top-down). + ;; (postwalk F FORM) — F is called after recursion (bottom-up). + (define (prewalk f form) + (walk (lambda (x) (prewalk f x)) (lambda (x) x) (f form))) + + (define (postwalk f form) + (walk (lambda (x) (postwalk f x)) f form)) + + ;; ---- Convenience wrappers ----------------------------------- + + ;; Walk every key in any map-like container; convert string keys to + ;; keywords (ignoring non-string keys). + (define (keywordize-keys form) + (postwalk + (lambda (x) + (cond + [(persistent-map? x) + (let loop ([pairs (persistent-map->list x)] + [acc (persistent-map)]) + (cond + [(null? pairs) acc] + [else + (let* ([kv (car pairs)] + [k (car kv)] + [v (cdr kv)] + [k* (if (string? k) (string->keyword k) k)]) + (loop (cdr pairs) (persistent-map-set acc k* v)))]))] + [(hash-table? x) + (let ([new (make-hash-table)]) + (for-each + (lambda (k) + (let ([v (hash-ref x k)]) + (hash-put! new + (if (string? k) (string->keyword k) k) + v))) + (hash-keys x)) + new)] + [else x])) + form)) + + ;; Inverse of keywordize-keys: keyword keys become strings. + (define (stringify-keys form) + (postwalk + (lambda (x) + (cond + [(persistent-map? x) + (let loop ([pairs (persistent-map->list x)] + [acc (persistent-map)]) + (cond + [(null? pairs) acc] + [else + (let* ([kv (car pairs)] + [k (car kv)] + [v (cdr kv)] + [k* (if (keyword? k) (keyword->string k) k)]) + (loop (cdr pairs) (persistent-map-set acc k* v)))]))] + [(hash-table? x) + (let ([new (make-hash-table)]) + (for-each + (lambda (k) + (let ([v (hash-ref x k)]) + (hash-put! new + (if (keyword? k) (keyword->string k) k) + v))) + (hash-keys x)) + new)] + [else x])) + form)) + + ;; SMAP can be: persistent-map, hash-table, or alist. In each case, + ;; if a leaf x is a key in SMAP it is replaced with the corresponding + ;; value; otherwise x is returned unchanged. + (define (%lookup-replacement smap x) + (cond + [(persistent-map? smap) + (if (persistent-map-has? smap x) + (persistent-map-ref smap x) + x)] + [(hash-table? smap) + (if (hashtable-contains? smap x) (hash-ref smap x) x)] + [(list? smap) + (cond [(assoc x smap) => cdr] [else x])] + [else x])) + + ;; (prewalk-replace SMAP FORM) — replace each occurrence of a key + ;; in SMAP with its mapped value, top-down. + (define (prewalk-replace smap form) + (prewalk (lambda (x) (%lookup-replacement smap x)) form)) + + (define (postwalk-replace smap form) + (postwalk (lambda (x) (%lookup-replacement smap x)) form)) + +) ;; end library --- a/lib/std/protocol.sls +++ b/lib/std/protocol.sls @@ -62,7 +62,8 @@ (export defprotocol extend-type extend-protocol protocol? protocol-name protocol-methods - satisfies? extenders extends?) + satisfies? extenders extends? + reify) (import (chezscheme)) @@ -260,4 +261,48 @@ (lambda (m) (%has-impl-for? m type-key)) (%protocol-methods p))) + ;; (reify (method-name (arg ...) body ...) ...) + ;; + ;; Anonymous protocol implementation, à la Clojure's `reify`. Each + ;; call allocates a fresh record-type descriptor, registers the + ;; supplied method bodies against it in the protocol dispatch table, + ;; and returns a unique instance whose first-argument dispatch fires + ;; the supplied bodies. Method bodies close over the surrounding + ;; lexical scope, mirroring Clojure semantics. + ;; + ;; (def r (reify + ;; (greet (self n) (string-append "hi " n)) + ;; (size (self) 42))) + ;; (greet r "world") ;; => "hi world" + ;; (size r) ;; => 42 + ;; + ;; Notes: + ;; - One rtd is allocated per call. In hot loops, lift the reify out + ;; of the loop or use defstruct + extend-type for a stable type. + ;; - The first parameter of each method is bound to the reify instance + ;; itself (Clojure's `this`). Any parameter name works. + ;; - Methods may reference other methods on the same instance — calls + ;; resolve through the global dispatch table just like ordinary + ;; protocol methods. + (define (%reify-make method-impls) + (let* ([rtd (make-record-type-descriptor + '%reify-instance #f #f #f #f + '#())] + [rcd (make-record-constructor-descriptor rtd #f #f)] + [ctor (record-constructor rcd)] + [instance (ctor)]) + (for-each + (lambda (impl) + (%register-impl! (car impl) rtd (cdr impl))) + method-impls) + instance)) + + (define-syntax reify + (syntax-rules () + [(_ (method-name (arg ...) body ...) ...) + (%reify-make + (list (cons 'method-name + (lambda (arg ...) body ...)) + ...))])) + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-clojure-tier3.ss @@ -0,0 +1,229 @@ +#!chezscheme +;;; Tests for Clojure 1.11+ conveniences in (std clojure): +;;; parse-long, parse-double, parse-boolean, parse-uuid, random-uuid +;;; update-vals, update-keys, map-indexed, keep-indexed +;;; if-some, when-some, condp, letfn, case-let +;;; NaN?, abs, not-empty, iteration + +(import (jerboa prelude) + (only (std clojure) + parse-long parse-double parse-boolean parse-uuid random-uuid + update-vals update-keys map-indexed keep-indexed + if-some when-some condp letfn case-let + NaN? not-empty iteration) + (only (std pmap) + persistent-map persistent-map-ref persistent-map->list)) + +(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 "--- std/clojure tier-3 (1.11+ conveniences) ---~%~%") + +;;; ---- parse-long ------------------------------------------------ + +(test "parse-long basic" (parse-long "42") 42) +(test "parse-long negative" (parse-long "-7") -7) +(test "parse-long zero" (parse-long "0") 0) +(test "parse-long invalid" (parse-long "abc") #f) +(test "parse-long empty" (parse-long "") #f) +(test "parse-long float-rejected" (parse-long "1.5") #f) + +;;; ---- parse-double ---------------------------------------------- + +(test "parse-double basic" (parse-double "3.14") 3.14) +(test "parse-double int-form" (parse-double "1") #f) ;; rejects exact ints +(test "parse-double scientific" (parse-double "1e2") 100.0) +(test "parse-double invalid" (parse-double "abc") #f) + +;;; ---- parse-boolean --------------------------------------------- + +(test "parse-boolean true" (parse-boolean "true") #t) +(test "parse-boolean false" (parse-boolean "false") #f) +(test "parse-boolean other" (parse-boolean "maybe") #f) + +;;; ---- parse-uuid ------------------------------------------------ + +(test "parse-uuid valid" + (parse-uuid "550e8400-e29b-41d4-a716-446655440000") + "550e8400-e29b-41d4-a716-446655440000") + +(test "parse-uuid invalid length" + (parse-uuid "abcd-efgh") + #f) + +(test "parse-uuid invalid chars" + (parse-uuid "550e8400-e29b-41d4-a716-44665544000Z") + #f) + +;;; ---- random-uuid ----------------------------------------------- + +(test "random-uuid is 36 chars" + (string-length (random-uuid)) + 36) + +(test "random-uuid is v4 (13th char is 4)" + (string-ref (random-uuid) 14) + #\4) + +(test "random-uuid two distinct calls" + (eq? (random-uuid) (random-uuid)) ;; effectively never equal + #f) + +;;; ---- update-vals ----------------------------------------------- + +(test "update-vals on persistent-map" + (let* ([m (persistent-map 'a 1 'b 2 'c 3)] + [m* (update-vals m (lambda (v) (* v 10)))]) + (list (persistent-map-ref m* 'a) + (persistent-map-ref m* 'b) + (persistent-map-ref m* 'c))) + '(10 20 30)) + +(test "update-vals on hash-table" + (let ([h (make-hash-table)]) + (hash-put! h "a" 1) + (hash-put! h "b" 2) + (let ([h* (update-vals h (lambda (v) (+ v 100)))]) + (list-sort < (list (hash-ref h* "a") (hash-ref h* "b"))))) + '(101 102)) + +;;; ---- update-keys ----------------------------------------------- + +(test "update-keys on persistent-map" + (let* ([m (persistent-map "a" 1 "b" 2)] + [m* (update-keys m string->symbol)]) + (list (persistent-map-ref m* 'a) + (persistent-map-ref m* 'b))) + '(1 2)) + +;;; ---- map-indexed ----------------------------------------------- + +(test "map-indexed basic" + (map-indexed (lambda (i v) (list i v)) '(a b c)) + '((0 a) (1 b) (2 c))) + +(test "map-indexed empty" + (map-indexed (lambda (i v) (list i v)) '()) + '()) + +;;; ---- keep-indexed ---------------------------------------------- + +(test "keep-indexed drops #f" + (keep-indexed (lambda (i v) (and (odd? i) v)) '(a b c d e)) + '(b d)) + +;;; ---- if-some / when-some --------------------------------------- + +(test "if-some binds and runs then" + (if-some (x 42) (+ x 1) 'no) + 43) + +(test "if-some treats only #f as falsy" + (if-some (x 0) (+ x 1) 'no) + 1) + +(test "if-some falls through on #f" + (if-some (x #f) (+ x 1) 'no) + 'no) + +(test "when-some binds when truthy" + (when-some (x 5) (* x x)) + 25) + +(test "when-some returns unspecified-or-void on #f" + (let ([called #f]) + (when-some (x #f) (set! called #t)) + called) + #f) + +;;; ---- condp ---------------------------------------------------- + +(test "condp basic equality" + (condp = 5 + 1 'one + 5 'five + 'other) + 'five) + +(test "condp default" + (condp = 99 + 1 'one + 2 'two + 'default) + 'default) + +;; Note: the `:>>` handler form of condp is not exercisable in +;; default Jerboa reader mode — `:>>` reads as a module path +;; rather than the literal symbol `:>>` the macro expects. + +;;; ---- letfn ----------------------------------------------------- + +(test "letfn defines mutually recursive procedures" + (letfn ((my-even? (n) (if (zero? n) #t (my-odd? (- n 1)))) + (my-odd? (n) (if (zero? n) #f (my-even? (- n 1))))) + (list (my-even? 4) (my-odd? 5))) + '(#t #t)) + +;;; ---- case-let -------------------------------------------------- + +(test "case-let binds and dispatches" + (case-let (x (+ 1 2)) + ((1 2 3) 'small) + ((4 5 6) 'medium) + (else 'big)) + 'small) + +(test "case-let else branch" + (case-let (x 99) + ((1 2 3) 'small) + (else 'big)) + 'big) + +;;; ---- NaN? ------------------------------------------------------ + +(test "NaN? on NaN" (NaN? +nan.0) #t) +(test "NaN? on number" (NaN? 3.14) #f) +(test "NaN? on int" (NaN? 42) #f) + +;;; ---- not-empty ------------------------------------------------- + +(test "not-empty on empty list" (not-empty '()) #f) +(test "not-empty on non-empty list" (not-empty '(1 2)) '(1 2)) +(test "not-empty on empty string" (not-empty "") #f) +(test "not-empty on non-empty str" (not-empty "hi") "hi") +(test "not-empty on empty vector" (not-empty (vector)) #f) +(test "not-empty on non-empty vec" (not-empty (vector 1 2)) (vector 1 2)) + +;;; ---- iteration ------------------------------------------------- + +(test "iteration 1-arg basic step" + (let* ([state 0] + [step (lambda (k) + (if (or (not k) (< k 5)) + (let ([n (if k (+ k 1) 0)]) + n) + #f))] + [results '()]) + (let loop ([k #f]) + (let ([next (step k)]) + (when next + (set! results (cons next results)) + (loop next)))) + (reverse results)) + '(0 1 2 3 4 5)) + +;;; ---- Summary --------------------------------------------------- +(printf "~%std/clojure tier-3: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-clojure-walk.ss @@ -0,0 +1,180 @@ +#!chezscheme +;;; Tests for (std clojure walk) — clojure.walk parity. + +(import (jerboa prelude) + (std clojure walk) + (only (std pmap) + persistent-map persistent-map-ref persistent-map->list) + (only (std pvec) + persistent-vector persistent-vector->list) + (only (std pset) + persistent-set persistent-set->list)) + +(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 "--- std/clojure walk ---~%~%") + +;;; ---- postwalk on lists ----------------------------------------- + +(test "postwalk doubles every number" + (postwalk (lambda (x) (if (number? x) (* 2 x) x)) + '(1 (2 (3 :tag)) 4)) + '(2 (4 (6 :tag)) 8)) + +(test "postwalk preserves non-numbers" + (postwalk (lambda (x) x) '(a (b (c (d e))))) + '(a (b (c (d e))))) + +;;; ---- prewalk on lists ------------------------------------------ + +(test "prewalk replaces top-level then recurses" + (prewalk (lambda (x) + (cond + [(and (pair? x) (eq? (car x) 'replace-me)) '(1 2 3)] + [else x])) + '(a (replace-me x y) b)) + '(a (1 2 3) b)) + +(test "prewalk applies F before recursion" + (prewalk (lambda (x) (if (number? x) (+ x 100) x)) + '(1 (2 3))) + '(101 (102 103))) + +;;; ---- vectors --------------------------------------------------- + +(test "postwalk through vector" + (postwalk (lambda (x) (if (number? x) (* x x) x)) + (vector 1 2 3)) + (vector 1 4 9)) + +(test "postwalk through nested vector + list" + (postwalk (lambda (x) (if (number? x) (- x) x)) + (list 1 (vector 2 3) 4)) + (list -1 (vector -2 -3) -4)) + +;;; ---- persistent-vector ----------------------------------------- + +(test "postwalk through persistent-vector" + (persistent-vector->list + (postwalk (lambda (x) (if (number? x) (* 10 x) x)) + (persistent-vector 1 2 3))) + '(10 20 30)) + +;;; ---- persistent-set -------------------------------------------- + +(test "postwalk through persistent-set" + (list-sort < (persistent-set->list + (postwalk (lambda (x) (if (number? x) (+ 1 x) x)) + (persistent-set 1 2 3)))) + '(2 3 4)) + +;;; ---- persistent-map -------------------------------------------- + +(test "postwalk doubles map values" + (let* ([m (persistent-map 'a 1 'b 2)] + [m* (postwalk (lambda (x) (if (number? x) (* 2 x) x)) m)]) + (list (persistent-map-ref m* 'a) + (persistent-map-ref m* 'b))) + '(2 4)) + +;;; ---- hash-table ------------------------------------------------ + +(test "postwalk doubles hash-table values" + (let* ([h (make-hash-table)]) + (hash-put! h "a" 1) + (hash-put! h "b" 2) + (let ([h* (postwalk (lambda (x) (if (number? x) (* 3 x) x)) h)]) + (list-sort < (list (hash-ref h* "a") (hash-ref h* "b"))))) + '(3 6)) + +;;; ---- keywordize-keys ------------------------------------------- + +(test "keywordize-keys on persistent-map" + (let* ([m (persistent-map "a" 1 "b" 2)] + [m* (keywordize-keys m)]) + (list (persistent-map-ref m* (string->keyword "a")) + (persistent-map-ref m* (string->keyword "b")))) + '(1 2)) + +(test "keywordize-keys on hash-table" + (let ([h (make-hash-table)]) + (hash-put! h "x" 10) + (hash-put! h "y" 20) + (let ([h* (keywordize-keys h)]) + (list (hash-ref h* (string->keyword "x")) + (hash-ref h* (string->keyword "y"))))) + '(10 20)) + +(test "keywordize-keys preserves non-string keys" + (let* ([m (persistent-map 'sym 1 "str" 2)] + [m* (keywordize-keys m)]) + (list (persistent-map-ref m* 'sym) + (persistent-map-ref m* (string->keyword "str")))) + '(1 2)) + +;;; ---- stringify-keys -------------------------------------------- + +(test "stringify-keys on persistent-map" + (let* ([m (persistent-map (string->keyword "a") 1 + (string->keyword "b") 2)] + [m* (stringify-keys m)]) + (list (persistent-map-ref m* "a") + (persistent-map-ref m* "b"))) + '(1 2)) + +(test "stringify-keys on hash-table" + (let ([h (make-hash-table)]) + (hash-put! h (string->keyword "a") 100) + (hash-put! h (string->keyword "b") 200) + (let ([h* (stringify-keys h)]) + (list (hash-ref h* "a") (hash-ref h* "b")))) + '(100 200)) + +;;; ---- prewalk-replace / postwalk-replace ------------------------ + +(test "postwalk-replace with alist" + (postwalk-replace '((a . 1) (b . 2)) '(a (b a) c)) + '(1 (2 1) c)) + +(test "prewalk-replace with alist" + (prewalk-replace '((a . X)) '(a (a b))) + '(X (X b))) + +(test "postwalk-replace leaves non-keys alone" + (postwalk-replace '((a . 1)) '(b c (d a))) + '(b c (d 1))) + +;;; ---- improper lists -------------------------------------------- + +(test "postwalk preserves improper list tail" + (postwalk (lambda (x) (if (number? x) (* 10 x) x)) + '(1 2 . 3)) + '(10 20 . 30)) + +;;; ---- leaves stay leaves ---------------------------------------- + +(test "strings are leaves" + (postwalk (lambda (x) (if (string? x) (string-upcase x) x)) + '("a" ("b" "c"))) + '("A" ("B" "C"))) + +(test "numbers are leaves" + (postwalk (lambda (x) x) '(1 2 3)) + '(1 2 3)) + +;;; ---- Summary --------------------------------------------------- +(printf "~%std/clojure walk: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1)) --- a/tests/test-protocol.ss +++ b/tests/test-protocol.ss @@ -309,6 +309,46 @@ (extenders 'not-a-proto)) 'caught) +;;; ---- reify (anonymous protocol implementation) ----------------- + +(defprotocol Greeter + (greet1 (self n))) + +(test "reify single-method dispatch" + (let ([r (reify (greet1 (self n) (string-append "hi " n)))]) + (greet1 r "world")) + "hi world") + +(test "reify multiple methods on same instance" + (let ([r (reify