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