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

Makes the Redex tests less dependent on the wording of blame messages

Browse Source
This commit is contained in:
Casey Klein 2010-12-10 13:56:10 -06:00
parent 7243029786
commit 335e679ec7
4 changed files with 82 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/redex/tests/keyword-macros-test.rkt
View File

@ -47,16 +47,19 @@
(let* ([default #'3]
[formals `((#:a ,default (,#'(-> number? string?) "#:a arg")))]
[parse (λ (actuals) (parse-kw-args formals actuals actuals 'test-form))])
[form 'test-form]
[parse (λ (actuals) (parse-kw-args formals actuals actuals form))])
(test (first (parse #'())) default)
(define arg
(eval (first (parse #'(#:a (λ (x) 3))))
(namespace-anchor->namespace test-module)))
(test (with-handlers ([exn:fail:contract:blame? exn-message])
(arg 3))
#rx"keyword-macros-test.*broke the contract.*on #:a arg")
(test (with-handlers ([exn:fail:contract:blame? exn-message])
(arg "NaN"))
#rx"test-form.*broke the contract.*on #:a arg"))
(test-contract-violation
(arg 3)
#:blaming "keyword-macros-test"
#:message "#:a arg")
(test-contract-violation
(arg "NaN")
#:blaming (format "~a" form)
#:message "#:a arg"))
(print-tests-passed 'keyword-macros-test.ss)

66
collects/redex/tests/rg-test.rkt
View File

@ -29,18 +29,19 @@
(get-output-string p)
(close-output-port p))))
(define-syntax (test-contract-violation stx)
(define-syntax (test-contract-violation/client stx)
(syntax-case stx ()
[(form expr)
[(form expr)
(syntax/loc stx (form "" expr))]
[(_ name expr)
(with-syntax ([expected
(syntax/loc stx
(regexp (format "rg-test.*broke the contract .* ~a" name)))])
#'(test (raised-exn-msg
exn:fail?
(begin (output (λ () expr)) 'no-violation))
expected))]))
(syntax/loc stx
(test-contract-violation
(output (λ () expr))
#:blaming "rg-test"
#:message ""
#:extract (match-lambda
[(exn:fail:redex:test _ _ (? exn:fail:contract:blame? e) _) e]
[x x])))]))
(define find-base-cases/unparsed
(compose find-base-cases parse-language))
@ -226,7 +227,7 @@
(parameterize ([current-namespace ns])
(expand #'(generate-term M n))))
#rx"generate-term: expected a identifier defined by define-language( in: M)?$")
(test-contract-violation (generate-term L n 1.5)))
(test-contract-violation/client (generate-term L n 1.5)))
;; variable-except pattern
(let ()
@ -770,16 +771,16 @@
#:print? #f)
(counterexample 1))
(test-contract-violation
(test-contract-violation/client
"#:attempts argument"
(redex-check lang natural #t #:attempts 3.5))
(test-contract-violation
(test-contract-violation/client
"#:retries argument"
(redex-check lang natural #t #:retries 3.5))
(test-contract-violation
(test-contract-violation/client
"#:attempt-size argument"
(redex-check lang natural #t #:attempt-size -))
(test-contract-violation
(test-contract-violation/client
"#:prepare argument"
(redex-check lang natural #t #:prepare (λ (_) (values))))
@ -926,13 +927,12 @@
#:prepare (λ (_) (error 'fixer))
#:print? #f))
#rx"fixing 0")
(test (raised-exn-msg
exn:fail:contract:blame?
(check-reduction-relation
(reduction-relation L (--> 0 0))
void
#:prepare (λ () 0)))
#rx"rg-test broke the contract")
(test-contract-violation/client
"#:prepare argument"
(check-reduction-relation
(reduction-relation L (--> 0 0))
void
#:prepare (λ () 0)))
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1)))
@ -983,19 +983,19 @@
#rx"^check-reduction-relation: unable"))
(let ([R (reduction-relation L (--> any any))])
(test-contract-violation
(test-contract-violation/client
"#:attempts argument"
(check-reduction-relation R values #:attempts -1))
(test-contract-violation
(test-contract-violation/client
"#:retries argument"
(check-reduction-relation R values #:retries -1))
(test-contract-violation
(test-contract-violation/client
"#:attempt-size argument"
(check-reduction-relation R values #:attempt-size (λ (_) (values 1 2))))
(test-contract-violation
(test-contract-violation/client
"#:prepare argument"
(check-reduction-relation R values #:prepare (λ (_) (values 1 2))))
(test-contract-violation (check-reduction-relation R #t))))
(test-contract-violation/client (check-reduction-relation R #t))))
; check-metafunction
(let ()
@ -1109,19 +1109,19 @@
(let ()
(define-metafunction empty
[(f 0) 0])
(test-contract-violation
(test-contract-violation/client
"#:attempts argument"
(check-metafunction f void #:attempts 3.5))
(test-contract-violation
(test-contract-violation/client
"#:retries argument"
(check-metafunction f void #:retries 3.5))
(test-contract-violation
(test-contract-violation/client
"#:attempt-size argument"
(check-metafunction f void #:attempt-size 3.5))
(test-contract-violation
(test-contract-violation/client
"#:prepare argument"
(check-metafunction f void #:prepare car #:print? #f))
(test-contract-violation (check-metafunction f (λ () #t))))
(test-contract-violation/client (check-metafunction f (λ () #t))))
; Extension reinterprets the LHSs of the base metafunction
; relative to the new language.
@ -1254,7 +1254,7 @@
(hash-map
(class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1) lang 'top-level))
(λ (_ cls) cls))
'(..._1 ..._1))
'(..._1 ..._1))
(test-class-reassignments
'((3 ..._1) ..._2 (4 ..._1) ..._3)
'((..._2 . ..._3)))
@ -1280,4 +1280,4 @@
(test (seed-effect-generate void)
(seed-effect-generate random))))
(print-tests-passed 'rg-test.ss)
(print-tests-passed 'rg-test.ss)

22
collects/redex/tests/test-util.rkt
View File

@ -1,12 +1,14 @@
#lang scheme
(require "../private/matcher.ss"
(for-syntax syntax/parse)
errortrace/errortrace-lib
errortrace/errortrace-key)
(provide test test-syn-err tests reset-count
syn-err-test-namespace
print-tests-passed
equal/bindings?
test-contract-violation
runtime-error-source)
(define syn-err-test-namespace (make-base-namespace))
@ -137,3 +139,23 @@
;; rib-lt : rib rib -> boolean
(define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1))
(format "~s" (bind-name r2))))
(define-syntax (test-contract-violation stx)
(syntax-parse stx
[(_ expr
(~or (~once (~seq #:blaming blaming:expr))
(~optional (~seq #:message message:expr)
#:defaults ([message #'""]))
(~optional (~seq #:extract extract:expr)
#:defaults ([extract #'values])))
...)
#`(test (with-handlers ([(λ (exn)
(let ([exn (extract exn)])
(and (exn:fail:contract:blame? exn)
(regexp-match?
blaming
(format "~a" (blame-positive (exn:fail:contract:blame-object exn)))))))
exn-message])
expr
(gensym 'no-violation))
#,(syntax/loc stx (regexp message)))]))

31
collects/redex/tests/tl-test.rkt
View File

@ -2233,11 +2233,11 @@
(λ (stx)
(syntax-case stx ()
[(_ test-form)
#'(test (with-handlers ([exn:fail:contract? exn-message])
(test-form (reduction-relation empty-language (--> any any))
#:equiv 1 2)
"no error raised")
#rx"tl-test\\.(?:.+).*broke the contract")]))])
(syntax/loc stx
(test-contract-violation
(test-form (reduction-relation empty-language (--> any any))
#:equiv 1 2)
#:blaming "tl-test"))]))])
(test-bad-equiv-arg test-->)
(test-bad-equiv-arg test-->>))
@ -2269,15 +2269,18 @@
(test (capture-output (test-results)) "2 tests failed (out of 6 total).\n")
(test (with-handlers ([exn:fail:contract? exn-message])
(test-->>∃ 1+ 0 (λ (x y) x)))
#rx"tl-test\\.(?:.+).*broke the contract.*goal expression")
(test (with-handlers ([exn:fail:contract? exn-message])
(test-->>∃ 1 0 1))
#rx"tl-test\\.(?:.+).*broke the contract.*reduction relation expression")
(test (with-handlers ([exn:fail:contract? exn-message])
(test-->>∃ #:steps 1.1 1+ 0 1))
#rx"tl-test\\.(?:.+).*broke the contract.*steps expression"))
(test-contract-violation
(test-->>∃ 1+ 0 (λ (x y) x))
#:blaming "tl-test"
#:message "goal expression")
(test-contract-violation
(test-->>∃ 1 0 1)
#:blaming "tl-test"
#:message "reduction relation expression")
(test-contract-violation
(test-->>∃ #:steps 1.1 1+ 0 1)
#:blaming "tl-test"
#:message "steps expression"))
(print-tests-passed 'tl-test.ss)