mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
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:
parent
b23db00aed
commit
e0497b3084
2 changed files with 42 additions and 43 deletions
|
@ -24,11 +24,11 @@
|
||||||
(newline (current-error-port)))
|
(newline (current-error-port)))
|
||||||
|
|
||||||
(define (exception-message exc)
|
(define (exception-message exc)
|
||||||
(let* ((s (parameterize
|
(let* ((s (let ((p (open-output-string)))
|
||||||
((current-output-port (open-output-string)))
|
(print-exception exc p)
|
||||||
(print-exception exc (current-output-port))
|
(get-output-string p)))
|
||||||
(get-output-string (current-output-port))))
|
|
||||||
(n (- (string-length s) 1)))
|
(n (- (string-length s) 1)))
|
||||||
|
;; Strip the “ERROR: ” prefix if present
|
||||||
(let loop ((i 0))
|
(let loop ((i 0))
|
||||||
(if (>= (+ i 2) n)
|
(if (>= (+ i 2) n)
|
||||||
(substring s 0 n)
|
(substring s 0 n)
|
||||||
|
@ -185,6 +185,7 @@
|
||||||
|
|
||||||
(define (test-run expect expr info)
|
(define (test-run expect expr info)
|
||||||
(let ((info (test-expand-info info)))
|
(let ((info (test-expand-info info)))
|
||||||
|
((current-test-reporter) 'BEGIN info)
|
||||||
(if (and (cond ((current-test-group)
|
(if (and (cond ((current-test-group)
|
||||||
=> (lambda (g) (not (test-group-ref g 'skip-group?))))
|
=> (lambda (g) (not (test-group-ref g 'skip-group?))))
|
||||||
(else #t))
|
(else #t))
|
||||||
|
@ -256,26 +257,18 @@
|
||||||
|
|
||||||
;;> Begin testing a new group until the closing \scheme{(test-end)}.
|
;;> Begin testing a new group until the closing \scheme{(test-end)}.
|
||||||
|
|
||||||
(define test-begin
|
(define-opt (test-begin (name ""))
|
||||||
(case-lambda
|
|
||||||
(()
|
|
||||||
(test-begin ""))
|
|
||||||
((name)
|
|
||||||
(let* ((parent (current-test-group))
|
(let* ((parent (current-test-group))
|
||||||
(group (make-test-group name parent)))
|
(group (make-test-group name parent)))
|
||||||
((current-test-group-reporter) group parent)
|
((current-test-group-reporter) group parent)
|
||||||
(current-test-group group)))))
|
(current-test-group group)))
|
||||||
|
|
||||||
;;> Ends testing group introduced with \scheme{(test-begin)}, and
|
;;> Ends testing group introduced with \scheme{(test-begin)}, and
|
||||||
;;> summarizes the results. The \var{name} is optional, but if
|
;;> summarizes the results. The \var{name} is optional, but if
|
||||||
;;> present should match the corresponding \scheme{test-begin} name,
|
;;> present should match the corresponding \scheme{test-begin} name,
|
||||||
;;> or a warning is printed.
|
;;> or a warning is printed.
|
||||||
|
|
||||||
(define test-end
|
(define-opt (test-end (name #f))
|
||||||
(case-lambda
|
|
||||||
(()
|
|
||||||
(test-end #f))
|
|
||||||
((name)
|
|
||||||
(let ((group (current-test-group)))
|
(let ((group (current-test-group)))
|
||||||
(when group
|
(when group
|
||||||
(when (and name (not (equal? name (test-group-name 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-pass 0)
|
||||||
(test-group-ref group 'subgroups-count 0)))
|
(test-group-ref group 'subgroups-count 0)))
|
||||||
(test-group-inc! parent 'subgroups-pass))))
|
(test-group-inc! parent 'subgroups-pass))))
|
||||||
(current-test-group parent)))))))
|
(current-test-group parent)))))
|
||||||
|
|
||||||
;;> Exits with a failure status if any tests have failed,
|
;;> Exits with a failure status if any tests have failed,
|
||||||
;;> and a successful status otherwise.
|
;;> and a successful status otherwise.
|
||||||
|
@ -527,7 +520,6 @@
|
||||||
info)))
|
info)))
|
||||||
|
|
||||||
(define (test-default-applier expect expr info)
|
(define (test-default-applier expect expr info)
|
||||||
((current-test-reporter) #f info)
|
|
||||||
(let ((expect-val
|
(let ((expect-val
|
||||||
(guard
|
(guard
|
||||||
(exn
|
(exn
|
||||||
|
@ -554,7 +546,6 @@
|
||||||
((current-test-reporter) status info))))))
|
((current-test-reporter) status info))))))
|
||||||
|
|
||||||
(define (test-default-skipper info)
|
(define (test-default-skipper info)
|
||||||
((current-test-reporter) #f info)
|
|
||||||
((current-test-reporter) 'SKIP info))
|
((current-test-reporter) 'SKIP info))
|
||||||
|
|
||||||
(define (test-status-color status)
|
(define (test-status-color status)
|
||||||
|
@ -737,10 +728,11 @@
|
||||||
=> (lambda (group) (test-group-set! group 'trailing #t))))))
|
=> (lambda (group) (test-group-set! group 'trailing #t))))))
|
||||||
(flush-output-port)
|
(flush-output-port)
|
||||||
status)
|
status)
|
||||||
|
|
||||||
(define (test-default-reporter status info)
|
(define (test-default-reporter status info)
|
||||||
(if (symbol? status)
|
(if (eq? status 'BEGIN)
|
||||||
(stop-test status info)
|
(start-test info)
|
||||||
(start-test info)))
|
(stop-test status info)))
|
||||||
|
|
||||||
(define (close-group group)
|
(define (close-group group)
|
||||||
(define (plural word n)
|
(define (plural word n)
|
||||||
|
@ -831,6 +823,7 @@
|
||||||
(else
|
(else
|
||||||
(when (zero? (test-group-ref group 'level))
|
(when (zero? (test-group-ref group 'level))
|
||||||
(newline))))))
|
(newline))))))
|
||||||
|
|
||||||
(define test-default-group-reporter
|
(define test-default-group-reporter
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((group) (close-group group))
|
((group) (close-group group))
|
||||||
|
@ -878,8 +871,13 @@
|
||||||
(define current-test-skipper (make-parameter test-default-skipper))
|
(define current-test-skipper (make-parameter test-default-skipper))
|
||||||
|
|
||||||
;;> Takes two arguments, the symbol status of the test and the info
|
;;> Takes two arguments, the symbol status of the test and the info
|
||||||
;;> alist. Reports the result of the test and updates bookkeeping in
|
;;> alist. The status is one of \scheme{'BEGIN}, \scheme{'PASS},
|
||||||
;;> the current test group for reporting.
|
;;> \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 test’s
|
||||||
|
;;> result and updates bookkeeping in the current test group for
|
||||||
|
;;> reporting.
|
||||||
|
|
||||||
(define current-test-reporter (make-parameter test-default-reporter))
|
(define current-test-reporter (make-parameter test-default-reporter))
|
||||||
|
|
||||||
|
|
|
@ -27,7 +27,8 @@
|
||||||
(chibi term ansi))
|
(chibi term ansi))
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(chibi
|
(chibi
|
||||||
(import (only (chibi) pair-source print-exception)))
|
(import (only (chibi) pair-source print-exception)
|
||||||
|
(chibi optional)))
|
||||||
(chicken
|
(chicken
|
||||||
(import (only (chicken) print-error-message))
|
(import (only (chicken) print-error-message))
|
||||||
(begin
|
(begin
|
||||||
|
|
Loading…
Add table
Reference in a new issue