test-suite/lib.scm

   1 ;;;; test-suite/lib.scm --- generic support for testing
   2 ;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This program is free software; you can redistribute it and/or modify
   5 ;;;; it under the terms of the GNU General Public License as published by
   6 ;;;; the Free Software Foundation; either version 2, or (at your option)
   7 ;;;; any later version.
   8 ;;;;
   9 ;;;; This program is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;;; GNU General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU General Public License
  15 ;;;; along with this software; see the file COPYING.  If not, write to
  16 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17 ;;;; Boston, MA 02111-1307 USA
  18
  19 (define-module (test-suite lib))
  20
  21 (export
  22
  23  ;; Reporting passes and failures.
  24  run-test pass-if expect-fail
  25
  26  ;; Naming groups of tests in a regular fashion.
  27  with-test-prefix with-test-prefix* current-test-prefix
  28
  29  ;; Reporting results in various ways.
  30  register-reporter unregister-reporter reporter-registered?
  31  make-count-reporter print-counts
  32  make-log-reporter
  33  full-reporter
  34  user-reporter
  35  format-test-name
  36
  37  ;; Noticing whether an error occurs.
  38  signals-error? signals-error?*)
  39
  40
  41 ;;;; If you're using Emacs's Scheme mode:
  42 ;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
  43
  44 \f
  45 ;;;; CORE FUNCTIONS
  46 ;;;;
  47 ;;;; The function (run-test name expected-result thunk) is the heart of the
  48 ;;;; testing environment.  The first parameter NAME is a unique name for the
  49 ;;;; test to be executed (for an explanation of this parameter see below under
  50 ;;;; TEST NAMES).  The second parameter EXPECTED-RESULT is a boolean value
  51 ;;;; that indicates whether the corresponding test is expected to pass.  If
  52 ;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
  53 ;;;; #f the test is expected to fail.  Finally, THUNK is the function that
  54 ;;;; actually performs the test.  For example:
  55 ;;;;
  56 ;;;;    (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
  57 ;;;;
  58 ;;;; To report success, THUNK should either return #t or throw 'pass.  To
  59 ;;;; report failure, THUNK should either return #f or throw 'fail.  If THUNK
  60 ;;;; returns a non boolean value or throws 'unresolved, this indicates that
  61 ;;;; the test did not perform as expected.  For example the property that was
  62 ;;;; to be tested could not be tested because something else went wrong.
  63 ;;;; THUNK may also throw 'untested to indicate that the test was deliberately
  64 ;;;; not performed, for example because the test case is not complete yet.
  65 ;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
  66 ;;;; requires some feature that is not available in the configured testing
  67 ;;;; environment.  All other exceptions thrown by THUNK are considered as
  68 ;;;; errors.
  69 ;;;;
  70 ;;;; For convenience, the following macros are provided:
  71 ;;;; * (pass-if name body) is a short form for
  72 ;;;;   (run-test name #t (lambda () body))
  73 ;;;; * (expect-fail name body) is a short form for
  74 ;;;;   (run-test name #f (lambda () body))
  75 ;;;;
  76 ;;;; For example:
  77 ;;;;
  78 ;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
  79
  80
  81 \f
  82 ;;;; TEST NAMES
  83 ;;;;
  84 ;;;; Every test in the test suite has a unique name, to help
  85 ;;;; developers find tests that are failing (or unexpectedly passing),
  86 ;;;; and to help gather statistics.
  87 ;;;;
  88 ;;;; A test name is a list of printable objects.  For example:
  89 ;;;; ("ports.scm" "file" "read and write back list of strings")
  90 ;;;; ("ports.scm" "pipe" "read")
  91 ;;;;
  92 ;;;; Test names may contain arbitrary objects, but they always have
  93 ;;;; the following properties:
  94 ;;;; - Test names can be compared with EQUAL?.
  95 ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
  96 ;;;;   and READ procedures; doing so preserves their identity.
  97 ;;;;
  98 ;;;; For example:
  99 ;;;;
 100 ;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
 101 ;;;;
 102 ;;;; In that case, the test name is the list ("simple addition").
 103 ;;;;
 104 ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
 105 ;;;; a prefix for the names of all tests whose results are reported
 106 ;;;; within their dynamic scope.  For example:
 107 ;;;;
 108 ;;;; (begin
 109 ;;;;   (with-test-prefix "basic arithmetic"
 110 ;;;;     (pass-if "addition" (= (+ 2 2) 4))
 111 ;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
 112 ;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
 113 ;;;;
 114 ;;;; In that example, the three test names are:
 115 ;;;;   ("basic arithmetic" "addition"),
 116 ;;;;   ("basic arithmetic" "subtraction"), and
 117 ;;;;   ("multiplication").
 118 ;;;;
 119 ;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
 120 ;;;; a new element to the current prefix:
 121 ;;;;
 122 ;;;; (with-test-prefix "arithmetic"
 123 ;;;;   (with-test-prefix "addition"
 124 ;;;;     (pass-if "integer" (= (+ 2 2) 4))
 125 ;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
 126 ;;;;   (with-test-prefix "subtraction"
 127 ;;;;     (pass-if "integer" (= (- 2 2) 0))
 128 ;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
 129 ;;;;
 130 ;;;; The four test names here are:
 131 ;;;;   ("arithmetic" "addition" "integer")
 132 ;;;;   ("arithmetic" "addition" "complex")
 133 ;;;;   ("arithmetic" "subtraction" "integer")
 134 ;;;;   ("arithmetic" "subtraction" "complex")
 135 ;;;;
 136 ;;;; To print a name for a human reader, we DISPLAY its elements,
 137 ;;;; separated by ": ".  So, the last set of test names would be
 138 ;;;; reported as:
 139 ;;;;
 140 ;;;;   arithmetic: addition: integer
 141 ;;;;   arithmetic: addition: complex
 142 ;;;;   arithmetic: subtraction: integer
 143 ;;;;   arithmetic: subtraction: complex
 144 ;;;;
 145 ;;;; The Guile benchmarks use with-test-prefix to include the name of
 146 ;;;; the source file containing the test in the test name, to help
 147 ;;;; developers to find failing tests, and to provide each file with its
 148 ;;;; own namespace.
 149
 150 \f
 151 ;;;; REPORTERS
 152 ;;;;
 153 ;;;; A reporter is a function which we apply to each test outcome.
 154 ;;;; Reporters can log results, print interesting results to the
 155 ;;;; standard output, collect statistics, etc.
 156 ;;;;
 157 ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
 158 ;;;; possibly additional arguments depending on RESULT; its return value
 159 ;;;; is ignored.  RESULT has one of the following forms:
 160 ;;;;
 161 ;;;; pass         - The test named TEST passed.
 162 ;;;;                Additional arguments are ignored.
 163 ;;;; upass        - The test named TEST passed unexpectedly.
 164 ;;;;                Additional arguments are ignored.
 165 ;;;; fail         - The test named TEST failed.
 166 ;;;;                Additional arguments are ignored.
 167 ;;;; xfail        - The test named TEST failed, as expected.
 168 ;;;;                Additional arguments are ignored.
 169 ;;;; unresolved   - The test named TEST did not perform as expected, for
 170 ;;;;                example the property that was to be tested could not be
 171 ;;;;                tested because something else went wrong.
 172 ;;;;                Additional arguments are ignored.
 173 ;;;; untested     - The test named TEST was not actually performed, for
 174 ;;;;                example because the test case is not complete yet.
 175 ;;;;                Additional arguments are ignored.
 176 ;;;; unsupported  - The test named TEST requires some feature that is not
 177 ;;;;                available in the configured testing environment.
 178 ;;;;                Additional arguments are ignored.
 179 ;;;; error        - An error occurred while the test named TEST was
 180 ;;;;                performed.  Since this result means that the system caught
 181 ;;;;                an exception it could not handle, the exception arguments
 182 ;;;;                are passed as additional arguments.
 183 ;;;;
 184 ;;;; This library provides some standard reporters for logging results
 185 ;;;; to a file, reporting interesting results to the user, and
 186 ;;;; collecting totals.
 187 ;;;;
 188 ;;;; You can use the REGISTER-REPORTER function and friends to add
 189 ;;;; whatever reporting functions you like.  If you don't register any
 190 ;;;; reporters, the library uses FULL-REPORTER, which simply writes
 191 ;;;; all results to the standard output.
 192
 193 \f
 194 ;;;; MISCELLANEOUS
 195 ;;;;
 196
 197 ;;; Display all parameters to the default output port, followed by a newline.
 198 (define (display-line . objs)
 199   (for-each display objs)
 200   (newline))
 201
 202 ;;; Display all parameters to the given output port, followed by a newline.
 203 (define (display-line-port port . objs)
 204   (for-each (lambda (obj) (display obj port)) objs)
 205   (newline port))
 206
 207 \f
 208 ;;;; CORE FUNCTIONS
 209 ;;;;
 210
 211 ;;; The central testing routine.
 212 ;;; The idea is taken from Greg, the GNUstep regression test environment.
 213 (define run-test #f)
 214 (let ((test-running #f))
 215   (define (local-run-test name expect-pass thunk)
 216     (if test-running
 217         (error "Nested calls to run-test are not permitted.")
 218         (let ((test-name (full-name name)))
 219           (set! test-running #t)
 220           (catch #t
 221             (lambda ()
 222               (let ((result (thunk)))
 223                 (if (eq? result #t) (throw 'pass))
 224                 (if (eq? result #f) (throw 'fail))
 225                 (throw 'unresolved)))
 226             (lambda (key . args)
 227               (case key
 228                 ((pass)
 229                  (report (if expect-pass 'pass 'upass) test-name))
 230                 ((fail)
 231                  (report (if expect-pass 'fail 'xfail) test-name))
 232                 ((unresolved untested unsupported)
 233                  (report key test-name))
 234                 ((quit)
 235                  (report 'unresolved test-name)
 236                  (quit))
 237                 (else
 238                  (report 'error test-name (cons key args))))))
 239           (set! test-running #f))))
 240   (set! run-test local-run-test))
 241
 242 ;;; A short form for tests that are expected to pass, taken from Greg.
 243 (defmacro pass-if (name body . rest)
 244   `(run-test ,name #t (lambda () (not (not (begin ,body ,@rest))))))
 245
 246 ;;; A short form for tests that are expected to fail, taken from Greg.
 247 (defmacro expect-fail (name body . rest)
 248   `(run-test ,name #f (lambda () ,body ,@rest)))
 249
 250 \f
 251 ;;;; TEST NAMES
 252 ;;;;
 253
 254 ;;;; Turn a test name into a nice human-readable string.
 255 (define (format-test-name name)
 256   (call-with-output-string
 257    (lambda (port)
 258      (let loop ((name name)
 259                 (separator ""))
 260        (if (pair? name)
 261            (begin
 262              (display separator port)
 263              (display (car name) port)
 264              (loop (cdr name) ": ")))))))
 265
 266 ;;;; For a given test-name, deliver the full name including all prefixes.
 267 (define (full-name name)
 268   (append (current-test-prefix) (list name)))
 269
 270 ;;; A fluid containing the current test prefix, as a list.
 271 (define prefix-fluid (make-fluid))
 272 (fluid-set! prefix-fluid '())
 273 (define (current-test-prefix)
 274   (fluid-ref prefix-fluid))
 275
 276 ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
 277 ;;; The name prefix is only changed within the dynamic scope of the
 278 ;;; call to with-test-prefix*.  Return the value returned by THUNK.
 279 (define (with-test-prefix* prefix thunk)
 280   (with-fluids ((prefix-fluid
 281                  (append (fluid-ref prefix-fluid) (list prefix))))
 282     (thunk)))
 283
 284 ;;; (with-test-prefix PREFIX BODY ...)
 285 ;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
 286 ;;; The name prefix is only changed within the dynamic scope of the
 287 ;;; with-test-prefix expression.  Return the value returned by the last
 288 ;;; BODY expression.
 289 (defmacro with-test-prefix (prefix . body)
 290   `(with-test-prefix* ,prefix (lambda () ,@body)))
 291
 292 \f
 293 ;;;; REPORTERS
 294 ;;;;
 295
 296 ;;; The global list of reporters.
 297 (define reporters '())
 298
 299 ;;; The default reporter, to be used only if no others exist.
 300 (define default-reporter #f)
 301
 302 ;;; Add the procedure REPORTER to the current set of reporter functions.
 303 ;;; Signal an error if that reporter procedure object is already registered.
 304 (define (register-reporter reporter)
 305   (if (memq reporter reporters)
 306       (error "register-reporter: reporter already registered: " reporter))
 307   (set! reporters (cons reporter reporters)))
 308
 309 ;;; Remove the procedure REPORTER from the current set of reporter
 310 ;;; functions.  Signal an error if REPORTER is not currently registered.
 311 (define (unregister-reporter reporter)
 312   (if (memq reporter reporters)
 313       (set! reporters (delq! reporter reporters))
 314       (error "unregister-reporter: reporter not registered: " reporter)))
 315
 316 ;;; Return true iff REPORTER is in the current set of reporter functions.
 317 (define (reporter-registered? reporter)
 318   (if (memq reporter reporters) #t #f))
 319
 320 ;;; Send RESULT to all currently registered reporter functions.
 321 (define (report . args)
 322   (if (pair? reporters)
 323       (for-each (lambda (reporter) (apply reporter args))
 324                 reporters)
 325       (apply default-reporter args)))
 326
 327 \f
 328 ;;;; Some useful standard reporters:
 329 ;;;; Count reporters count the occurrence of each test result type.
 330 ;;;; Log reporters write all test results to a given log file.
 331 ;;;; Full reporters write all test results to the standard output.
 332 ;;;; User reporters write interesting test results to the standard output.
 333
 334 ;;; The complete list of possible test results.
 335 (define result-tags
 336   '((pass        "PASS"        "passes:                 ")
 337     (fail        "FAIL"        "failures:               ")
 338     (upass       "UPASS"       "unexpected passes:      ")
 339     (xfail       "XFAIL"       "expected failures:      ")
 340     (unresolved  "UNRESOLVED"  "unresolved test cases:  ")
 341     (untested    "UNTESTED"    "untested test cases:    ")
 342     (unsupported "UNSUPPORTED" "unsupported test cases: ")
 343     (error       "ERROR"       "errors:                 ")))
 344
 345 ;;; The list of important test results.
 346 (define important-result-tags
 347   '(fail upass unresolved error))
 348
 349 ;;; Display a single test result in formatted form to the given port
 350 (define (print-result port result name . args)
 351   (let* ((tag (assq result result-tags))
 352          (label (if tag (cadr tag) #f)))
 353     (if label
 354         (begin
 355           (display label port)
 356           (display ": " port)
 357           (display (format-test-name name) port)
 358           (if (pair? args)
 359               (begin
 360                 (display " - arguments: " port)
 361                 (write args port)))
 362           (newline port))
 363         (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
 364                result))))
 365
 366 ;;; Return a list of the form (COUNTER RESULTS), where:
 367 ;;; - COUNTER is a reporter procedure, and
 368 ;;; - RESULTS is a procedure taking no arguments which returns the
 369 ;;;   results seen so far by COUNTER.  The return value is an alist
 370 ;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
 371 (define (make-count-reporter)
 372   (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
 373     (list
 374      (lambda (result name . args)
 375        (let ((pair (assq result counts)))
 376          (if pair
 377              (set-cdr! pair (+ 1 (cdr pair)))
 378              (error "count-reporter: unexpected test result: "
 379                     (cons result (cons name args))))))
 380      (lambda ()
 381        (append counts '())))))
 382
 383 ;;; Print a count reporter's results nicely.  Pass this function the value
 384 ;;; returned by a count reporter's RESULTS procedure.
 385 (define (print-counts results . port?)
 386   (let ((port (if (pair? port?)
 387                   (car port?)
 388                   (current-output-port))))
 389     (newline port)
 390     (display-line-port port "Totals for this test run:")
 391     (for-each
 392      (lambda (tag)
 393        (let ((result (assq (car tag) results)))
 394          (if result
 395              (display-line-port port (caddr tag) (cdr result))
 396              (display-line-port port
 397                                 "Test suite bug: "
 398                                 "no total available for `" (car tag) "'"))))
 399      result-tags)
 400     (newline port)))
 401
 402 ;;; Return a reporter procedure which prints all results to the file
 403 ;;; FILE, in human-readable form.  FILE may be a filename, or a port.
 404 (define (make-log-reporter file)
 405   (let ((port (if (output-port? file) file
 406                   (open-output-file file))))
 407     (lambda args
 408       (apply print-result port args)
 409       (force-output port))))
 410
 411 ;;; A reporter that reports all results to the user.
 412 (define (full-reporter . args)
 413   (apply print-result (current-output-port) args))
 414
 415 ;;; A reporter procedure which shows interesting results (failures,
 416 ;;; unexpected passes etc.) to the user.
 417 (define (user-reporter result name . args)
 418   (if (memq result important-result-tags)
 419       (apply full-reporter result name args)))
 420
 421 (set! default-reporter full-reporter)
 422
 423 \f
 424 ;;;; Detecting whether errors occur
 425
 426 ;;; (signals-error? KEY BODY ...)
 427 ;;; Evaluate the expressions BODY ... .  If any errors occur, return #t;
 428 ;;; otherwise, return #f.
 429 ;;;
 430 ;;; KEY indicates the sort of errors to look for; it can be a symbol,
 431 ;;; indicating that only errors with that name should be caught, or
 432 ;;; #t, meaning that any kind of error should be caught.
 433 (defmacro signals-error? key-and-body
 434   `(signals-error?* ,(car key-and-body)
 435                     (lambda () ,@(cdr key-and-body))))
 436
 437 ;;; (signals-error?* KEY THUNK)
 438 ;;; Apply THUNK, catching errors.  If any errors occur, return #t;
 439 ;;; otherwise, return #f.
 440 ;;;
 441 ;;; KEY indicates the sort of errors to look for; it can be a symbol,
 442 ;;; indicating that only errors with that name should be caught, or
 443 ;;; #t, meaning that any kind of error should be caught.
 444 (define (signals-error?* key thunk)
 445   (catch key
 446          (lambda () (thunk) #f)
 447          (lambda args #t)))