Random testing based on data/enumerate
This commit is contained in:
parent
e7c9bcfa8f
commit
88a5522d2f
|
@ -0,0 +1,120 @@
|
|||
#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)
|
||||
check-property*
|
||||
check-property
|
||||
reject-test
|
||||
==>)
|
||||
|
||||
(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 (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 100]
|
||||
#:max-rejected-ratio [max-rejected-ratio 10]
|
||||
#:min-rejected-tests [min-rejected-tests (* max-rejected-ratio max-tests)]
|
||||
#:name [name (object-name prop)]
|
||||
#:quiet? [quiet? #f]
|
||||
. 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 (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 100]
|
||||
#:max-rejected-ratio [max-rejected-ratio 10]
|
||||
#:min-rejected-tests [min-rejected-tests (* max-rejected-ratio max-tests)]
|
||||
#:name [name (object-name prop)]
|
||||
#:quiet? [quiet? #f]
|
||||
. 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
|
||||
#: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))
|
Loading…
Reference in New Issue