Implement review comments

Add some newlines and a comment to improve readability.

Use local string port instead of parameterizing current-output-port.

Pass symbol 'BEGIN to tell test reporter that evaluation of a test
starts.  Adapt documentation of current-test-reporter accordingly.

Use define-opt instead of case-lambda.
This commit is contained in:
Jürgen Geßwein 2021-08-07 21:04:18 +02:00
parent b23db00aed
commit e0497b3084
2 changed files with 42 additions and 43 deletions

View file

@ -24,11 +24,11 @@
(newline (current-error-port)))
(define (exception-message exc)
(let* ((s (parameterize
((current-output-port (open-output-string)))
(print-exception exc (current-output-port))
(get-output-string (current-output-port))))
(let* ((s (let ((p (open-output-string)))
(print-exception exc p)
(get-output-string p)))
(n (- (string-length s) 1)))
;; Strip the “ERROR: ” prefix if present
(let loop ((i 0))
(if (>= (+ i 2) n)
(substring s 0 n)
@ -185,6 +185,7 @@
(define (test-run expect expr info)
(let ((info (test-expand-info info)))
((current-test-reporter) 'BEGIN info)
(if (and (cond ((current-test-group)
=> (lambda (g) (not (test-group-ref g 'skip-group?))))
(else #t))
@ -256,26 +257,18 @@
;;> Begin testing a new group until the closing \scheme{(test-end)}.
(define test-begin
(case-lambda
(()
(test-begin ""))
((name)
(define-opt (test-begin (name ""))
(let* ((parent (current-test-group))
(group (make-test-group name parent)))
((current-test-group-reporter) group parent)
(current-test-group group)))))
(current-test-group group)))
;;> Ends testing group introduced with \scheme{(test-begin)}, and
;;> summarizes the results. The \var{name} is optional, but if
;;> present should match the corresponding \scheme{test-begin} name,
;;> or a warning is printed.
(define test-end
(case-lambda
(()
(test-end #f))
((name)
(define-opt (test-end (name #f))
(let ((group (current-test-group)))
(when group
(when (and name (not (equal? name (test-group-name group))))
@ -292,7 +285,7 @@
(= (test-group-ref group 'subgroups-pass 0)
(test-group-ref group 'subgroups-count 0)))
(test-group-inc! parent 'subgroups-pass))))
(current-test-group parent)))))))
(current-test-group parent)))))
;;> Exits with a failure status if any tests have failed,
;;> and a successful status otherwise.
@ -527,7 +520,6 @@
info)))
(define (test-default-applier expect expr info)
((current-test-reporter) #f info)
(let ((expect-val
(guard
(exn
@ -554,7 +546,6 @@
((current-test-reporter) status info))))))
(define (test-default-skipper info)
((current-test-reporter) #f info)
((current-test-reporter) 'SKIP info))
(define (test-status-color status)
@ -737,10 +728,11 @@
=> (lambda (group) (test-group-set! group 'trailing #t))))))
(flush-output-port)
status)
(define (test-default-reporter status info)
(if (symbol? status)
(stop-test status info)
(start-test info)))
(if (eq? status 'BEGIN)
(start-test info)
(stop-test status info)))
(define (close-group group)
(define (plural word n)
@ -831,6 +823,7 @@
(else
(when (zero? (test-group-ref group 'level))
(newline))))))
(define test-default-group-reporter
(case-lambda
((group) (close-group group))
@ -878,8 +871,13 @@
(define current-test-skipper (make-parameter test-default-skipper))
;;> Takes two arguments, the symbol status of the test and the info
;;> alist. Reports the result of the test and updates bookkeeping in
;;> the current test group for reporting.
;;> alist. The status is one of \scheme{'BEGIN}, \scheme{'PASS},
;;> \scheme{'FAIL}, \scheme{'ERROR}, or \scheme{'SKIP}. For each test
;;> a reporter is called twice: once with symbol \scheme{'BEGIN} to
;;> indicate that handling of the test begins and a second time when
;;> the result was determined. A test reporter returns the tests
;;> result and updates bookkeeping in the current test group for
;;> reporting.
(define current-test-reporter (make-parameter test-default-reporter))

View file

@ -27,7 +27,8 @@
(chibi term ansi))
(cond-expand
(chibi
(import (only (chibi) pair-source print-exception)))
(import (only (chibi) pair-source print-exception)
(chibi optional)))
(chicken
(import (only (chicken) print-error-message))
(begin