71 lines
1.6 KiB
Scheme
71 lines
1.6 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/match
|
|
srfi/13)
|
|
|
|
(require "check-info.ss")
|
|
|
|
(provide
|
|
display-check-info-name-value
|
|
display-check-info
|
|
display-check-info-stack
|
|
display-test-name
|
|
display-exn
|
|
|
|
display-delimiter
|
|
display-failure
|
|
display-error)
|
|
;; name-width : integer
|
|
;;
|
|
;; Number of characters we reserve for the check-info name column
|
|
(define name-width 12)
|
|
|
|
(define (display-delimiter)
|
|
(display "--------------------") (newline))
|
|
|
|
(define (display-failure)
|
|
(display "FAILURE"))
|
|
|
|
(define (display-error)
|
|
(display "ERROR"))
|
|
|
|
(define (display-check-info-name-value name value [value-printer write])
|
|
(display (string-pad-right
|
|
(string-append (symbol->string name) ": ")
|
|
name-width))
|
|
(value-printer value)
|
|
(newline))
|
|
|
|
(define display-check-info
|
|
(match-lambda [(struct check-info (name value))
|
|
(display-check-info-name-value name value)]))
|
|
|
|
;; display-check-info-stack : (listof check-info) -> void
|
|
(define (display-check-info-stack check-info-stack)
|
|
(for-each
|
|
display-check-info
|
|
check-info-stack)
|
|
(newline))
|
|
|
|
;; display-test-name : (U string #f) -> void
|
|
(define (display-test-name name)
|
|
(if name
|
|
(begin
|
|
(display name) (newline))
|
|
(begin
|
|
(display "Unnamed test ")(newline))))
|
|
|
|
;; display-exn : exn -> void
|
|
;;
|
|
;; 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))
|
|
(newline)))
|
|
|