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

Changed rackunit top-level test output to stderr

Browse Source 
Made test-begin accept zero expressions
 Closes PR 11331
This commit is contained in:
Ryan Culpepper 2010-10-25 14:40:52 -06:00
parent 454673ddcc
commit f17d0001c4
2 changed files with 65 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/rackunit/private/check.rkt
View File

@ -2,7 +2,6 @@
(require (for-syntax racket/base
"location.rkt")
srfi/1
"base.rkt"
"check-info.rkt"
"format.rkt"
@ -34,39 +33,50 @@
check-not-equal?
fail)
(define USE-ERROR-HANDLER? #f)
;; default-check-handler : exn -> any
(define (default-check-handler e)
(let ([out (open-output-string)])
;;(display "check failed\n" out)
(parameterize ((current-output-port out))
(display-delimiter)
(cond [(exn:test:check? e)
(display-failure)
(newline)
(display-check-info-stack
(exn:test:check-stack e))]
[(exn? e)
(display-error)
(newline)
(display-exn e)])
(display-delimiter))
(cond [USE-ERROR-HANDLER?
((error-display-handler) (get-output-string out)
;; So that DrRacket won't recognize exn:fail:syntax, etc
(make-exn (exn-message exn) (exn-continuation-marks exn)))]
[else
(display (get-output-string out) (current-error-port))])))
;; parameter current-check-handler : (-> exn any)
(define current-check-handler
(make-parameter
(lambda (e)
(cond
[(exn:test:check? e)
(display-delimiter)
(display-failure)(newline)
(display-check-info-stack
(exn:test:check-stack e))
(display-delimiter)]
[(exn? e)
(display-delimiter)
(display-error)(newline)
(display-exn e)
(display-delimiter)]))
default-check-handler
(lambda (v)
(if (procedure? v)
v
(raise-type-error 'current-check-handler "procedure" v)))))
;; check-around : ( -> a) -> a
(define check-around
(lambda (thunk)
(with-handlers
([exn? (current-check-handler)])
(thunk))))
(define (check-around thunk)
(with-handlers ([exn? (current-check-handler)])
(thunk)))
;; top-level-check-around : ( -> a) -> a
(define top-level-check-around
(lambda (thunk)
(check-around thunk)
(void)))
(define (top-level-check-around thunk)
(check-around thunk)
(void))
;; parameter current-check-around : (( -> a) -> a)
(define current-check-around

61
collects/rackunit/private/test-case.rkt
View File

@ -16,47 +16,52 @@
after
around)
(define USE-ERROR-HANDLER? #f)
(define current-test-name
(make-parameter
#f
(lambda (v)
(if (string? v)
v
(raise-mismatch-error
'current-test-name
"string?"
v)))))
(raise-type-error 'current-test-name "string" v)))))
;; test-case-around : ( -> a) -> a
;;
;; Run a test-case immediately, printing information on failure
(define test-case-around
(lambda (thunk)
(with-handlers
([exn:test:check?
(lambda (e)
(display-delimiter)
(display-test-name (current-test-name))
(display-failure)(newline)
(display-check-info-stack (exn:test:check-stack e))
(display-delimiter))]
[exn?
(lambda (e)
(display-delimiter)
(display-test-name (current-test-name))
(display-error)(newline)
(display-exn e)
(display-delimiter))])
(thunk))))
(define (default-test-case-around thunk)
(with-handlers ([exn? default-test-case-handler])
(thunk)))
;; default-test-case-handler : exn -> any
(define (default-test-case-handler e)
(let ([out (open-output-string)])
;;(display "test case failed\n" out)
(parameterize ((current-output-port out))
(display-delimiter)
(display-test-name (current-test-name))
(cond [(exn:test:check? e)
(display-failure)(newline)
(display-check-info-stack (exn:test:check-stack e))]
[(exn? e)
(display-error)(newline)
(display-exn e)])
(display-delimiter))
(cond [USE-ERROR-HANDLER?
((error-display-handler) (get-output-string out)
;; So that DrRacket won't recognize exn:fail:syntax, etc
(make-exn (exn-message e) (exn-continuation-marks e)))]
[else
(display (get-output-string out) (current-error-port))])))
(define current-test-case-around
(make-parameter
test-case-around
default-test-case-around
(lambda (v)
(if (procedure? v)
v
(raise-type-error 'current-test-case-around "procedure" v)))))
(raise-type-error 'current-test-case-around "procedure" v)))))
(define-syntax (test-begin stx)
(syntax-case stx ()
[(_ expr ...)
@ -66,6 +71,7 @@
(parameterize
([current-check-handler raise]
[current-check-around check-around])
(void)
expr ...))))]
[_
(raise-syntax-error
@ -73,7 +79,6 @@
"Correct form is (test-begin expr ...)"
stx)]))
(define-syntax test-case
(syntax-rules ()
[(test-case name expr ...)
@ -81,7 +86,6 @@
([current-test-name name])
(test-begin expr ...))]))
(define-syntax before
(syntax-rules ()
((_ before-e expr1 expr2 ...)
@ -132,4 +136,3 @@
"Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)"
'around
'(error ...)))))