test-suite/lib.scm

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