suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branches/mike/quickcheck:

Browse Source 
Add QuickCheck-based property testing to the DeinProgramm/DMdA languages.

svn: r15901
This commit is contained in:
Mike Sperber 2009-09-07 16:31:18 +00:00
parent 3d3cb4cbd3
commit 89ec442c04
19 changed files with 1129 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/deinprogramm/DMdA-advanced.ss
View File

@ -10,6 +10,7 @@
define-record-procedures-parametric define-record-procedures-parametric-2
.. ... .... ..... ......
check-expect check-within check-error
check-property for-all ==> expect expect-within
: define-contract -> mixed one-of predicate combined property
number real rational integer natural boolean true false string symbol empty-list unspecific
chocolate-cookie)

1
collects/deinprogramm/DMdA-assignments.ss
View File

@ -10,6 +10,7 @@
define-record-procedures-parametric define-record-procedures-parametric-2
.. ... .... ..... ......
check-expect check-within check-error
check-property for-all ==> expect expect-within
: define-contract -> mixed one-of predicate combined property
number real rational integer natural boolean true false string empty-list unspecific
chocolate-cookie)

1
collects/deinprogramm/DMdA-beginner.ss
View File

@ -6,6 +6,7 @@
define-record-procedures define-record-procedures-parametric
.. ... .... ..... ......
check-expect check-within check-error
check-property for-all ==> expect expect-within
: define-contract -> mixed one-of predicate combined property
number real rational integer natural boolean true false string empty-list
chocolate-cookie)

1
collects/deinprogramm/DMdA-vanilla.ss
View File

@ -6,6 +6,7 @@
define-record-procedures define-record-procedures-parametric
.. ... .... ..... ......
check-expect check-within check-error
check-property for-all ==> expect expect-within
: define-contract -> mixed one-of predicate combined property
number real rational integer natural boolean true false string empty-list
chocolate-cookie)

94
collects/deinprogramm/DMdA.ss
View File

@ -2,9 +2,13 @@
(require syntax/docprovide)
(require test-engine/scheme-tests)
(require test-engine/scheme-tests
(lib "test-info.scm" "test-engine")
scheme/class)
(require deinprogramm/contract/module-begin
deinprogramm/contract/contract
deinprogramm/contract/contract-test-engine
deinprogramm/contract/contract-syntax)
(require (for-syntax scheme/base)
@ -12,8 +16,13 @@
(require deinprogramm/define-record-procedures)
(require (only-in lang/private/teachprims beginner-equal? beginner-equal~?))
(require (for-syntax deinprogramm/syntax-checkers))
(require (rename-in deinprogramm/quickcheck/quickcheck
(property quickcheck:property)))
(provide provide lib planet rename-out require #%datum #%module-begin #%top-interaction) ; so we can use this as a language
(provide cons) ; hack, for the stepper
@ -61,6 +70,11 @@
(provide DMdA-advanced-lambda
DMdA-advanced-define)
(provide for-all ==>
check-property
expect
expect-within)
(provide quote)
(provide-and-document
@ -844,18 +858,18 @@
""
(string-append (car l) (strings-list->string (cdr l)))))
(define-contract integer (predicate integer?))
(define-contract number (predicate number?))
(define-contract rational (predicate rational?))
(define-contract real (predicate real?))
(define integer (contract/arbitrary arbitrary-integer (predicate integer?)))
(define number (contract/arbitrary arbitrary-real (predicate number?)))
(define rational (contract/arbitrary arbitrary-rational (predicate rational?)))
(define real (contract/arbitrary arbitrary-real (predicate real?)))
(define (natural? x)
(and (integer? x)
(not (negative? x))))
(define-contract natural (predicate natural?))
(define natural (contract/arbitrary arbitrary-natural (predicate natural?)))
(define-contract boolean (predicate boolean?))
(define boolean (contract/arbitrary arbitrary-boolean (predicate boolean?)))
(define (true? x)
(eq? x #t))
@ -863,12 +877,12 @@
(define (false? x)
(eq? x #f))
(define-contract true (predicate true?))
(define-contract false (predicate false?))
(define-contract true (one-of #f))
(define-contract false (one-of #f))
(define-contract string (predicate string?))
(define-contract symbol (predicate symbol?))
(define-contract empty-list (predicate empty?))
(define string (contract/arbitrary arbitrary-string (predicate string?)))
(define symbol (contract/arbitrary arbitrary-symbol (predicate symbol?)))
(define-contract empty-list (one-of empty))
(define-contract unspecific (predicate (lambda (_) #t)))
@ -951,3 +965,59 @@
stx)))))))))
(values (proc #f)
(proc #t))))
; QuickCheck
(define-syntax (for-all stx)
(syntax-case stx ()
((_ ((?id ?arb) ...) ?body)
(with-syntax ((((?id ?arb) ...)
;; #### check errors, idness
(map (lambda (pr)
(syntax-case pr ()
((?id ?contract)
(with-syntax ((?error-call
(syntax/loc #'?contract (error "Vertrag hat keinen Generator"))))
#'(?id
(or (contract-arbitrary (contract ?contract))
?error-call))))))
(syntax->list #'((?id ?arb) ...)))))
#'(quickcheck:property
((?id ?arb) ...) ?body)))))
(define-syntax (check-property stx)
(unless (memq (syntax-local-context) '(module top-level))
(raise-syntax-error
#f "`check-property' muss ganz außen stehen" stx))
(syntax-case stx ()
((_ ?prop)
(stepper-syntax-property
(check-expect-maker stx #'check-property-error #'?prop '()
'comes-from-check-property)
'stepper-skip-completely
#t))
(_ (raise-syntax-error 'check-expect "`check-property' erwartet einen einzelnen Operanden"
stx))))
(define (check-property-error test src-info test-info)
(let ((info (send test-info get-info)))
(send info add-check)
(with-handlers ((exn?
(lambda (e)
(send info property-error e src-info)
(raise e))))
(call-with-values
(lambda ()
(quickcheck-results (test)))
(lambda (ntest stamps result)
(if (check-result? result)
(begin
(send info property-failed result src-info)
#f)
#t))))))
(define (expect v1 v2)
(quickcheck:property () (beginner-equal? v1 v2)))
(define (expect-within v1 v2 epsilon)
(quickcheck:property () (beginner-equal~? v1 v2 epsilon)))

10
collects/deinprogramm/contract/contract-syntax.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(provide :
contract
contract contract/arbitrary
define-contract
define/contract define-values/contract
-> mixed one-of predicate combined property)
@ -116,6 +116,14 @@
((_ ?name ?contr)
(parse-contract (syntax->datum #'?name) #'?contr)))))
(define-syntax contract/arbitrary
(lambda (stx)
(syntax-case stx ()
((_ ?arb ?contr . ?rest)
#'(let ((contr (contract ?contr . ?rest)))
(set-contract-arbitrary! contr ?arb)
contr)))))
(define-syntax define-contract
(lambda (stx)
(syntax-case stx ()

17
collects/deinprogramm/contract/contract-test-display.ss
View File

@ -14,7 +14,8 @@
(lib "test-engine/test-engine.scm")
(lib "test-engine/print.ss")
deinprogramm/contract/contract
deinprogramm/contract/contract-test-engine)
deinprogramm/contract/contract-test-engine
deinprogramm/quickcheck/quickcheck)
(define contract-test-display%
(class* object% ()
@ -229,7 +230,19 @@
(formatter (expected-error-value fail))
(expected-error-message fail))]
[(message-error? fail)
(for-each print-formatted (message-error-strings fail))])
(for-each print-formatted (message-error-strings fail))]
[(property-fail? fail)
(print-string "Eigenschaft falsifizierbar mit")
(for-each (lambda (arguments)
(for-each (lambda (p)
(if (car p)
(print " ~a = ~F" (car p) (formatter (cdr p)))
(print "~F" (formatter (cdr p)))))
arguments))
(result-arguments-list (property-fail-result fail)))]
[(property-error? fail)
(print "`check-property' bekam den folgenden Fehler~n:: ~a"
(property-error-message fail))])
(print-string "\n")))
;; make-error-link: text% check-fail exn src editor -> void

14
collects/deinprogramm/contract/contract-test-engine.ss
View File

@ -4,7 +4,9 @@
contract-violation?
contract-violation-obj contract-violation-contract contract-violation-message
contract-violation-blame contract-violation-srcloc
contract-got? contract-got-value contract-got-format)
contract-got? contract-got-value contract-got-format
property-fail? property-fail-result
property-error? make-property-error property-error-message property-error-exn)
(require scheme/class
(lib "test-engine/test-engine.scm")
@ -96,6 +98,9 @@
(define-struct contract-violation (obj contract message srcloc blame))
(define-struct (property-fail check-fail) (result))
(define-struct (property-error check-fail) (message exn))
(define contract-test-info%
(class* test-info-base% ()
@ -129,5 +134,12 @@
(inner (void) contract-failed obj contract message))
(define/public (failed-contracts) (reverse contract-violations))
(inherit add-check-failure)
(define/pubment (property-failed result src-info)
(add-check-failure (make-property-fail src-info (test-format) result) #f))
(define/pubment (property-error exn src-info)
(add-check-failure (make-property-error src-info (test-format) (exn-message exn) exn) exn))
(super-instantiate ())))

104
collects/deinprogramm/contract/contract.ss
View File

@ -2,6 +2,7 @@
(provide contract?
contract-name contract-syntax
contract-arbitrary set-contract-arbitrary!
contract-violation-proc
call-with-contract-violation-proc
make-delayed-contract
@ -20,12 +21,20 @@
(for-syntax scheme/base)
(for-syntax stepper/private/shared))
(require deinprogramm/quickcheck/quickcheck)
; name may be #f
; enforcer: contract val -> val
;
; syntax: syntax data from where the contract was defined
(define-struct contract (name enforcer syntax))
(define-struct contract (name enforcer syntax (arbitrary-promise #:mutable)))
(define (contract-arbitrary ctr)
(force (contract-arbitrary-promise ctr)))
(define (set-contract-arbitrary! ctr arb)
(set-contract-arbitrary-promise! ctr (delay arb)))
(define (contract-update-syntax ctr stx)
(struct-copy contract ctr (syntax stx)))
@ -47,7 +56,9 @@
(make-contract name
(lambda (self obj)
((contract-enforcer (force promise)) self obj))
syntax))
syntax
(delay
(force (contract-arbitrary-promise (force promise))))))
(define (make-property-contract name access contract syntax)
(let ((enforce (contract-enforcer contract)))
@ -55,7 +66,8 @@
(lambda (self obj)
(enforce self (access obj)) ; #### problematic: enforcement doesn't stick
obj)
syntax)))
syntax
#f)))
(define (make-predicate-contract name predicate-promise syntax)
(make-contract
@ -66,7 +78,8 @@
(begin
(contract-violation obj self #f #f)
obj)))
syntax))
syntax
#f))
(define (make-type-variable-contract name syntax)
(make-predicate-contract name (lambda (obj) #t) syntax))
@ -102,35 +115,62 @@
(go-on))))
(else
(go-on)))))
syntax))
syntax
(delay
(lift->arbitrary arbitrary-list arg-contract))))
(define (lift->arbitrary proc . contracts)
(let ((arbitraries (map force (map contract-arbitrary-promise contracts))))
(if (andmap values arbitraries)
(apply proc arbitraries)
#f)))
(define (make-mixed-contract name alternative-contracts syntax)
(make-contract
name
(lambda (self obj)
(let loop ((alternative-contracts alternative-contracts))
(if (null? alternative-contracts)
(begin
(contract-violation obj self #f #f)
obj)
((let/ec exit
(let ((enforced
(call-with-contract-violation-proc
(lambda (contract syntax msg blame)
(exit (lambda () (loop (cdr alternative-contracts)))))
(lambda ()
(let ((ctr (car alternative-contracts)))
(if (eq? ctr self)
(raise
(make-exn:fail:contract
(string->immutable-string
(if name
(format "rekursiver Vertrag: ~a" name)
"rekursiver Vertrag"))
(current-continuation-marks)))
(apply-contract ctr obj)))))))
(lambda () enforced)))))))
syntax))
(cond
((null? alternative-contracts)
(contract-violation obj self #f #f)
obj)
((eq? (car alternative-contracts) self)
(raise
(make-exn:fail:contract
(string->immutable-string
(if name
(format "rekursiver Vertrag: ~a" name)
"rekursiver Vertrag"))
(current-continuation-marks))))
(else
(check-contract (car alternative-contracts)
obj
values
(lambda () (loop (cdr alternative-contracts))))))))
syntax
(delay
(let ((arbitraries (map force (map contract-arbitrary-promise alternative-contracts))))
(if (andmap values arbitraries)
(arbitrary-mixed
(map (lambda (ctr arb)
(cons (contract->predicate ctr)
arb))
alternative-contracts arbitraries))
#f)))))
(define (check-contract ctr val success fail)
((let/ec exit
(let ((enforced
(call-with-contract-violation-proc
(lambda (contract syntax msg blame)
(exit fail))
(lambda ()
(apply-contract ctr val)))))
(lambda () (success enforced))))))
(define (contract->predicate ctr)
(lambda (val)
(check-contract ctr val (lambda (_) #t) (lambda () #f))))
(define (make-combined-contract name contracts syntax)
(make-contract
@ -151,7 +191,8 @@
(lambda () obj)
(loop (cdr contracts)
(apply-contract (car contracts) obj))))))))))
syntax))
syntax
#f))
(define (make-case-contract name cases syntax)
(make-contract
@ -166,7 +207,8 @@
obj)
(else
(loop (cdr cases))))))
syntax))
syntax
(delay (apply arbitrary-one-of equal? cases))))
(define-struct procedure-to-blame (proc syntax))
@ -220,7 +262,9 @@
(old-violation-proc obj contract message blame-syntax))
(lambda ()
(apply-contract return-contract retval))))))))))))))
syntax)))
syntax
(delay
(apply lift->arbitrary arbitrary-procedure return-contract arg-contracts)))))
;; Matthew has promised a better way of doing this in the future.
(define (attach-name name thing)

12
collects/deinprogramm/quickcheck/info.ss Normal file
View File

@ -0,0 +1,12 @@
(module info (lib "infotab.ss" "setup")
(define name "DeinProgramm - QuickCheck")
(define compile-omit-files
'("examples.scm"
"packages.scm"
"quickcheck-test.scm"
"quickcheck.scm"
"random.scm")))

658
collects/deinprogramm/quickcheck/quickcheck.scm Normal file
View File

@ -0,0 +1,658 @@
; QuickCheck clone
(define-record-type :generator
(make-generator proc)
generator?
;; int(size) random-generator -> val
(proc generator-proc))
(define (lift->generator proc . gens)
(make-generator
(lambda (size rgen)
(apply proc
(map (lambda (gen)
((generator-proc gen) size rgen))
gens)))))
; [lower, upper]
(define (choose-integer lower upper)
(make-generator
(lambda (size rgen)
(call-with-values
(lambda ()
(random-integer rgen lower upper))
(lambda (n _)
n)))))
(define (choose-real lower upper)
(make-generator
(lambda (size rgen)
(call-with-values
(lambda ()
(random-real rgen lower upper))
(lambda (n _)
n)))))
(define choose-ascii-char
(lift->generator integer->char (choose-integer 0 127)))
(define max-scalar-value #x10FFFF)
(define gap-start #xD800)
(define gap-end #xE000)
(define gap-size (- gap-end gap-start))
(define (choose-char lower upper)
(make-generator
(lambda (size rgen)
(call-with-values
(lambda ()
(random-integer rgen (char->integer lower)
(min (char->integer upper)
(- max-scalar-value gap-size))))
(lambda (n _)
(integer->char
(if (< n gap-start)
n
(+ n gap-size))))))))
; int (generator a) -> (generator a)
(define (variant v gen)
(let ((proc (generator-proc gen)))
(make-generator
(lambda (size rgen)
(let loop ((v (+ 1 v))
(rgen rgen))
(if (zero? v)
(proc size rgen)
(call-with-values
(lambda ()
(random-generator-split rgen))
(lambda (rgen1 rgen2)
(loop (- v 1) rgen2)))))))))
; int random-gen (generator a) -> a
(define (generate n rgen gen)
(call-with-values
(lambda ()
(random-integer rgen 0 n))
(lambda (size nrgen)
((generator-proc gen) size nrgen))))
; (vals -> (generator b)) -> (generator (vals -> b))
(define (promote proc)
(make-generator
(lambda (size rgen)
(lambda vals
(let ((g (apply proc vals)))
((generator-proc g) size rgen))))))
; (int -> (generator a)) -> (generator a)
(define (sized proc)
(make-generator
(lambda (size rgen)
(let ((g (proc size)))
((generator-proc g) size rgen)))))
; (list a) -> (generator a)
(define (choose-one-of lis)
(lift->generator (lambda (n)
(list-ref lis n))
(choose-integer 0 (- (length lis) 1))))
; vector from the paper
; (generator a) int -> (generator (list a))
(define (choose-list el-gen n)
(let recur ((n n))
(if (zero? n)
(return '())
(>>= el-gen
(lambda (val)
(>>= (recur (- n 1))
(lambda (rest)
(return (cons val rest)))))))))
; (generator char) int -> (generator string)
(define (choose-string char-gen n)
(lift->generator list->string (choose-list char-gen n)))
(define (choose-symbol char-gen n)
(>>= (choose-string char-gen n)
(lambda (s)
(return (string->symbol s)))))
(define (choose-vector el-gen n)
(lift->generator list->vector (choose-list el-gen n)))
; for transliteration from Haskell
(define (return val)
(make-generator
(lambda (size rgen)
val)))
(define (>>= m1 k)
(let ((proc1 (generator-proc m1)))
(make-generator
(lambda (size rgen)
(call-with-values
(lambda ()
(random-generator-split rgen))
(lambda (rgen1 rgen2)
(let ((gen (k (proc1 size rgen1))))
((generator-proc gen) size rgen2))))))))
(define (sequence gens)
(if (null? gens)
(return '())
(>>= (car gens)
(lambda (val)
(>>= (sequence (cdr gens))
(lambda (rest)
(return (cons val rest))))))))
; for export
(define generator-unit return)
(define generator-bind >>=)
(define generator-sequence sequence)
; (list (generator a)) -> (generator a)
(define (choose-mixed gens)
(>>= (choose-one-of gens)
values))
; (list (pair int (generator a))) -> (generator a)
(define (choose-with-frequencies lis)
(>>= (choose-integer 1 (apply + (map car lis)))
(lambda (n)
(pick n lis))))
(define (pick n lis)
(let ((k (caar lis)))
(if (<= n k)
(cdar lis)
(pick (- n k) lis))))
(define-record-type :arbitrary
(make-arbitrary generator transformer)
arbitrary?
;; (generator a)
(generator arbitrary-generator)
;; a (generator b) -> (generator b)
(transformer arbitrary-transformer))
; class Arbitrary a where
; arbitrary :: Gen a
; coarbitrary :: a -> Gen b -> Gen b
(define (coarbitrary arb val gen)
((arbitrary-transformer arb) val gen))
(define arbitrary-boolean
(make-arbitrary (choose-one-of '(#t #f))
(lambda (a gen)
(variant (if a 0 1) gen))))
(define arbitrary-integer
(make-arbitrary (sized
(lambda (n)
(choose-integer (- n) n)))
(lambda (n gen)
(variant (if (>= n 0)
(* 2 n)
(+ (* 2 (- n)) 1))
gen))))
(define arbitrary-natural
(make-arbitrary (sized
(lambda (n)
(choose-integer 0 n)))
(lambda (n gen)
(variant n gen))))
(define arbitrary-ascii-char
(make-arbitrary choose-ascii-char
(lambda (ch gen)
(variant (char->integer ch) gen))))
(define arbitrary-char
(make-arbitrary (sized
(lambda (n)
(choose-char (integer->char 0)
(integer->char n))))
(lambda (ch gen)
(variant (char->integer ch) gen))))
(define (make-rational a b)
(/ a
(+ 1 b)))
(define arbitrary-rational
(make-arbitrary (lift->generator make-rational
(arbitrary-generator arbitrary-integer)
(arbitrary-generator arbitrary-natural))
(lambda (r gen)
(coarbitrary arbitrary-integer
(numerator r)
(coarbitrary arbitrary-integer
(denominator r) gen)))))
(define (fraction a b c)
(+ a
(exact->inexact (/ b
(+ (abs c) 1)))))
(define arbitrary-real
(make-arbitrary (lift->generator fraction
(arbitrary-generator arbitrary-integer)
(arbitrary-generator arbitrary-integer)
(arbitrary-generator arbitrary-integer))
(lambda (r gen)
(let ((fr (rationalize r 1/1000)))
(coarbitrary arbitrary-integer
(numerator fr)
(coarbitrary arbitrary-integer
(denominator fr) gen))))))
(define (arbitrary-mixed pred+arbitrary-list)
(make-arbitrary (choose-mixed (map (lambda (p)
(arbitrary-generator (cdr p)))
pred+arbitrary-list))
(lambda (val gen)
(let loop ((lis pred+arbitrary-list) (n 0))
(cond
((null? lis)
(assertion-violation 'arbitrary-mixed
"value matches none of the predicates"
val pred+arbitrary-list))
(((caar lis) val)
(variant n gen))
(else
(loop (cdr lis) (+ 1 n))))))))
(define (arbitrary-one-of eql? . vals)
(make-arbitrary (choose-one-of vals)
(lambda (val gen)
(let loop ((lis vals) (n 0))
(cond
((null? lis)
(assertion-violation 'arbitrary-one-of
"value is not in the list"
val vals))
((eql? (car lis) val)
(variant n gen))
(else
(loop (cdr lis) (+ 1 n))))))))
(define (arbitrary-pair arbitrary-car arbitrary-cdr)
(make-arbitrary (lift->generator cons
(arbitrary-generator arbitrary-car)
(arbitrary-generator arbitrary-cdr))
(lambda (p gen)
(coarbitrary arbitrary-car
(car p)
(coarbitrary arbitrary-cdr
(cdr p) gen)))))
; a tuple is just a non-uniform list
(define (arbitrary-tuple . arbitrary-els)
(make-arbitrary (apply lift->generator
list
(map arbitrary-generator arbitrary-els))
(lambda (lis gen)
(let recur ((arbitrary-els arbitrary-els)
(lis lis))
(if (null? arbitrary-els)
gen
((arbitrary-transformer (car arbitrary-els))
(car lis)
(recur (cdr arbitrary-els)
(cdr lis))))))))
(define (arbitrary-sequence choose-sequence sequence->list arbitrary-el)
(make-arbitrary (sized
(lambda (n)
(>>= (choose-integer 0 n)
(lambda (length)
(choose-sequence (arbitrary-generator arbitrary-el) length)))))
(lambda (seq gen)
(let recur ((lis (sequence->list seq)))
(if (null? lis)
(variant 0 gen)
((arbitrary-transformer arbitrary-el)
(car lis)
(variant 1 (recur (cdr lis)))))))))
(define (arbitrary-list arbitrary-el)
(arbitrary-sequence choose-list values arbitrary-el))
(define (arbitrary-vector arbitrary-el)
(arbitrary-sequence choose-vector vector->list arbitrary-el))
(define arbitrary-ascii-string
(arbitrary-sequence choose-string string->list arbitrary-ascii-char))
(define arbitrary-string
(arbitrary-sequence choose-string string->list arbitrary-char))
(define arbitrary-symbol
(arbitrary-sequence choose-symbol
(lambda (symbol)
(string->list (symbol->string symbol)))
arbitrary-ascii-char))
(define (arbitrary-procedure arbitrary-result . arbitrary-args)
(let ((arbitrary-arg-tuple (apply arbitrary-tuple arbitrary-args)))
(make-arbitrary (promote
(lambda args
((arbitrary-transformer arbitrary-arg-tuple)
args
(arbitrary-generator arbitrary-result))))
(lambda (proc gen)
(>>= (arbitrary-generator arbitrary-arg-tuple)
(lambda (args)
((arbitrary-transformer arbitrary-result)
(apply proc args)
gen)))))))
(define-record-type :property
(make-property proc arg-names args)
property?
(proc property-proc)
(arg-names property-arg-names)
;; (list (union arbitrary generator))
(args property-args))
(define-syntax property
(syntax-rules ()
((property ((?id ?gen) ...) ?body0 ?body1 ...)
(make-property (lambda (?id ...)
?body0 ?body1 ...)
'(?id ...)
(list ?gen ...)))))
(define-record-type :result
(make-result ok stamp arguments-list)
check-result?
;; () = unknown, #t, #f
(ok result-ok)
(stamp result-stamp)
;; (list (list (pair (union #f symbol) value)))
(arguments-list result-arguments-list))
(define (result-with-ok res ok)
(make-result ok
(result-stamp res)
(result-arguments-list res)))
(define (result-add-stamp res stamp)
(make-result (result-ok res)
(cons stamp (result-stamp res))
(result-arguments-list res)))
; result (list (pair (union #f symbol) value)) -> result
(define (result-add-arguments res args)
(make-result (result-ok res)
(result-stamp res)
(cons args (result-arguments-list res))))
(define nothing
(make-result '() '() '()))
; A testable value is one of the following:
; - a :property object
; - a boolean
; - a result record
; - a generator of a result record
(define (coerce->result-generator thing)
(cond
((property? thing)
(for-all/names (property-proc thing)
(property-arg-names thing)
(property-args thing)))
((boolean? thing) (return (result-with-ok nothing thing)))
((check-result? thing) (return thing))
((generator? thing) thing)
(else
(assertion-violation 'coerce->result-generator
"cannot be coerced to a result generator"
thing))))
(define (coerce->generator thing)
(cond
((generator? thing) thing)
((arbitrary? thing) (arbitrary-generator thing))
(else
(assertion-violation 'coerce->generator
"cannot be coerced to a generator" thing))))
(define (for-all proc . args)
(>>= (sequence (map coerce->generator args))
(lambda (args)
(>>= (coerce->result-generator (apply proc args))
(lambda (res)
(return (result-add-arguments res
(map (lambda (arg) (cons #f arg)) args))))))))
(define (for-all/names proc arg-names args)
(>>= (sequence (map coerce->generator args))
(lambda (args)
(>>= (coerce->result-generator (apply proc args))
(lambda (res)
(return (result-add-arguments res (map cons arg-names args))))))))
(define-syntax ==>
(syntax-rules ()
((==> ?bool ?prop)
(if ?bool
?prop
(return nothing)))))
(define (label str testable)
(>>= (coerce->result-generator testable)
(lambda (res)
(return (result-add-stamp res str)))))
(define-syntax classify
(syntax-rules ()
((classify ?really? ?str ?testable)
(let ((testable ?testable))
(if ?really?
(label ?str testable)
testable)))))
(define-syntax trivial
(syntax-rules ()
((trivial ?really? ?testable)
(classify ?really? "trivial" ?testable))))
(define (collect lbl testable)
(label (external-representation lbl) testable))
(define (external-representation obj)
(let ((port (make-string-output-port)))
(write obj port)
(string-output-port-output port)))
; Running the whole shebang
(define-record-type :config
(make-config max-test max-fail size print-every)
config?
(max-test config-max-test)
(max-fail config-max-fail)
(size config-size)
(print-every config-print-every))
(define quick
(make-config 100
1000
(lambda (n)
(+ 3 (quotient n 2)))
values))
(define verbose
(make-config 100
1000
(lambda (n)
(+ 3 (quotient n 2)))
(lambda (n args)
(display n)
(display ":")
(newline)
(for-each (lambda (arg)
(display arg)
(newline))
args))))
(define (check-results config prop)
(let ((rgen (make-random-generator 0)))
(tests config (coerce->result-generator prop) rgen 0 0 '())))
(define (check config prop)
(call-with-values
(lambda ()
(check-results config prop))
report-result))
(define (quickcheck-results prop)
(check-results quick prop))
(define (quickcheck prop)
(check quick prop))
; returns three values:
; - ntest
; - stamps
; - #t for success, #f for exhausted, result for failure
(define (tests config gen rgen ntest nfail stamps)
(let loop ((rgen rgen)
(ntest ntest)
(nfail nfail)
(stamps stamps))
(cond
((= ntest (config-max-test config))
(values ntest stamps #t))
((= ntest (config-max-fail config))
(values ntest stamps #f))
(else
(call-with-values
(lambda ()
(random-generator-split rgen))
(lambda (rgen1 rgen2)
(let ((result (generate ((config-size config) ntest) rgen2 gen)))
((config-print-every config) ntest (result-arguments-list result))
(case (result-ok result)
((()) (loop rgen1 ntest (+ 1 nfail) stamps))
((#t) (loop rgen1 (+ 1 ntest) nfail (cons (result-stamp result) stamps)))
((#f)
(values ntest stamps result))))))))))
(define (report-result ntest stamps maybe-result)
(case maybe-result
((#t)
(done "OK, passed" ntest stamps))
((#f)
(done "Arguments exhausted after" ntest stamps))
(else
(display "Falsifiable, after ")
(display ntest)
(display " tests:")
(newline)
(for-each write-arguments
(result-arguments-list maybe-result)))))
; (pair (union #f symbol) value)
(define (write-argument arg)
(if (car arg)
(begin
(display (car arg))
(display " = "))
(values))
(write (cdr arg)))
; (list (pair (union #f symbol) value))
(define (write-arguments args)
(if (pair? args)
(begin
(write-argument (car args))
(for-each (lambda (arg)
(display " ")
(write-argument arg))
(cdr args))
(newline))
(values)))
(define (done mesg ntest stamps)
(display mesg)
(display " ")
(display ntest)
(display " tests")
(let* ((sorted (list-sort stamp<? (filter pair? stamps)))
(grouped (group-sizes sorted))
(sorted (list-sort (lambda (p1 p2)
(< (car p1) (car p2)))
grouped))
(entries (map (lambda (p)
(let ((n (car p))
(lis (cdr p)))
(string-append (number->string (quotient (* 100 n) ntest))
"% "
(intersperse ", " lis))))
(reverse sorted))))
(cond
((null? entries)
(display ".")
(newline))
((null? (cdr entries))
(display " (")
(display (car entries))
(display ").")
(newline))
(else
(display ".") (newline)
(for-each (lambda (entry)
(display entry)
(display ".")
(newline))
entries)))))
(define (group-sizes lis)
(if (null? lis)
'()
(let loop ((current (car lis))
(size 1)
(lis (cdr lis))
(rev '()))
(cond
((null? lis)
(reverse (cons (cons size current) rev)))
((equal? current (car lis))
(loop current (+ 1 size) (cdr lis) rev))
(else
(loop (car lis) 1 (cdr lis) (cons (cons size current) rev)))))))
(define (stamp<? s1 s2)
(cond
((null? s1)
(pair? s1))
((null? s2)
#t)
((string<? (car s1) (car s2))
#t)
((string=? (car s1) (car s2))
(stamp<? (cdr s1) (cdr s2)))
(else #f)))
(define (intersperse del lis)
(if (null? lis)
""
(string-append (car lis)
(let recur ((lis (cdr lis)))
(if (null? lis)
""
(string-append del
(recur (cdr lis))))))))

44
collects/deinprogramm/quickcheck/quickcheck.ss Normal file
View File

@ -0,0 +1,44 @@
#lang scheme/base
(provide check check-results make-config
quickcheck quickcheck-results
check-result? result-arguments-list
choose-integer choose-real
choose-ascii-char choose-char
choose-list choose-vector choose-string choose-symbol
generator-unit generator-bind generator-sequence
sized choose-one-of choose-mixed choose-with-frequencies
arbitrary-boolean arbitrary-char arbitrary-ascii-char
arbitrary-integer arbitrary-natural arbitrary-rational arbitrary-real
arbitrary-mixed arbitrary-one-of
arbitrary-pair
arbitrary-list
arbitrary-vector
arbitrary-string
arbitrary-ascii-string
arbitrary-symbol
arbitrary-procedure
property
==>
label
classify
trivial
collect
)
(require srfi/9
"random.ss")
; exceptions
(define (assertion-violation who msg . irritants)
(apply error msg irritants))
; extended-ports
(define make-string-output-port open-output-string)
(define string-output-port-output get-output-string)
; sorting
(define (list-sort < lis)
(sort lis <))
(require scheme/include)
(include "quickcheck.scm")

109
collects/deinprogramm/quickcheck/random.scm Normal file
View File

@ -0,0 +1,109 @@
; This is a purely functional random generator, based on Lennart
; Augustsson's generator shipped with Hugs.
; Its comment says:
; This implementation uses the Portable Combined Generator of L'Ecuyer
; ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by
; Lennart Augustsson. It has a period of roughly 2.30584e18.
; This makes it not as good as Sebastian Egner's reference
; implementation of SRFI 27, but much faster for applications that
; need a pure random-number generator with a `split' operation.
(define-record-type :random-generator
(really-make-random-generator s1 s2)
random-generator?
(s1 random-generator-s1)
(s2 random-generator-s2))
(define-record-discloser :random-generator
(lambda (r)
(list 'random-generator
(random-generator-s1 r)
(random-generator-s2 r))))
(define min-bound (- (expt 2 31)))
(define max-bound (- (expt 2 31) 1))
(define int-range (- max-bound min-bound))
(define (make-random-generator s)
(if (negative? s)
(make-random-generator (- s))
(let ((q (quotient s 2147483562))
(s1 (remainder s 2147483562)))
(let ((s2 (remainder q 2147483398)))
(really-make-random-generator (+ 1 s1) (+ 1 s2))))))
(define (random-generator-next rg)
(let ((s1 (random-generator-s1 rg))
(s2 (random-generator-s2 rg)))
(let ((k (quotient s1 53668))
(k* (quotient s2 52774)))
(let ((s1* (- (* 40014 (- s1 (* k 53668)))
(* k 12211)))
(s2* (- (* 40692 (- s2 (* k* 52774)))
(* k* 3791))))
(let ((s1** (if (negative? s1*)
(+ s1* 2147483563)
s1*))
(s2** (if (negative? s2*)
(+ s2* 2147483399)
s2*)))
(let* ((z (- s1** s2**))
(z* (if (< z 1)
(+ z 2147483562)
z)))
(values z* (really-make-random-generator s1** s2**))))))))
(define (random-generator-split rg)
(let ((s1 (random-generator-s1 rg))
(s2 (random-generator-s2 rg)))
(let ((new-s1 (if (= s1 2147483562)
1
(+ s1 1)))
(new-s2 (if (= s2 1)
2147483398
(- s2 1))))
(call-with-values
(lambda ()
(random-generator-next rg))
(lambda (_ nrg)
(values (really-make-random-generator new-s1
(random-generator-s2 nrg))
(really-make-random-generator (random-generator-s1 nrg)
new-s2)))))))
; The intervals are inclusive.
(define (random-integer rg low high)
(let ((b 2147483561)
(k (+ (- high low) 1)))
(let loop ((n (ilogbase b k))
(acc low)
(rg rg))
(if (zero? n)
(values (+ low (modulo acc k))
rg)
(call-with-values
(lambda () (random-generator-next rg))
(lambda (x rgn)
(loop (- n 1) (+ x (* acc b)) rgn)))))))
(define (random-real rg low high)
(call-with-values
(lambda ()
(random-integer rg min-bound max-bound))
(lambda (x nrg)
(let ((scaled-x (+ (/ (+ low high) 2)
(* (/ (- high low) int-range)
x))))
(values scaled-x nrg)))))
(define (ilogbase b i)
(if (< i b)
1
(+ 1 (ilogbase b (quotient i b)))))

17
collects/deinprogramm/quickcheck/random.ss Normal file
View File

@ -0,0 +1,17 @@
#lang scheme/base
(provide make-random-generator
random-generator-next
random-generator-split
random-integer
random-real)
(require srfi/9)
(define-syntax define-record-discloser
(syntax-rules ()
((define-record-discloser ?:type ?discloser)
(values))))
(require scheme/include)
(include "random.scm")

73
collects/deinprogramm/scribblings/DMdA-beginner.scrbl
View File

@ -333,6 +333,21 @@ Dieser Testfall überprüft, ob der erste @scheme[expr] einen Fehler produziert,
wobei die Fehlermeldung der Zeichenkette entspricht, die der Wert des zweiten
@scheme[expr] ist.}
@defform[(check-property expr)]{
Dieser Testfall überprüft experimentell, ob die Eigenschaft
@scheme[expr] erfüllt ist. Dazu werden zufällige Werte für die mit
@scheme[for-all] quantifizierten Variablen eingesetzt: Damit wird
überprüft, ob die Bedingung gilt.
@emph{Wichtig:} @scheme[check-property] funktioniert nur für
Eigenschaften, bei denen aus den Verträgen sinnvoll Werte generiert
werden können. Dies ist für die meisten eingebauten Verträge der
Fall, aber nicht für Verträge, die mit @scheme[predicate],
@scheme[property] oder @scheme[define-record-procedures]definiert
wurden. In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung.
}
@section{Parametrische Record-Typ-Definitionen}
@defform[(define-record-procedures-parametric (t p1 ...) c p (s1 ...))]{
@ -395,6 +410,64 @@ Dann ist @scheme[(pare integer string)] der Vertrag für
@; ----------------------------------------
@section{Eigenschaften}
Eine @deftech{Eigenschaft} definiert eine Aussage über einen
Scheme-Ausdruck, die experimentell überprüft werden kann. Der
einfachste Fall einer Eigenschaft ist ein boolescher Ausdruck. Die
folgende Eigenschaft gilt immer:
@schemeblock[
(= 1 1)
]
Es ist auch möglich, in einer Eigenschaft Variablen zu verwenden, für
die verschiedene Werte eingesetzt werden. Dafür müssen die Variablen
gebunden und @deftech{quantifiziert} werden, d.h. es muß festgelegt
werden, welchen Vertrag die Werte der Variable erfüllen sollen.
Eigenschaften mit Variablen werden mit der @scheme[for-all]-Form erzeugt:
@defform[(for-all ((id contract) ...) expr)]{
Dies bindet die Variablen @scheme[id] in der Eigenschaft
@scheme[expr]. Zu jeder Variable gehört ein Vertrag
@scheme[contract], der von den Werten der Variable erfüllt werden
muß.
Beispiel:
@schemeblock[
(for-all ((x integer))
(= x (/ (* x 2) 2)))
]
}
@defform[(expect expr expr)]{
Ein @scheme[expect]-Ausdruck ergibt eine Eigenschaft, die dann gilt,
wenn die Werte von @scheme[expr] und @scheme[expr] gleich sind, im
gleichen Sinne wie bei @scheme[check-expect].}
@defform[(expect-within expr expr expr)]{
Wie @scheme[expect], aber entsprechend @scheme[check-within] mit einem
weiteren Ausdruck, der als Wert eine Zahl @scheme[_delta] hat. Die
resultierende Eigenschaft gilt, wenn jede Zahl im Resultat des ersten
@scheme[expr] maximal um @scheme[_delta] von der entsprechenden Zahl
im zweiten @scheme[expr] abweicht.}
@defform[(==> expr expr)]{
Der erste Operand ist ein boolescher Ausdruck, der zweite Operand eine
Eigenschaft: @scheme[(==> c p)] legt fest, daß die Eigenschaft
@scheme[p] nur erfüllt sein muß, wenn @scheme[c] (die
@emph{Bedingung}) @scheme[#t] ergibt, also erfüllt ist.}
@schemeblock[
(for-all ((x integer))
(==> (even? x)
(= x (* 2 (/ x 2)))))
]
@section[#:tag "beginner-prim-ops"]{Primitive Operationen}
@prim-op-defns['(lib "DMdA-beginner.ss" "deinprogramm") #'here '()]

5
collects/deinprogramm/scribblings/std-grammar.ss
View File

@ -49,6 +49,8 @@
@#,scheme[(letrec ((id expr) (... ...)) expr)]
@#,scheme[(let* ((id expr) (... ...)) expr) ]
@#,scheme[(begin expr expr (... ...))]
@#,scheme[(for-all ((id contract) (... ...)) expr)]
@#,scheme[(==> expr expr)]
expr-rule ...]
[contract id
@#,scheme[(predicate expr)]
@ -62,7 +64,8 @@
]
[test-case @#,scheme[(check-expect expr expr)]
@#,scheme[(check-within expr expr expr)]
@#,scheme[(check-error expr expr)]]
@#,scheme[(check-error expr expr)]
@#,scheme[(check-property expr)]]
#;(...
[library-require @#,scheme[(require string)]
@#,scheme[(require (lib string string ...))]

5
collects/framework/private/main.ss
View File

@ -257,7 +257,10 @@
parameterize
call-with-input-file call-with-input-file* with-input-from-file
with-input-from-port call-with-output-file
with-output-to-file with-output-to-port))
with-output-to-file with-output-to-port
for-all
))
(preferences:set-default
'framework:tabify
(list hash-table #rx"^begin" #rx"^def" #f)

4
collects/test-engine/scheme-tests.ss
View File

@ -16,6 +16,10 @@
check-error ;; syntax : (check-error <expression> <expression>)
)
; for other modules implementing check-expect-like forms
(provide
(for-syntax check-expect-maker))
(define INEXACT-NUMBERS-FMT
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
(define FUNCTION-FMT

10
collects/test-engine/test-info.scm
View File

@ -58,17 +58,21 @@
(set! total-tsts (add1 total-tsts))
(inner (void) add-test))
(define/pubment (add-check-failure fail exn?)
(set! failed-cks (add1 failed-cks))
(set! failures (cons (make-failed-check fail exn?) failures))
(inner (void) add-check-failure fail exn?))
;; check-failed: (U check-fail (list (U string snip%))) src (U exn false) -> void
(define/pubment (check-failed msg src exn?)
(set! failed-cks (add1 failed-cks))
(let ((fail
(let ((fail
;; We'd like every caller to make a check-fail object,
;; but some (such as ProfessorJ's run time) cannot because
;; of phase problems. Therefore, do the coercion here.
(if (check-fail? msg)
msg
(make-message-error src #f msg))))
(set! failures (cons (make-failed-check fail exn?) failures))
(add-check-failure fail exn?)
(inner (void) check-failed fail src exn?)))
(define/pubment (test-failed failed-info)