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

rackunit: drop redundant 'params info, use error-display-handler

Browse Source 
Closes PR 11618

original commit: f6b73f01e174337534ed11e7ff78d095f16d6088
This commit is contained in:
Ryan Culpepper 2011-05-10 16:39:24 -06:00
parent 864ae93889
commit 63d6faaecf
4 changed files with 53 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -33,31 +33,9 @@
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))])))
(display-test-failure/error e))
;; parameter current-check-handler : (-> exn any)
(define current-check-handler

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

@ -2,6 +2,7 @@
(require racket/match
srfi/13
"base.rkt"
"check-info.rkt")
(provide display-check-info-name-value
@ -12,7 +13,10 @@
display-delimiter
display-failure
display-error)
display-error
display-test-failure/error
strip-redundant-params)
;; name-width : integer
;;
@ -43,7 +47,7 @@
(define (display-check-info-stack check-info-stack)
(for-each
display-check-info
check-info-stack)
(strip-redundant-params check-info-stack))
(newline))
;; display-test-name : (U string #f) -> void
@ -59,11 +63,47 @@
;; Outputs a printed representation of the exception to
;; the current-output-port
(define (display-exn exn)
(let ([op (open-output-string)])
(parameterize ([current-error-port op])
((error-display-handler)
(exn-message exn)
exn))
(display (get-output-string op))
(parameterize ((current-error-port (current-output-port)))
((error-display-handler) (exn-message exn) exn)
(newline)))
;; ----
;; strip-redundant-parms : (list-of check-info) -> (list-of check-info)
;;
;; Strip any check-params? is there is an
;; actual/expected check-info in the same stack frame. A
;; stack frame is delimited by occurrence of a check-name?
(define (strip-redundant-params stack)
(define (binary-check-this-frame? stack)
(let loop ([stack stack])
(cond
[(null? stack) #f]
[(check-name? (car stack)) #f]
[(check-actual? (car stack)) #t]
[else (loop (cdr stack))])))
(let loop ([stack stack])
(cond
[(null? stack) null]
[(check-params? (car stack))
(if (binary-check-this-frame? stack)
(loop (cdr stack))
(cons (car stack) (loop (cdr stack))))]
[else (cons (car stack) (loop (cdr stack)))])))
;; ----
(define (display-test-failure/error e [name #f])
(parameterize ((current-output-port (current-error-port)))
(display-delimiter)
(when name (display-test-name name))
(cond [(exn:test:check? e)
(display-failure) (newline)
(display-check-info-stack (exn:test:check-stack e))
(when #t
(parameterize ((error-print-context-length 0))
((error-display-handler) (exn-message e) e)))]
[(exn? e)
(display-error) (newline)
(display-exn e)])
(display-delimiter)))

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

@ -16,8 +16,6 @@
after
around)
(define USE-ERROR-HANDLER? #f)
(define current-test-name
(make-parameter
#f
@ -35,24 +33,7 @@
;; 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))])))
(display-test-failure/error e (current-test-name)))
(define current-test-case-around
(make-parameter

28
collects/rackunit/text-ui.rkt
View File

@ -97,37 +97,15 @@
(else
(void))))
;; strip-redundant-parms : (list-of check-info) -> (list-of check-info)
;;
;; Strip any check-params? is there is an
;; actual/expected check-info in the same stack frame. A
;; stack frame is delimited by occurrence of a check-name?
(define (strip-redundant-params stack)
(define (binary-check-this-frame? stack)
(let loop ([stack stack])
(cond
[(null? stack) #f]
[(check-name? (car stack)) #f]
[(check-actual? (car stack)) #t]
[else (loop (cdr stack))])))
(let loop ([stack stack])
(cond
[(null? stack) null]
[(check-params? (car stack))
(if (binary-check-this-frame? stack)
(loop (cdr stack))
(cons (car stack) (loop (cdr stack))))]
[else (cons (car stack) (loop (cdr stack)))])))
;; display-context : test-result [(U #t #f)] -> void
(define (display-context result [verbose? #f])
(cond
[(test-failure? result)
(let* ([exn (test-failure-result result)]
[stack (exn:test:check-stack exn)])
(textui-display-check-info-stack stack verbose?))]
(textui-display-check-info-stack stack verbose?)
(when #t
((error-display-handler) (exn-message exn) exn)))]
[(test-error? result)
(let ([exn (test-error-result result)])
(textui-display-check-info-stack (check-info-stack (exn-continuation-marks exn)))