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

Made unit contract test regular expressions more robust.

Browse Source 
svn: r17782
This commit is contained in:
Carl Eastlund 2010-01-23 18:31:32 +00:00
parent d00e3432d9
commit bd9b6e9e97
1 changed files with 23 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/tests/units/test-unit-contracts.ss
View File

@ -2,24 +2,14 @@
scheme/unit scheme/unit
scheme/contract) scheme/contract)
(define temp-unit-blame #rx"(unit temp[0-9]*)") (define temp-unit-blame-re "\\(unit temp[0-9]*\\)")
(define top-level "top-level") (define top-level "top-level")
(define (get-blame msg) (define (match-blame re msg)
(cond (regexp-match? (string-append "(^| )" re " broke") msg))
[(regexp-match #rx"(^| )(.*) broke" msg)
=>
(λ (x) (caddr x))]
[else (error 'test-contract-error
(format "no blame in error message: \"~a\"" msg))]))
(define (get-obj msg) (define (match-obj re msg)
(cond (regexp-match? (string-append "(^| )on " re ";") msg))
[(regexp-match #rx"(^| )on (.*);" msg)
=>
(λ (x) (caddr x))]
[else (error 'test-contract-error
(format "no object in error message: \"~a\"" msg))]))
(define (get-ctc-err msg) (define (get-ctc-err msg)
(cond (cond
@ -29,28 +19,29 @@
[else (error 'test-contract-error [else (error 'test-contract-error
(format "no specific error in message: \"~a\"" msg))])) (format "no specific error in message: \"~a\"" msg))]))
(define-syntax test-contract-error (define-syntax-rule (test-contract-error blame obj err expr)
(test-contract-error/regexp
(regexp-quote blame) (regexp-quote obj) (regexp-quote err)
expr))
(define-syntax test-contract-error/regexp
(syntax-rules () (syntax-rules ()
((_ blame obj err expr) ((_ blame obj err expr)
(with-handlers ((exn:fail:contract? (with-handlers ((exn:fail:contract?
(lambda (exn) (lambda (exn)
(let ([exn-blame (get-blame (exn-message exn))] (let ([msg (exn-message exn)])
[exn-obj (get-obj (exn-message exn))])
(cond (cond
[(and (string? blame) [(not (match-blame blame msg))
(not (equal? blame exn-blame))) (error 'test-contract-error
(error 'test-contract-error "expected blame ~a, got ~a" "blame \"~a\" not found in:~n\"~a\""
blame exn-blame)] blame msg)]
[(and (regexp? blame) [(not (match-obj obj msg))
(not (regexp-match blame exn-blame))) (error 'test-contract-error
(error 'test-contract-error "expected blame ~a, got ~a" "object \"~a\" not found in:~n\"~a\""
blame exn-blame)] obj msg)]
[(not (equal? obj exn-obj))
(error 'test-contract-error "expected object ~a, got ~a"
obj exn-obj)]
[else [else
(printf "contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n" (printf "contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n"
err obj exn-blame (get-ctc-err (exn-message exn)))]))))) err obj blame (get-ctc-err msg))])))))
expr expr
(error 'test-contract-error (error 'test-contract-error
"expected contract error \"~a\" on ~a, got none" "expected contract error \"~a\" on ~a, got none"
@ -123,7 +114,7 @@
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S1 : sig1)) unit1) (link (((S1 : sig1)) unit1)
(() unit2 S1))))) (() unit2 S1)))))
(test-contract-error temp-unit-blame "a" "not a number" (test-contract-error/regexp temp-unit-blame-re "a" "not a number"
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4)) (link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4) (unit (import) (export sig3 sig4)
@ -133,7 +124,7 @@
(define (b t) (if t 3 0)))) (define (b t) (if t 3 0))))
(() unit3 S3 S4))))) (() unit3 S3 S4)))))
(test-contract-error temp-unit-blame "g" "not a boolean" (test-contract-error/regexp temp-unit-blame-re "g" "not a boolean"
(invoke-unit (compound-unit (import) (export) (invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4)) (link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4) (unit (import) (export sig3 sig4)