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

add support to the test suite to check "contract violation" vs "broke its own contract"

Browse Source
This commit is contained in:
Robby Findler 2019-05-17 14:52:05 -05:00
parent ddb944d583
commit 388076a3cf
2 changed files with 25 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -694,4 +694,12 @@
#'(eval '(->* [#:a any/c] [#:a any/c] void?))
(λ (x) (and (exn:fail:syntax? x) (regexp-match #rx"->[*]: duplicate keyword" (exn-message x)))))
(test/neg-blame
'header.1
#:header-of-message "contract violation"
'((contract (-> integer? integer?) (λ (x) #f) 'pos 'neg) #f))
(test/pos-blame
'header.2
#:header-of-message "broke its own contract"
'((contract (-> integer? integer?) (λ (x) #f) 'pos 'neg) 11))
)

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

@ -351,7 +351,8 @@
;; blame : (or/c 'pos 'neg string?)
;; 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)
;; if header-of-message is a string, look for it at the start of the message
(define (test/spec-failed name expression blame #:header-of-message [header-of-message #f])
(define (has-proper-blame? msg)
(define reg
(cond
@ -360,6 +361,11 @@
[(string? blame) (string-append "blaming: " (regexp-quote blame))]
[else #f]))
(and reg (regexp-match? reg msg)))
(define (has-right-header? msg)
(cond
[header-of-message
(regexp-match? (format "^[^\n]*~a\n" (regexp-quote header-of-message)) msg)]
[else #t]))
(contract-eval
#:test-case-name name
`(,test-an-error
@ -368,7 +374,8 @@
',expression
(lambda (exn)
(and (exn:fail:contract:blame? exn)
(,has-proper-blame? (exn-message exn))))))
(,has-proper-blame? (exn-message exn))
(,has-right-header? (exn-message exn))))))
(define (rewrite-test wrapper wrapper-name short-wrapper-name)
(unless (member short-wrapper-name (contract-rewrite-tests-to-skip))
(let/ec k
@ -381,12 +388,17 @@
',rewritten
(lambda (exn)
(and (exn:fail:contract:blame? exn)
(,has-proper-blame? (exn-message exn))))))))))
(,has-proper-blame? (exn-message exn))
(,has-right-header? (exn-message exn))))))))))
(rewrite-test rewrite-to-add-opt/c "rewrite-to-add-opt/c" "opt/c")
(rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap" "double"))
(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/pos-blame name expression #:header-of-message [header-of-message #f])
(test/spec-failed name expression 'pos
#:header-of-message header-of-message))
(define (test/neg-blame name expression #:header-of-message [header-of-message #f])
(test/spec-failed name expression 'neg
#:header-of-message header-of-message))
(define-syntax (ctest/rewrite stx)
(syntax-case stx ()