Add QuickCheck property-based testing framework
ober
aedf274dcce889ca72bb1b67f6c6380cfb1751c2
new file mode 100644 --- /dev/null +++ b/lib/std/test/quickcheck.sls @@ -0,0 +1,267 @@ +#!chezscheme +;;; (std test quickcheck) -- QuickCheck-style property-based testing +;;; +;;; A generator is a procedure that takes a `size` parameter (non-negative +;;; integer) and returns a random value. Larger sizes hint the generator to +;;; produce larger / more complex values. +;;; +;;; `check-property` runs a property over many random inputs with increasing +;;; sizes, and on failure attempts to shrink the counterexample. + +(library (std test quickcheck) + (export + ;; Core + check-property for-all quickcheck make-gen + + ;; Generators + gen-int gen-nat gen-bool gen-char gen-string + gen-list gen-vector gen-one-of gen-pair gen-choose + + ;; Combinators + gen-map gen-bind gen-filter gen-sized + + ;; Shrinking + shrink-int shrink-list shrink-string) + + (import (except (chezscheme) for-all)) + + ;; ================================================================ + ;; make-gen -- wrap a (lambda (size) ...) into a generator + ;; ================================================================ + + ;; Generators are plain procedures. make-gen is just the identity + ;; wrapper kept for API clarity. + (define (make-gen proc) + proc) + + ;; ================================================================ + ;; Primitive generators + ;; ================================================================ + + ;; Random integer in [-size, size]. + (define (gen-int size) + (if (zero? size) + 0 + (- (random (+ 1 (* 2 size))) size))) + + ;; Random non-negative integer in [0, size]. + (define (gen-nat size) + (if (zero? size) + 0 + (random (+ size 1)))) + + ;; Random boolean. + (define (gen-bool size) + (= (random 2) 0)) + + ;; Random character (printable ASCII 32-126). + (define (gen-char size) + (integer->char (+ 32 (random 95)))) + + ;; Random string of length up to size. + (define (gen-string size) + (let* ([len (random (+ size 1))] + [chars (let loop ([n len] [acc '()]) + (if (zero? n) + acc + (loop (- n 1) + (cons (gen-char size) acc))))]) + (list->string chars))) + + ;; Random list whose elements come from `elem-gen`, length up to size. + (define (gen-list elem-gen) + (lambda (size) + (let ([len (random (+ size 1))]) + (let loop ([n len] [acc '()]) + (if (zero? n) + acc + (loop (- n 1) (cons (elem-gen size) acc))))))) + + ;; Random vector whose elements come from `elem-gen`. + (define (gen-vector elem-gen) + (lambda (size) + (let ([lst ((gen-list elem-gen) size)]) + (list->vector lst)))) + + ;; Choose uniformly from a non-empty list of values. + (define (gen-one-of choices) + (lambda (size) + (list-ref choices (random (length choices))))) + + ;; Random pair from two generators. + (define (gen-pair gen-a gen-b) + (lambda (size) + (cons (gen-a size) (gen-b size)))) + + ;; Random integer in [lo, hi] (inclusive). + (define (gen-choose lo hi) + (lambda (size) + (+ lo (random (+ 1 (- hi lo)))))) + + ;; ================================================================ + ;; Generator combinators + ;; ================================================================ + + ;; Transform a generator's output. + (define (gen-map f gen) + (lambda (size) + (f (gen size)))) + + ;; Monadic bind: `f` receives the value and returns a new generator. + (define (gen-bind gen f) + (lambda (size) + (let ([v (gen size)]) + ((f v) size)))) + + ;; Keep trying until the predicate holds (with retry limit). + (define (gen-filter pred gen) + (lambda (size) + (let loop ([tries 100]) + (if (zero? tries) + (error 'gen-filter "could not satisfy predicate after 100 tries") + (let ([v (gen size)]) + (if (pred v) + v + (loop (- tries 1)))))))) + + ;; Size-dependent generator: `f` receives the size and returns a generator. + (define (gen-sized f) + (lambda (size) + ((f size) size))) + + ;; ================================================================ + ;; Shrinking + ;; ================================================================ + + ;; Shrink an integer toward 0 -- returns a list of candidates. + (define (shrink-int n) + (cond + [(= n 0) '()] + [(> n 0) + ;; 0, halved, and predecessor + (let ([candidates (list 0 (quotient n 2) (- n 1))]) + ;; remove duplicates and n itself, keep only < n + (filter (lambda (c) (and (>= c 0) (< c n))) candidates))] + [else + ;; Negative: try 0, negate, halved toward 0, and successor + (let ([candidates (list 0 (- n) (- (quotient (- n) 2)) (+ n 1))]) + (filter (lambda (c) (< (abs c) (abs n))) candidates))])) + + ;; Shrink a list by removing elements one at a time, plus try empty. + (define (shrink-list lst) + (if (null? lst) + '() + (cons '() + (let loop ([i 0] [acc '()]) + (if (>= i (length lst)) + (reverse acc) + (loop (+ i 1) + (cons (append (list-head lst i) + (list-tail lst (+ i 1))) + acc))))))) + + ;; Shrink a string by converting to list, shrinking that, then back. + (define (shrink-string s) + (map list->string (shrink-list (string->list s)))) + + ;; ================================================================ + ;; Property running + ;; ================================================================ + + ;; Try to shrink the failing inputs. `inputs` is a list of generated + ;; values, `shrinkers` is a parallel list of (value -> list-of-candidates) + ;; procedures, and `prop` is a procedure taking the input list and + ;; returning truthy on success. + (define (shrink-inputs inputs shrinkers prop) + ;; Simple greedy shrink: iterate over each position, try candidates. + (let loop ([current inputs] [fuel 100]) + (if (zero? fuel) + current + (let pos-loop ([pos 0] [improved? #f] [cur current]) + (if (>= pos (length cur)) + (if improved? + (loop cur (- fuel 1)) + cur) + (let ([shrink-fn (if (< pos (length shrinkers)) + (list-ref shrinkers pos) + (lambda (x) '()))]) + (let cand-loop ([cands (shrink-fn (list-ref cur pos))]) + (if (null? cands) + (pos-loop (+ pos 1) improved? cur) + (let ([new-inputs + (let build ([i 0] [xs cur]) + (cond + [(null? xs) '()] + [(= i pos) (cons (car cands) (cdr xs))] + [else (cons (car xs) (build (+ i 1) (cdr xs)))]))]) + (if (guard (exn [#t #t]) ;; exception counts as failure + (not (apply prop new-inputs))) + ;; Shrunk successfully + (pos-loop (+ pos 1) #t new-inputs) + ;; Candidate didn't fail, try next + (cand-loop (cdr cands)))))))))))) + + ;; Infer a default shrinker from the type of a value. + (define (default-shrinker v) + (cond + [(integer? v) shrink-int] + [(string? v) shrink-string] + [(list? v) shrink-list] + [else (lambda (x) '())])) + + ;; ---- check-property ---- + ;; Run a property `n-trials` times with increasing sizes. + ;; `gen-list-arg` is a list of generators. + ;; `prop` is a procedure that takes as many arguments as generators + ;; and returns truthy on success. + ;; Returns a result alist: ((status . pass/fail) ...) + (define (check-property n-trials generators prop) + (let loop ([trial 0]) + (if (>= trial n-trials) + `((status . pass) (trials . ,n-trials)) + (let* ([size (min trial 100)] + [inputs (map (lambda (g) (g size)) generators)]) + (let ([ok? (guard (exn [#t #f]) + (apply prop inputs))]) + (if ok? + (loop (+ trial 1)) + ;; Failure -- attempt shrinking + (let* ([shrinkers (map default-shrinker inputs)] + [shrunk (shrink-inputs inputs shrinkers prop)]) + `((status . fail) + (trial . ,trial) + (original . ,inputs) + (shrunk . ,shrunk))))))))) + + ;; ---- for-all macro ---- + ;; (for-all ([x gen-int] [y gen-string]) body ...) + ;; Expands into a (check-property ...) call. + ;; Each binding's generator is used directly, and body is wrapped + ;; in a lambda. Returns the check-property result alist. + (define-syntax for-all + (syntax-rules () + [(_ ([var gen] ...) body ...) + (check-property 100 + (list gen ...) + (lambda (var ...) body ...))])) + + ;; ---- quickcheck ---- + ;; Main entry point: + ;; (quickcheck n-trials property) + ;; where property is (lambda (gen-fn) ...) and gen-fn takes a generator + ;; and returns a random value at the current trial's size. + ;; + ;; Returns result alist. + (define (quickcheck n-trials property) + (let loop ([trial 0]) + (if (>= trial n-trials) + `((status . pass) (trials . ,n-trials)) + (let* ([size (min trial 100)] + [gen-fn (lambda (gen) (gen size))] + [ok? (guard (exn [#t #f]) + (property gen-fn))]) + (if ok? + (loop (+ trial 1)) + `((status . fail) (trial . ,trial))))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-quickcheck.ss @@ -0,0 +1,321 @@ +#!chezscheme +;;; tests/test-quickcheck.ss -- Tests for (std test quickcheck) + +(import (except (chezscheme) for-all) (std test quickcheck)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail-count (+ fail-count 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) + (format "~s" exn)))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass-count (+ pass-count 1)) (printf " ok ~a~%" name)) + (begin (set! fail-count (+ fail-count 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(define-syntax test-pred + (syntax-rules () + [(_ name pred expr) + (guard (exn [#t (set! fail-count (+ fail-count 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) + (format "~s" exn)))]) + (let ([got expr]) + (if (pred got) + (begin (set! pass-count (+ pass-count 1)) (printf " ok ~a~%" name)) + (begin (set! fail-count (+ fail-count 1)) + (printf "FAIL ~a: ~s did not satisfy ~a~%" name got 'pred)))))])) + +(printf "~%--- QuickCheck Tests ---~%~%") + +;; ================================================================ +;; 1. Primitive generators produce correct types +;; ================================================================ +(printf "-- Generator type checks --~%") + +(test-pred "gen-int returns integer" + integer? (gen-int 10)) + +(test-pred "gen-nat returns non-negative" + (lambda (n) (and (integer? n) (>= n 0))) + (gen-nat 10)) + +(test-pred "gen-bool returns boolean" + boolean? (gen-bool 5)) + +(test-pred "gen-char returns char" + char? (gen-char 5)) + +(test-pred "gen-string returns string" + string? (gen-string 10)) + +;; ================================================================ +;; 2. gen-int range respects size +;; ================================================================ +(printf "~%-- gen-int respects size --~%") + +(test "gen-int size 0 is 0" (gen-int 0) 0) + +;; Run many times, all should be in [-size, size] +(let ([size 5]) + (test-pred "gen-int within bounds" + (lambda (x) x) + (let loop ([n 200] [all-ok? #t]) + (if (zero? n) + all-ok? + (let ([v (gen-int size)]) + (loop (- n 1) + (and all-ok? (>= v (- size)) (<= v size)))))))) + +;; ================================================================ +;; 3. gen-nat is always non-negative +;; ================================================================ +(printf "~%-- gen-nat always non-negative --~%") + +(test-pred "gen-nat many trials" + (lambda (x) x) + (let loop ([n 200] [ok? #t]) + (if (zero? n) + ok? + (loop (- n 1) (and ok? (>= (gen-nat 20) 0)))))) + +;; ================================================================ +;; 4. gen-list produces lists of correct type +;; ================================================================ +(printf "~%-- gen-list --~%") + +(let ([gen (gen-list gen-int)]) + (test-pred "gen-list returns list" + list? (gen 10)) + (test-pred "gen-list elements are integers" + (lambda (lst) (andmap (lambda (x) (integer? x)) lst)) + (gen 10))) + +;; ================================================================ +;; 5. gen-vector produces vectors +;; ================================================================ +(printf "~%-- gen-vector --~%") + +(let ([gen (gen-vector gen-int)]) + (test-pred "gen-vector returns vector" + vector? (gen 10))) + +;; ================================================================ +;; 6. gen-one-of picks from the list +;; ================================================================ +(printf "~%-- gen-one-of --~%") + +(let ([gen (gen-one-of '(a b c))]) + (test-pred "gen-one-of from set" + (lambda (v) (memv v '(a b c))) + (gen 5))) + +;; ================================================================ +;; 7. gen-pair makes pairs +;; ================================================================ +(printf "~%-- gen-pair --~%") + +(let ([gen (gen-pair gen-int gen-bool)]) + (let ([p (gen 10)]) + (test-pred "gen-pair returns pair" pair? p) + (test-pred "gen-pair car is integer" integer? (car p)) + (test-pred "gen-pair cdr is boolean" boolean? (cdr p)))) + +;; ================================================================ +;; 8. gen-choose range +;; ================================================================ +(printf "~%-- gen-choose --~%") + +(let ([gen (gen-choose 5 10)]) + (test-pred "gen-choose in range" + (lambda (x) x) + (let loop ([n 200] [ok? #t]) + (if (zero? n) + ok? + (let ([v (gen 0)]) + (loop (- n 1) (and ok? (>= v 5) (<= v 10)))))))) + +;; ================================================================ +;; 9. Generator combinators +;; ================================================================ +(printf "~%-- Combinators --~%") + +;; gen-map +(test-pred "gen-map doubles" + even? + ((gen-map (lambda (n) (* 2 n)) gen-nat) 10)) + +;; gen-bind +(let ([gen (gen-bind gen-nat + (lambda (n) (gen-choose 0 (max 1 n))))]) + (test-pred "gen-bind produces integer" + integer? (gen 10))) + +;; gen-filter +(let ([gen (gen-filter even? gen-int)]) + (test-pred "gen-filter only evens" + even? (gen 20))) + +;; gen-sized +(let ([gen (gen-sized (lambda (sz) (gen-choose 0 (max 1 sz))))]) + (test-pred "gen-sized produces integer" + integer? (gen 10))) + +;; ================================================================ +;; 10. make-gen +;; ================================================================ +(printf "~%-- make-gen --~%") + +(let ([gen (make-gen (lambda (size) (* size 2)))]) + (test "make-gen custom" (gen 5) 10)) + +;; ================================================================ +;; 11. Shrinking +;; ================================================================ +(printf "~%-- Shrinking --~%") + +;; shrink-int +(test "shrink-int 0" (shrink-int 0) '()) +(test-pred "shrink-int 10 contains 0" + (lambda (lst) (memv 0 lst)) + (shrink-int 10)) +(test-pred "shrink-int 10 all smaller" + (lambda (lst) (andmap (lambda (c) (< c 10)) lst)) + (shrink-int 10)) +(test-pred "shrink-int -5 all closer to 0" + (lambda (lst) (andmap (lambda (c) (< (abs c) 5)) lst)) + (shrink-int -5)) + +;; shrink-list +(test "shrink-list empty" (shrink-list '()) '()) +(test-pred "shrink-list starts with empty" + (lambda (lst) (and (pair? lst) (null? (car lst)))) + (shrink-list '(1 2 3))) +(test-pred "shrink-list all shorter" + (lambda (candidates) + (andmap (lambda (c) (< (length c) 3)) candidates)) + (shrink-list '(1 2 3))) + +;; shrink-string +(test-pred "shrink-string produces strings" + (lambda (lst) (andmap string? lst)) + (shrink-string "hello")) +(test-pred "shrink-string all shorter" + (lambda (lst) (andmap (lambda (s) (< (string-length s) 5)) lst)) + (shrink-string "hello")) + +;; ================================================================ +;; 12. check-property -- passing property +;; ================================================================ +(printf "~%-- check-property --~%") + +(let ([result (check-property 50 (list gen-int gen-int) + (lambda (a b) (= (+ a b) (+ b a))))]) + (test "commutativity passes" + (cdr (assq 'status result)) + 'pass) + (test "ran 50 trials" + (cdr (assq 'trials result)) + 50)) + +;; ================================================================ +;; 13. check-property -- failing property detected +;; ================================================================ +(printf "~%-- check-property detects failure --~%") + +(let ([result (check-property 100 (list gen-nat) + (lambda (n) (< n 50)))]) + (test "large-nat fails" + (cdr (assq 'status result)) + 'fail) + (test-pred "shrunk result present" + (lambda (r) (assq 'shrunk r)) + result)) + +;; ================================================================ +;; 14. check-property -- shrinking works +;; ================================================================ +(printf "~%-- Shrinking finds minimal counterexample --~%") + +;; Property: n < 10. Minimal counterexample is 10. +(let ([result (check-property 200 (list gen-nat) + (lambda (n) (< n 10)))]) + (test "fails as expected" + (cdr (assq 'status result)) + 'fail) + (let ([shrunk (cdr (assq 'shrunk result))]) + (test-pred "shrunk to minimal" + (lambda (s) (and (pair? s) (= (car s) 10))) + shrunk))) + +;; ================================================================ +;; 15. for-all macro -- passing +;; ================================================================ +(printf "~%-- for-all macro --~%") + +(let ([result (for-all ([x gen-int] [y gen-int]) + (integer? (+ x y)))]) + (test "for-all pass" + (cdr (assq 'status result)) + 'pass)) + +;; ================================================================ +;; 16. for-all macro -- failing +;; ================================================================ +(let ([result (for-all ([x gen-nat]) + (< x 20))]) + (test "for-all detects failure" + (cdr (assq 'status result)) + 'fail)) + +;; ================================================================ +;; 17. quickcheck main entry +;; ================================================================ +(printf "~%-- quickcheck --~%") + +(let ([result (quickcheck 100 + (lambda (gen-fn) + (let ([n (gen-fn gen-int)]) + (= (+ n 0) n))))]) + (test "quickcheck pass" + (cdr (assq 'status result)) + 'pass)) + +(let ([result (quickcheck 200 + (lambda (gen-fn) + (let ([n (gen-fn gen-nat)]) + (< n 30))))]) + (test "quickcheck fail" + (cdr (assq 'status result)) + 'fail)) + +;; ================================================================ +;; 18. check-property catches exceptions as failures +;; ================================================================ +(printf "~%-- Exception handling --~%") + +(let ([result (check-property 10 (list gen-int) + (lambda (n) + (when (> n 3) + (error 'test "boom")) + #t))]) + ;; It should eventually fail since gen-int will produce > 3 + ;; (at size >= 4, there's a chance) + ;; But with size starting at 0 and going up, size 4+ can produce 4 + ;; Let's just verify it doesn't crash the whole test suite + (test-pred "exception property returns alist" + (lambda (r) (assq 'status r)) + result)) + +;; ================================================================ +;; Summary +;; ================================================================ +(printf "~%--- Results: ~a passed, ~a failed ---~%" pass-count fail-count) +(when (> fail-count 0) + (exit 1))