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

add option for testing errors and non-exception raised values with a predicate

Browse Source 
svn: r14141
This commit is contained in:
Eli Barzilay 2009-03-17 10:04:20 +00:00
parent 19eb34367f
commit 167bae8bdd
1 changed files with 54 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/tests/eli-tester.ss
View File

@ -7,17 +7,25 @@
(syntax-case stx ()
[(_ expr)
;; catch syntax errors while expanding, turn them into runtime errors
(with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e)))])
(with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e) #,e))])
(define-values (_ opaque)
(syntax-local-expand-expression
#'(with-handlers ([exn? (lambda (e) (list 'error (exn-message e)))])
#'(with-handlers
([(lambda (_) #t)
(lambda (e) (list 'error (and (exn? e) (exn-message e)) e))])
(cons 'values (call-with-values (lambda () expr) list)))))
opaque)]))
(define show
(match-lambda [(list 'error msg) (format "error: ~a" msg)]
[(list 'values x) (format "~e" x)]
[(list 'values xs ...) (format "~e" (cons 'values xs))]))
(match-lambda
[(list 'values x) (format "~e" x)]
[(list 'values xs ...) (format "~e" (cons 'values xs))]
[(list 'error err val)
(cond [(procedure? err) (format "error satisfying ~s" err)]
[(regexp? err) (format "error matching ~s" err)]
[err (format "error: ~a" err)]
[else (format "a raised non-exception ~s" val)])]
[x (format "INTERNAL ERROR, unexpected value: ~s" x)]))
(define test-context (make-parameter #f))
(define failure-message (make-parameter #f))
@ -41,17 +49,36 @@
#`(let ([x (safe #,x)])
(unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x))
#,(blame x "expected non-#f single value; got: ~a" #'(show x)))))
(define (t2 x y)
#`(let ([x (safe #,x)] [y (safe #,y)])
(cond [(and (eq? 'values (car x)) (eq? 'error (car y)))
#,(blame x "expected an error; got ~a" #'(show x))]
[(and (eq? 'error (car x)) (eq? 'error (car y)))
(unless (regexp-match? (regexp-quote (cadr y)) (cadr x))
#,(blame x "bad error message, expected ~s; got ~s"
#'(cadr y) #'(cadr x)))]
[(not (equal? x y))
#,(blame x "expected ~a; got: ~a" #'(show y) #'(show x))])))
(define (te x y) (t2 x #`(error #,y)))
(define (t2 x y [eval2? #t])
#`(let* ([x (safe #,x)] [xtag (car x)]
[y #,(if eval2? #`(safe #,y) y)] [ytag (car y)])
(cond
[(eq? ytag 'values)
(unless (equal? x y)
#,(blame x "expected ~a; got: ~a" #'(show y) #'(show x)))]
[(eq? xtag 'values)
#,(blame x "expected an error; got ~a" #'(show x))]
;; both are errors (or other raised values)
[(not (cadr x)) ; expecting a non-exception raise
(unless (or (equal? x y)
(and (procedure? (cadr y)) ((cadr y) (caddr x))))
#,(blame x "expected ~a; got ~a" #'(show y) #'(show x)))]
[else
(let ([xerr (cadr x)] [xval (caddr x)] [yerr (cadr y)])
(cond [(string? yerr)
(unless (regexp-match? (regexp-quote yerr) xerr)
#,(blame x "bad error message, expected ~s; got ~s"
#'yerr #'xerr))]
[(regexp? yerr)
(unless (regexp-match? yerr xerr)
#,(blame x "bad error message, expected ~a ~s; got ~s"
"a match for" #'yerr #'xerr))]
[(and (procedure? yerr) (procedure-arity-includes? yerr 1))
(unless (yerr xval)
#,(blame x "bad error message, expected ~a ~s; got ~s"
"an exception satisfying" #'yerr #'xerr))]
[else (error 'test "bad error specification: ~e" yerr)]))])))
(define (te x y) (t2 x #`(list 'error #,y #f) #f))
(define (try t . args)
#`(let ([c (test-context)])
(with-handlers ([exn? (lambda (e) (set-mcdr! c (cons e (mcdr c))))])
@ -133,11 +160,22 @@
;; syntax errors
(if 1) =error> "if: bad syntax"
;; error (and non-exception raises) predicates
(+ 1 "2") =error> exn:fail:contract?
(+ 1 "2") =error> (lambda (x) (not (exn:fail:filesystem? x)))
(+ 1 "2") =error> #rx"expects.*<number>"
(error "1") =error> exn?
(raise 1) =error> number?
(raise "1") =error> string?
;; test `test' errors
(test* (/ 0)) =error> "expected non-#f single value"
(test* 1 => 2) =error> "expected 2"
(test* 1 =error> "") =error> "expected an error"
(test* (/ 0) =error> "zzz") =error> "bad error message"
(test* (raise 1) =error> "foo") =error> "raised non-exception"
(test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO"
(test* #:failure-message "FOO" (/ 0)) =error> "FOO"
)
;; SchemeUnit stuff