diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index 3a059a4..87af84a 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -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 diff --git a/collects/rackunit/private/format.rkt b/collects/rackunit/private/format.rkt index 6645914..8f43de7 100644 --- a/collects/rackunit/private/format.rkt +++ b/collects/rackunit/private/format.rkt @@ -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))) diff --git a/collects/rackunit/private/test-case.rkt b/collects/rackunit/private/test-case.rkt index 36f18b2..15f226c 100644 --- a/collects/rackunit/private/test-case.rkt +++ b/collects/rackunit/private/test-case.rkt @@ -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 diff --git a/collects/rackunit/text-ui.rkt b/collects/rackunit/text-ui.rkt index 4952b7a..13fe982 100644 --- a/collects/rackunit/text-ui.rkt +++ b/collects/rackunit/text-ui.rkt @@ -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)))