syndicate-2017/racket/syndicate/random-test.rkt

137 lines
6.0 KiB
Racket

#lang racket/base
;; Random testing based on data/enumerate
(provide (struct-out exn:fail:reject-test)
(struct-out property-check-result)
(struct-out property-check-result:ok)
(struct-out property-check-result:fail)
(struct-out property-check-result:gave-up)
(struct-out property-check-result:invalid-prop)
random-test:max-tests
random-test:max-rejected-ratio
random-test:index-limit
random-test:quiet?
check-property*
check-property
reject-test
==>
random-instance)
(require racket/match)
(require rackunit)
(require data/enumerate)
(require data/enumerate/lib)
(define-logger random-test)
(struct exn:fail:reject-test exn:fail ())
(struct property-check-result (name prop) #:transparent)
(struct property-check-result:ok property-check-result (test-count rejected-count) #:transparent)
(struct property-check-result:fail property-check-result (test-count test-case test-case-index)
#:transparent)
(struct property-check-result:gave-up property-check-result:ok () #:transparent)
(struct property-check-result:invalid-prop property-check-result:fail () #:transparent)
(define random-test:max-tests (make-parameter 100))
(define random-test:max-rejected-ratio (make-parameter 10))
(define random-test:index-limit (make-parameter #f))
(define random-test:quiet? (make-parameter #f))
(define (summarise-check-count name n-tests n-rejected)
(printf "\rChecking ~a; ~a tests / ~a rejected" name n-tests n-rejected)
(flush-output))
(define (check-property* prop
#:max-tests [max-tests (random-test:max-tests)]
#:max-rejected-ratio [max-rejected-ratio (random-test:max-rejected-ratio)]
#:min-rejected-tests [min-rejected-tests (* max-rejected-ratio max-tests)]
#:index-limit [index-limit (random-test:index-limit)]
#:name [name (object-name prop)]
#:quiet? [quiet? (random-test:quiet?)]
. enums)
(define args/e (apply list/e enums))
(begin0
(let loop ((n-tests 0)
(n-rejected 0))
(define rejected-ratio (if (zero? n-tests) 0 (/ n-rejected n-tests)))
(cond
[(and (>= n-rejected min-rejected-tests)
(>= rejected-ratio max-rejected-ratio))
(unless quiet? (summarise-check-count name n-tests n-rejected))
(property-check-result:gave-up name prop n-tests n-rejected)]
[(>= n-tests max-tests)
(unless quiet? (summarise-check-count name n-tests n-rejected))
(property-check-result:ok name prop n-tests n-rejected)]
[else
(define args-index (if index-limit (random index-limit) (random-index args/e)))
(define args (from-nat args/e args-index))
(with-handlers [[exn:fail:reject-test? (lambda (_exn) (loop n-tests (+ n-rejected 1)))]]
(unless quiet? (summarise-check-count name n-tests n-rejected))
(match (apply prop args)
[#t
(unless quiet?
(log-random-test-debug "Passed test ~a with index ~a and args ~a"
name
args-index
args))
(loop (+ n-tests 1) n-rejected)]
[#f (property-check-result:fail name prop n-tests args args-index)]
[_ (property-check-result:invalid-prop name prop n-tests args args-index)]))]))
(unless quiet? (newline))))
(define (signal-failure f message)
(match-define (property-check-result:fail name prop n-tests args args-index) f)
(with-check-info*
(list* (check-info 'property-name name)
(check-info 'property-prop prop)
(check-info 'after-n-tests n-tests)
(check-info 'test-case-index args-index)
(for/list [(i (in-naturals)) (a (in-list args))]
(check-info (string->symbol (format "property-arg-~a" i)) a)))
(lambda () (fail-check message))))
(define (check-property prop
#:max-tests [max-tests (random-test:max-tests)]
#:max-rejected-ratio [max-rejected-ratio (random-test:max-rejected-ratio)]
#:min-rejected-tests [min-rejected-tests (* max-rejected-ratio max-tests)]
#:index-limit [index-limit (random-test:index-limit)]
#:name [name (object-name prop)]
#:quiet? [quiet? (random-test:quiet?)]
. enums)
((current-check-around)
(lambda ()
(define result (apply check-property* prop enums
#:max-tests max-tests
#:max-rejected-ratio max-rejected-ratio
#:min-rejected-tests min-rejected-tests
#:index-limit index-limit
#:name name
#:quiet? quiet?))
(match result
[(? property-check-result:invalid-prop? f)
(signal-failure f (format "Invalid property ~a (expected #t or #f)" name))]
[(? property-check-result:fail? f)
(signal-failure f (format "Failed check of property ~a" name))]
[(property-check-result:gave-up name prop n-tests n-rejected)
(log-random-test-warning
"Gave up checking property ~a after ~a passed tests / ~a rejected tests"
name
n-tests
n-rejected)]
[(property-check-result:ok name prop n-tests n-rejected)
(log-random-test-info
"OK property ~a after ~a passed tests / ~a rejected tests"
name
n-tests
n-rejected)]))))
(define (reject-test [message "Rejecting test case because of precondition failure"])
(raise (exn:fail:reject-test message (current-continuation-marks))))
(define-syntax-rule (==> precondition expr)
(if (not precondition) (reject-test) expr))
(define (random-instance e)
(from-nat e (random-index e)))