mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
b3da54d181
- "filesystem" -> "file system" - remove doubled words - use EXIT_* macros instead of literal numbers - update `syntax-check' exclusion files
666 lines
24 KiB
Scheme
666 lines
24 KiB
Scheme
;;;; test-suite/lib.scm --- generic support for testing
|
||
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
|
||
;;;; 2011 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This program is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This program is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;;; GNU Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this software; see the file COPYING.LESSER.
|
||
;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
|
||
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
(define-module (test-suite lib)
|
||
#:use-module (ice-9 stack-catch)
|
||
#:use-module (ice-9 regex)
|
||
#:autoload (srfi srfi-1) (append-map)
|
||
#:autoload (system base compile) (compile)
|
||
#:export (
|
||
|
||
;; Exceptions which are commonly being tested for.
|
||
exception:syntax-pattern-unmatched
|
||
exception:bad-variable
|
||
exception:missing-expression
|
||
exception:out-of-range exception:unbound-var
|
||
exception:used-before-defined
|
||
exception:wrong-num-args exception:wrong-type-arg
|
||
exception:numerical-overflow
|
||
exception:struct-set!-denied
|
||
exception:system-error
|
||
exception:encoding-error
|
||
exception:miscellaneous-error
|
||
exception:string-contains-nul
|
||
exception:read-error
|
||
exception:null-pointer-error
|
||
exception:vm-error
|
||
|
||
;; Reporting passes and failures.
|
||
run-test
|
||
pass-if expect-fail
|
||
pass-if-exception expect-fail-exception
|
||
|
||
;; Naming groups of tests in a regular fashion.
|
||
with-test-prefix
|
||
with-test-prefix*
|
||
with-test-prefix/c&e
|
||
current-test-prefix
|
||
format-test-name
|
||
|
||
;; Using the debugging evaluator.
|
||
with-debugging-evaluator with-debugging-evaluator*
|
||
|
||
;; Using a given locale
|
||
with-locale with-locale* with-latin1-locale with-latin1-locale*
|
||
|
||
;; Reporting results in various ways.
|
||
register-reporter unregister-reporter reporter-registered?
|
||
make-count-reporter print-counts
|
||
make-log-reporter
|
||
full-reporter
|
||
user-reporter))
|
||
|
||
|
||
;;;; If you're using Emacs's Scheme mode:
|
||
;;;; (put 'with-test-prefix 'scheme-indent-function 1)
|
||
|
||
|
||
;;;; CORE FUNCTIONS
|
||
;;;;
|
||
;;;; The function (run-test name expected-result thunk) is the heart of the
|
||
;;;; testing environment. The first parameter NAME is a unique name for the
|
||
;;;; test to be executed (for an explanation of this parameter see below under
|
||
;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
|
||
;;;; that indicates whether the corresponding test is expected to pass. If
|
||
;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
|
||
;;;; #f the test is expected to fail. Finally, THUNK is the function that
|
||
;;;; actually performs the test. For example:
|
||
;;;;
|
||
;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
|
||
;;;;
|
||
;;;; To report success, THUNK should either return #t or throw 'pass. To
|
||
;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
|
||
;;;; returns a non boolean value or throws 'unresolved, this indicates that
|
||
;;;; the test did not perform as expected. For example the property that was
|
||
;;;; to be tested could not be tested because something else went wrong.
|
||
;;;; THUNK may also throw 'untested to indicate that the test was deliberately
|
||
;;;; not performed, for example because the test case is not complete yet.
|
||
;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
|
||
;;;; requires some feature that is not available in the configured testing
|
||
;;;; environment. All other exceptions thrown by THUNK are considered as
|
||
;;;; errors.
|
||
;;;;
|
||
;;;;
|
||
;;;; Convenience macros for tests expected to pass or fail
|
||
;;;;
|
||
;;;; * (pass-if name body) is a short form for
|
||
;;;; (run-test name #t (lambda () body))
|
||
;;;; * (expect-fail name body) is a short form for
|
||
;;;; (run-test name #f (lambda () body))
|
||
;;;;
|
||
;;;; For example:
|
||
;;;;
|
||
;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
|
||
;;;;
|
||
;;;;
|
||
;;;; Convenience macros to test for exceptions
|
||
;;;;
|
||
;;;; The following macros take exception parameters which are pairs
|
||
;;;; (type . message), where type is a symbol that denotes an exception type
|
||
;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
|
||
;;;; regular expression that describes the error message for the exception
|
||
;;;; like "Argument .* out of range".
|
||
;;;;
|
||
;;;; * (pass-if-exception name exception body) will pass if the execution of
|
||
;;;; body causes the given exception to be thrown. If no exception is
|
||
;;;; thrown, the test fails. If some other exception is thrown, it is an
|
||
;;;; error.
|
||
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
|
||
;;;; the execution of body causes the given exception to be thrown. If no
|
||
;;;; exception is thrown, the test fails expectedly. If some other
|
||
;;;; exception is thrown, it is an error.
|
||
|
||
|
||
;;;; TEST NAMES
|
||
;;;;
|
||
;;;; Every test in the test suite has a unique name, to help
|
||
;;;; developers find tests that are failing (or unexpectedly passing),
|
||
;;;; and to help gather statistics.
|
||
;;;;
|
||
;;;; A test name is a list of printable objects. For example:
|
||
;;;; ("ports.scm" "file" "read and write back list of strings")
|
||
;;;; ("ports.scm" "pipe" "read")
|
||
;;;;
|
||
;;;; Test names may contain arbitrary objects, but they always have
|
||
;;;; the following properties:
|
||
;;;; - Test names can be compared with EQUAL?.
|
||
;;;; - Test names can be reliably stored and retrieved with the standard WRITE
|
||
;;;; and READ procedures; doing so preserves their identity.
|
||
;;;;
|
||
;;;; For example:
|
||
;;;;
|
||
;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
|
||
;;;;
|
||
;;;; In that case, the test name is the list ("simple addition").
|
||
;;;;
|
||
;;;; In the case of simple tests the expression that is tested would often
|
||
;;;; suffice as a test name by itself. Therefore, the convenience macros
|
||
;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
|
||
;;;; a test name in such cases.
|
||
;;;;
|
||
;;;; * (pass-if expression) is a short form for
|
||
;;;; (run-test 'expression #t (lambda () expression))
|
||
;;;; * (expect-fail expression) is a short form for
|
||
;;;; (run-test 'expression #f (lambda () expression))
|
||
;;;;
|
||
;;;; For example:
|
||
;;;;
|
||
;;;; (pass-if (= 2 (+ 1 1)))
|
||
;;;;
|
||
;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
|
||
;;;; a prefix for the names of all tests whose results are reported
|
||
;;;; within their dynamic scope. For example:
|
||
;;;;
|
||
;;;; (begin
|
||
;;;; (with-test-prefix "basic arithmetic"
|
||
;;;; (pass-if "addition" (= (+ 2 2) 4))
|
||
;;;; (pass-if "subtraction" (= (- 4 2) 2)))
|
||
;;;; (pass-if "multiplication" (= (* 2 2) 4)))
|
||
;;;;
|
||
;;;; In that example, the three test names are:
|
||
;;;; ("basic arithmetic" "addition"),
|
||
;;;; ("basic arithmetic" "subtraction"), and
|
||
;;;; ("multiplication").
|
||
;;;;
|
||
;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX appends
|
||
;;;; a new element to the current prefix:
|
||
;;;;
|
||
;;;; (with-test-prefix "arithmetic"
|
||
;;;; (with-test-prefix "addition"
|
||
;;;; (pass-if "integer" (= (+ 2 2) 4))
|
||
;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
|
||
;;;; (with-test-prefix "subtraction"
|
||
;;;; (pass-if "integer" (= (- 2 2) 0))
|
||
;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
|
||
;;;;
|
||
;;;; The four test names here are:
|
||
;;;; ("arithmetic" "addition" "integer")
|
||
;;;; ("arithmetic" "addition" "complex")
|
||
;;;; ("arithmetic" "subtraction" "integer")
|
||
;;;; ("arithmetic" "subtraction" "complex")
|
||
;;;;
|
||
;;;; To print a name for a human reader, we DISPLAY its elements,
|
||
;;;; separated by ": ". So, the last set of test names would be
|
||
;;;; reported as:
|
||
;;;;
|
||
;;;; arithmetic: addition: integer
|
||
;;;; arithmetic: addition: complex
|
||
;;;; arithmetic: subtraction: integer
|
||
;;;; arithmetic: subtraction: complex
|
||
;;;;
|
||
;;;; The Guile benchmarks use with-test-prefix to include the name of
|
||
;;;; the source file containing the test in the test name, to help
|
||
;;;; developers to find failing tests, and to provide each file with its
|
||
;;;; own namespace.
|
||
|
||
|
||
;;;; REPORTERS
|
||
;;;;
|
||
;;;; A reporter is a function which we apply to each test outcome.
|
||
;;;; Reporters can log results, print interesting results to the
|
||
;;;; standard output, collect statistics, etc.
|
||
;;;;
|
||
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
|
||
;;;; possibly additional arguments depending on RESULT; its return value
|
||
;;;; is ignored. RESULT has one of the following forms:
|
||
;;;;
|
||
;;;; pass - The test named TEST passed.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; upass - The test named TEST passed unexpectedly.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; fail - The test named TEST failed.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; xfail - The test named TEST failed, as expected.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; unresolved - The test named TEST did not perform as expected, for
|
||
;;;; example the property that was to be tested could not be
|
||
;;;; tested because something else went wrong.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; untested - The test named TEST was not actually performed, for
|
||
;;;; example because the test case is not complete yet.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; unsupported - The test named TEST requires some feature that is not
|
||
;;;; available in the configured testing environment.
|
||
;;;; Additional arguments are ignored.
|
||
;;;; error - An error occurred while the test named TEST was
|
||
;;;; performed. Since this result means that the system caught
|
||
;;;; an exception it could not handle, the exception arguments
|
||
;;;; are passed as additional arguments.
|
||
;;;;
|
||
;;;; This library provides some standard reporters for logging results
|
||
;;;; to a file, reporting interesting results to the user, and
|
||
;;;; collecting totals.
|
||
;;;;
|
||
;;;; You can use the REGISTER-REPORTER function and friends to add
|
||
;;;; whatever reporting functions you like. If you don't register any
|
||
;;;; reporters, the library uses FULL-REPORTER, which simply writes
|
||
;;;; all results to the standard output.
|
||
|
||
|
||
;;;; MISCELLANEOUS
|
||
;;;;
|
||
|
||
;;; Define some exceptions which are commonly being tested for.
|
||
(define exception:syntax-pattern-unmatched
|
||
(cons 'syntax-error "source expression failed to match any pattern"))
|
||
(define exception:bad-variable
|
||
(cons 'syntax-error "Bad variable"))
|
||
(define exception:missing-expression
|
||
(cons 'misc-error "^missing or extra expression"))
|
||
(define exception:out-of-range
|
||
(cons 'out-of-range "^.*out of range"))
|
||
(define exception:unbound-var
|
||
(cons 'unbound-variable "^Unbound variable"))
|
||
(define exception:used-before-defined
|
||
(cons 'unbound-variable "^Variable used before given a value"))
|
||
(define exception:wrong-num-args
|
||
(cons 'wrong-number-of-args "^Wrong number of arguments"))
|
||
(define exception:wrong-type-arg
|
||
(cons 'wrong-type-arg "^Wrong type"))
|
||
(define exception:numerical-overflow
|
||
(cons 'numerical-overflow "^Numerical overflow"))
|
||
(define exception:struct-set!-denied
|
||
(cons 'misc-error "^set! denied for field"))
|
||
(define exception:system-error
|
||
(cons 'system-error ".*"))
|
||
(define exception:encoding-error
|
||
(cons 'encoding-error "(cannot convert to output locale|input (locale conversion|decoding) error)"))
|
||
(define exception:miscellaneous-error
|
||
(cons 'misc-error "^.*"))
|
||
(define exception:read-error
|
||
(cons 'read-error "^.*$"))
|
||
(define exception:null-pointer-error
|
||
(cons 'null-pointer-error "^.*$"))
|
||
(define exception:vm-error
|
||
(cons 'vm-error "^.*$"))
|
||
|
||
;; as per throw in scm_to_locale_stringn()
|
||
(define exception:string-contains-nul
|
||
(cons 'misc-error "^string contains #\\\\nul character"))
|
||
|
||
|
||
;;; Display all parameters to the default output port, followed by a newline.
|
||
(define (display-line . objs)
|
||
(for-each display objs)
|
||
(newline))
|
||
|
||
;;; Display all parameters to the given output port, followed by a newline.
|
||
(define (display-line-port port . objs)
|
||
(for-each (lambda (obj) (display obj port)) objs)
|
||
(newline port))
|
||
|
||
|
||
;;;; CORE FUNCTIONS
|
||
;;;;
|
||
|
||
;;; The central testing routine.
|
||
;;; The idea is taken from Greg, the GNUstep regression test environment.
|
||
(define run-test #f)
|
||
(let ((test-running #f))
|
||
(define (local-run-test name expect-pass thunk)
|
||
(if test-running
|
||
(error "Nested calls to run-test are not permitted.")
|
||
(let ((test-name (full-name name)))
|
||
(set! test-running #t)
|
||
(catch #t
|
||
(lambda ()
|
||
(let ((result (thunk)))
|
||
(if (eq? result #t) (throw 'pass))
|
||
(if (eq? result #f) (throw 'fail))
|
||
(throw 'unresolved)))
|
||
(lambda (key . args)
|
||
(case key
|
||
((pass)
|
||
(report (if expect-pass 'pass 'upass) test-name))
|
||
((fail)
|
||
(report (if expect-pass 'fail 'xfail) test-name))
|
||
((unresolved untested unsupported)
|
||
(report key test-name))
|
||
((quit)
|
||
(report 'unresolved test-name)
|
||
(quit))
|
||
(else
|
||
(report 'error test-name (cons key args))))))
|
||
(set! test-running #f))))
|
||
(set! run-test local-run-test))
|
||
|
||
;;; A short form for tests that are expected to pass, taken from Greg.
|
||
(define-syntax pass-if
|
||
(syntax-rules ()
|
||
((_ name)
|
||
;; presume this is a simple test, i.e. (pass-if (even? 2))
|
||
;; where the body should also be the name.
|
||
(run-test 'name #t (lambda () name)))
|
||
((_ name rest ...)
|
||
(run-test name #t (lambda () rest ...)))))
|
||
|
||
;;; A short form for tests that are expected to fail, taken from Greg.
|
||
(define-syntax expect-fail
|
||
(syntax-rules ()
|
||
((_ name)
|
||
;; presume this is a simple test, i.e. (expect-fail (even? 2))
|
||
;; where the body should also be the name.
|
||
(run-test 'name #f (lambda () name)))
|
||
((_ name rest ...)
|
||
(run-test name #f (lambda () rest ...)))))
|
||
|
||
;;; A helper function to implement the macros that test for exceptions.
|
||
(define (run-test-exception name exception expect-pass thunk)
|
||
(run-test name expect-pass
|
||
(lambda ()
|
||
(stack-catch (car exception)
|
||
(lambda () (thunk) #f)
|
||
(lambda (key proc message . rest)
|
||
(cond
|
||
;; handle explicit key
|
||
((string-match (cdr exception) message)
|
||
#t)
|
||
;; handle `(error ...)' which uses `misc-error' for key and doesn't
|
||
;; yet format the message and args (we have to do it here).
|
||
((and (eq? 'misc-error (car exception))
|
||
(list? rest)
|
||
(string-match (cdr exception)
|
||
(apply simple-format #f message (car rest))))
|
||
#t)
|
||
;; handle syntax errors which use `syntax-error' for key and don't
|
||
;; yet format the message and args (we have to do it here).
|
||
((and (eq? 'syntax-error (car exception))
|
||
(list? rest)
|
||
(string-match (cdr exception)
|
||
(apply simple-format #f message (car rest))))
|
||
#t)
|
||
;; unhandled; throw again
|
||
(else
|
||
(apply throw key proc message rest))))))))
|
||
|
||
;;; A short form for tests that expect a certain exception to be thrown.
|
||
(define-syntax pass-if-exception
|
||
(syntax-rules ()
|
||
((_ name exception body rest ...)
|
||
(run-test-exception name exception #t (lambda () body rest ...)))))
|
||
|
||
;;; A short form for tests expected to fail to throw a certain exception.
|
||
(define-syntax expect-fail-exception
|
||
(syntax-rules ()
|
||
((_ name exception body rest ...)
|
||
(run-test-exception name exception #f (lambda () body rest ...)))))
|
||
|
||
|
||
;;;; TEST NAMES
|
||
;;;;
|
||
|
||
;;;; Turn a test name into a nice human-readable string.
|
||
(define (format-test-name name)
|
||
;; Choose a Unicode-capable encoding so that the string port can contain any
|
||
;; valid Unicode character.
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(call-with-output-string
|
||
(lambda (port)
|
||
(let loop ((name name)
|
||
(separator ""))
|
||
(if (pair? name)
|
||
(begin
|
||
(display separator port)
|
||
(display (car name) port)
|
||
(loop (cdr name) ": "))))))))
|
||
|
||
;;;; For a given test-name, deliver the full name including all prefixes.
|
||
(define (full-name name)
|
||
(append (current-test-prefix) (list name)))
|
||
|
||
;;; A fluid containing the current test prefix, as a list.
|
||
(define prefix-fluid (make-fluid '()))
|
||
(define (current-test-prefix)
|
||
(fluid-ref prefix-fluid))
|
||
|
||
;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
|
||
;;; The name prefix is only changed within the dynamic scope of the
|
||
;;; call to with-test-prefix*. Return the value returned by THUNK.
|
||
(define (with-test-prefix* prefix thunk)
|
||
(with-fluids ((prefix-fluid
|
||
(append (fluid-ref prefix-fluid) (list prefix))))
|
||
(thunk)))
|
||
|
||
;;; (with-test-prefix PREFIX BODY ...)
|
||
;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
|
||
;;; The name prefix is only changed within the dynamic scope of the
|
||
;;; with-test-prefix expression. Return the value returned by the last
|
||
;;; BODY expression.
|
||
(define-syntax with-test-prefix
|
||
(syntax-rules ()
|
||
((_ prefix body ...)
|
||
(with-test-prefix* prefix (lambda () body ...)))))
|
||
|
||
(define-syntax c&e
|
||
(syntax-rules (pass-if pass-if-exception)
|
||
"Run the given tests both with the evaluator and the compiler/VM."
|
||
((_ (pass-if test-name exp))
|
||
(begin (pass-if (string-append test-name " (eval)")
|
||
(primitive-eval 'exp))
|
||
(pass-if (string-append test-name " (compile)")
|
||
(compile 'exp #:to 'value #:env (current-module)))))
|
||
((_ (pass-if-exception test-name exc exp))
|
||
(begin (pass-if-exception (string-append test-name " (eval)")
|
||
exc (primitive-eval 'exp))
|
||
(pass-if-exception (string-append test-name " (compile)")
|
||
exc (compile 'exp #:to 'value
|
||
#:env (current-module)))))))
|
||
|
||
;;; (with-test-prefix/c&e PREFIX BODY ...)
|
||
;;; Same as `with-test-prefix', but the enclosed tests are run both with
|
||
;;; the compiler/VM and the evaluator.
|
||
(define-syntax with-test-prefix/c&e
|
||
(syntax-rules ()
|
||
((_ section-name exp ...)
|
||
(with-test-prefix section-name (c&e exp) ...))))
|
||
|
||
;;; Call THUNK using the debugging evaluator.
|
||
(define (with-debugging-evaluator* thunk)
|
||
(let ((dopts #f))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(set! dopts (debug-options)))
|
||
thunk
|
||
(lambda ()
|
||
(debug-options dopts)))))
|
||
|
||
;;; Evaluate BODY... using the debugging evaluator.
|
||
(define-macro (with-debugging-evaluator . body)
|
||
`(with-debugging-evaluator* (lambda () ,@body)))
|
||
|
||
;;; Call THUNK with a given locale
|
||
(define (with-locale* nloc thunk)
|
||
(let ((loc #f))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(if (defined? 'setlocale)
|
||
(begin
|
||
(set! loc (false-if-exception (setlocale LC_ALL)))
|
||
(if (or (not loc)
|
||
(not (false-if-exception (setlocale LC_ALL nloc))))
|
||
(throw 'unresolved)))
|
||
(throw 'unresolved)))
|
||
thunk
|
||
(lambda ()
|
||
(if (and (defined? 'setlocale) loc)
|
||
(setlocale LC_ALL loc))))))
|
||
|
||
;;; Evaluate BODY... using the given locale.
|
||
(define-syntax with-locale
|
||
(syntax-rules ()
|
||
((_ loc body ...)
|
||
(with-locale* loc (lambda () body ...)))))
|
||
|
||
;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
|
||
;;; (if any).
|
||
(define (with-latin1-locale* thunk)
|
||
(define %locales
|
||
(append-map (lambda (name)
|
||
(list (string-append name ".ISO-8859-1")
|
||
(string-append name ".iso88591")
|
||
(string-append name ".ISO8859-1")))
|
||
'("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
|
||
"fr_FR" "pt_PT" "nl_NL" "sv_SE")))
|
||
|
||
(let loop ((locales %locales))
|
||
(if (null? locales)
|
||
(throw 'unresolved)
|
||
(catch 'unresolved
|
||
(lambda ()
|
||
(with-locale* (car locales) thunk))
|
||
(lambda (key . args)
|
||
(loop (cdr locales)))))))
|
||
|
||
;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
|
||
;;; was found.
|
||
(define-syntax with-latin1-locale
|
||
(syntax-rules ()
|
||
((_ body ...)
|
||
(with-latin1-locale* (lambda () body ...)))))
|
||
|
||
|
||
;;;; REPORTERS
|
||
;;;;
|
||
|
||
;;; The global list of reporters.
|
||
(define reporters '())
|
||
|
||
;;; The default reporter, to be used only if no others exist.
|
||
(define default-reporter #f)
|
||
|
||
;;; Add the procedure REPORTER to the current set of reporter functions.
|
||
;;; Signal an error if that reporter procedure object is already registered.
|
||
(define (register-reporter reporter)
|
||
(if (memq reporter reporters)
|
||
(error "register-reporter: reporter already registered: " reporter))
|
||
(set! reporters (cons reporter reporters)))
|
||
|
||
;;; Remove the procedure REPORTER from the current set of reporter
|
||
;;; functions. Signal an error if REPORTER is not currently registered.
|
||
(define (unregister-reporter reporter)
|
||
(if (memq reporter reporters)
|
||
(set! reporters (delq! reporter reporters))
|
||
(error "unregister-reporter: reporter not registered: " reporter)))
|
||
|
||
;;; Return true iff REPORTER is in the current set of reporter functions.
|
||
(define (reporter-registered? reporter)
|
||
(if (memq reporter reporters) #t #f))
|
||
|
||
;;; Send RESULT to all currently registered reporter functions.
|
||
(define (report . args)
|
||
(if (pair? reporters)
|
||
(for-each (lambda (reporter) (apply reporter args))
|
||
reporters)
|
||
(apply default-reporter args)))
|
||
|
||
|
||
;;;; Some useful standard reporters:
|
||
;;;; Count reporters count the occurrence of each test result type.
|
||
;;;; Log reporters write all test results to a given log file.
|
||
;;;; Full reporters write all test results to the standard output.
|
||
;;;; User reporters write interesting test results to the standard output.
|
||
|
||
;;; The complete list of possible test results.
|
||
(define result-tags
|
||
'((pass "PASS" "passes: ")
|
||
(fail "FAIL" "failures: ")
|
||
(upass "UPASS" "unexpected passes: ")
|
||
(xfail "XFAIL" "expected failures: ")
|
||
(unresolved "UNRESOLVED" "unresolved test cases: ")
|
||
(untested "UNTESTED" "untested test cases: ")
|
||
(unsupported "UNSUPPORTED" "unsupported test cases: ")
|
||
(error "ERROR" "errors: ")))
|
||
|
||
;;; The list of important test results.
|
||
(define important-result-tags
|
||
'(fail upass unresolved error))
|
||
|
||
;;; Display a single test result in formatted form to the given port
|
||
(define (print-result port result name . args)
|
||
(let* ((tag (assq result result-tags))
|
||
(label (if tag (cadr tag) #f)))
|
||
(if label
|
||
(begin
|
||
(display label port)
|
||
(display ": " port)
|
||
(display (format-test-name name) port)
|
||
(if (pair? args)
|
||
(begin
|
||
(display " - arguments: " port)
|
||
(write args port)))
|
||
(newline port))
|
||
(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
|
||
result))))
|
||
|
||
;;; Return a list of the form (COUNTER RESULTS), where:
|
||
;;; - COUNTER is a reporter procedure, and
|
||
;;; - RESULTS is a procedure taking no arguments which returns the
|
||
;;; results seen so far by COUNTER. The return value is an alist
|
||
;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
|
||
(define (make-count-reporter)
|
||
(let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
|
||
(list
|
||
(lambda (result name . args)
|
||
(let ((pair (assq result counts)))
|
||
(if pair
|
||
(set-cdr! pair (+ 1 (cdr pair)))
|
||
(error "count-reporter: unexpected test result: "
|
||
(cons result (cons name args))))))
|
||
(lambda ()
|
||
(append counts '())))))
|
||
|
||
;;; Print a count reporter's results nicely. Pass this function the value
|
||
;;; returned by a count reporter's RESULTS procedure.
|
||
(define (print-counts results . port?)
|
||
(let ((port (if (pair? port?)
|
||
(car port?)
|
||
(current-output-port))))
|
||
(newline port)
|
||
(display-line-port port "Totals for this test run:")
|
||
(for-each
|
||
(lambda (tag)
|
||
(let ((result (assq (car tag) results)))
|
||
(if result
|
||
(display-line-port port (caddr tag) (cdr result))
|
||
(display-line-port port
|
||
"Test suite bug: "
|
||
"no total available for `" (car tag) "'"))))
|
||
result-tags)
|
||
(newline port)))
|
||
|
||
;;; Return a reporter procedure which prints all results to the file
|
||
;;; FILE, in human-readable form. FILE may be a filename, or a port.
|
||
(define (make-log-reporter file)
|
||
(let ((port (if (output-port? file) file
|
||
(open-output-file file))))
|
||
(lambda args
|
||
(apply print-result port args)
|
||
(force-output port))))
|
||
|
||
;;; A reporter that reports all results to the user.
|
||
(define (full-reporter . args)
|
||
(apply print-result (current-output-port) args))
|
||
|
||
;;; A reporter procedure which shows interesting results (failures,
|
||
;;; unexpected passes etc.) to the user.
|
||
(define (user-reporter result name . args)
|
||
(if (memq result important-result-tags)
|
||
(apply full-reporter result name args)))
|
||
|
||
(set! default-reporter full-reporter)
|