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

more new contract test suite cleanups

Browse Source
This commit is contained in:
Robby Findler 2013-07-11 06:22:08 -05:00
parent c910252fdf
commit 402ddcbf1e
1 changed files with 28 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
pkgs/racket-pkgs/racket-test/tests/racket/contract/test-util.rkt
View File

@ -50,7 +50,6 @@
'no-exn-raised)) 'no-exn-raised))
(unless (predicate? exn) (unless (predicate? exn)
(set! failures (+ failures 1)) (set! failures (+ failures 1))
(printf "~s\n" (list name thunk sexp predicate?))
(eprintf "FAILED ~s\n" name))) (eprintf "FAILED ~s\n" name)))
(define current-contract-namespace (make-parameter 'current-contract-namespace-not-initialized)) (define current-contract-namespace (make-parameter 'current-contract-namespace-not-initialized))
@ -251,40 +250,34 @@
;; blame : (or/c 'pos 'neg string?) ;; blame : (or/c 'pos 'neg string?)
;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message ;; if blame is a string, expect to find the string (format "blaming: ~a" blame) in the exn message
(define (test/spec-failed name expression blame) (define (test/spec-failed name expression blame)
(let () (define (has-proper-blame? msg)
(define (has-proper-blame? msg) (define reg
(define reg (cond
(cond [(eq? blame 'pos) #rx"blaming: pos"]
[(eq? blame 'pos) #rx"blaming: pos"] [(eq? blame 'neg) #rx"blaming: neg"]
[(eq? blame 'neg) #rx"blaming: neg"] [(string? blame) (string-append "blaming: " (regexp-quote blame))]
[(string? blame) (string-append "blaming: " (regexp-quote blame))] [else #f]))
[else #f])) (and reg (regexp-match? reg msg)))
(contract-eval
(when reg #:test-case-name name
(unless (regexp-match? reg msg) `(,test-an-error
(eprintf "ACK!! ~s ~s\n" blame msg) ',name
(custodian-shutdown-all (current-custodian)))) (lambda () ,expression)
(and reg (regexp-match? reg msg))) ',expression
(contract-eval (lambda (exn)
#:test-case-name name (and (exn:fail:contract:blame? exn)
`(,test-an-error (,has-proper-blame? (exn-message exn))))))
',name (let/ec k
(lambda () ,expression) (let ([rewritten (rewrite-to-add-opt/c expression k)])
',expression (contract-eval
(lambda (exn) #:test-case-name (format "~a rewrite-to-add-opt/c" name)
(and (exn:fail:contract:blame? exn) `(,test-an-error
(,has-proper-blame? (exn-message exn)))))) ',(string->symbol (format "~a+opt/c" name))
(let/ec k (lambda () ,rewritten)
(let ([rewritten (rewrite-to-add-opt/c expression k)]) ',rewritten
(contract-eval (lambda (exn)
#:test-case-name (format "~a rewrite-to-add-opt/c" name) (and (exn:fail:contract:blame? exn)
`(,test-an-error (,has-proper-blame? (exn-message exn)))))))))
',name
(lambda () ,rewritten)
',rewritten
(lambda (exn)
(and (exn:fail:contract:blame? exn)
(,has-proper-blame? (exn-message exn))))))))))
(define (test/pos-blame name expression) (test/spec-failed name expression 'pos)) (define (test/pos-blame name expression) (test/spec-failed name expression 'pos))
(define (test/neg-blame name expression) (test/spec-failed name expression 'neg)) (define (test/neg-blame name expression) (test/spec-failed name expression 'neg))