test-suite/lib.scm

   1 ;;;; test-suite/lib.scm --- generic support for testing
   2 ;;;;    Copyright (C) 1999 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 (test-suite paths))
  21
  22 (export
  23
  24  ;; Reporting passes and failures.
  25  pass fail pass-if
  26
  27  ;; Indicating tests that are expected to fail.
  28  expect-failure expect-failure-if expect-failure-if*
  29
  30  ;; Marking independent groups of tests.
  31  catch-test-errors catch-test-errors*
  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  ;; Finding test input files.
  45  data-file)
  46
  47
  48 ;;;; If you're using Emacs's Scheme mode:
  49 ;;;;   (put 'expect-failure 'scheme-indent-function 0)
  50 ;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
  51
  52 \f
  53 ;;;; TEST NAMES
  54 ;;;;
  55 ;;;; Every test in the test suite has a unique name, to help
  56 ;;;; developers find tests that are failing (or unexpectedly passing),
  57 ;;;; and to help gather statistics.
  58 ;;;;
  59 ;;;; A test name is a list of printable objects.  For example:
  60 ;;;; ("ports.scm" "file" "read and write back list of strings")
  61 ;;;; ("ports.scm" "pipe" "read")
  62 ;;;;
  63 ;;;; Test names may contain arbitrary objects, but they always have
  64 ;;;; the following properties:
  65 ;;;; - Test names can be compared with EQUAL?.
  66 ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
  67 ;;;;   and READ procedures; doing so preserves their identity.
  68 ;;;;
  69 ;;;; The functions for reporting results (PASS, FAIL, PASS-IF, ...)
  70 ;;;; take the name of the passing/failing test as an argument.
  71 ;;;; For example:
  72 ;;;;
  73 ;;;;    (if (= 4 (+ 2 2))
  74 ;;;;      (pass "simple addition"))
  75 ;;;;
  76 ;;;; In that case, the test name is the list ("simple addition").
  77 ;;;;
  78 ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
  79 ;;;; a prefix for the names of all tests whose results are reported
  80 ;;;; within their dynamic scope.  For example:
  81 ;;;;
  82 ;;;; (begin
  83 ;;;;   (with-test-prefix "basic arithmetic"
  84 ;;;;     (pass-if "addition" (= (+ 2 2) 4))
  85 ;;;;     (pass-if "division" (= (- 4 2) 2)))
  86 ;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
  87 ;;;;
  88 ;;;; In that example, the three test names are:
  89 ;;;;   ("basic arithmetic" "addition"),
  90 ;;;;   ("basic arithmetic" "division"), and
  91 ;;;;   ("multiplication").
  92 ;;;;
  93 ;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
  94 ;;;; a new element to the current prefix:
  95 ;;;;
  96 ;;;; (with-test-prefix "arithmetic"
  97 ;;;;   (with-test-prefix "addition"
  98 ;;;;     (pass-if "integer" (= (+ 2 2) 4))
  99 ;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
 100 ;;;;   (with-test-prefix "subtraction"
 101 ;;;;     (pass-if "integer" (= (- 2 2) 0))
 102 ;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
 103 ;;;;
 104 ;;;; The four test names here are:
 105 ;;;;   ("arithmetic" "addition" "integer")
 106 ;;;;   ("arithmetic" "addition" "complex")
 107 ;;;;   ("arithmetic" "subtraction" "integer")
 108 ;;;;   ("arithmetic" "subtraction" "complex")
 109 ;;;;
 110 ;;;; To print a name for a human reader, we DISPLAY its elements,
 111 ;;;; separated by ": ".  So, the last set of test names would be
 112 ;;;; reported as:
 113 ;;;;
 114 ;;;;   arithmetic: addition: integer
 115 ;;;;   arithmetic: addition: complex
 116 ;;;;   arithmetic: subtraction: integer
 117 ;;;;   arithmetic: subtraction: complex
 118 ;;;;
 119 ;;;; The Guile benchmarks use with-test-prefix to include the name of
 120 ;;;; the source file containing the test in the test name, to help
 121 ;;;; developers to find failing tests, and to provide each file with its
 122 ;;;; own namespace.
 123
 124 \f
 125 ;;;; REPORTERS
 126
 127 ;;;; A reporter is a function which we apply to each test outcome.
 128 ;;;; Reporters can log results, print interesting results to the
 129 ;;;; standard output, collect statistics, etc.
 130 ;;;;
 131 ;;;; A reporter function takes one argument, RESULT; its return value
 132 ;;;; is ignored.  RESULT has one of the following forms:
 133 ;;;;
 134 ;;;; (pass TEST)    - The test named TEST passed.
 135 ;;;; (fail TEST)    - The test named TEST failed.
 136 ;;;; (xpass TEST)   - The test named TEST passed unexpectedly.
 137 ;;;; (xfail TEST)   - The test named TEST failed, as expected.
 138 ;;;; (error PREFIX) - An error occurred, with TEST as the current
 139 ;;;;                  test name prefix.  Some tests were
 140 ;;;;                  probably not executed because of this.
 141 ;;;;
 142 ;;;; This library provides some standard reporters for logging results
 143 ;;;; to a file, reporting interesting results to the user, and
 144 ;;;; collecting totals.
 145 ;;;;
 146 ;;;; You can use the REGISTER-REPORTER function and friends to add
 147 ;;;; whatever reporting functions you like.  If you don't register any
 148 ;;;; reporters, the library uses FULL-REPORTER, which simply writes
 149 ;;;; all results to the standard output.
 150
 151 \f
 152 ;;;; with-test-prefix: naming groups of tests
 153 ;;;; See the discussion of TEST
 154
 155 ;;; A fluid containing the current test prefix, as a list.
 156 (define prefix-fluid (make-fluid))
 157 (fluid-set! prefix-fluid '())
 158
 159 ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
 160 ;;; The name prefix is only changed within the dynamic scope of the
 161 ;;; call to with-test-prefix*.  Return the value returned by THUNK.
 162 (define (with-test-prefix* prefix thunk)
 163   (with-fluids ((prefix-fluid
 164                  (append (fluid-ref prefix-fluid) (list prefix))))
 165     (thunk)))
 166
 167 ;;; (with-test-prefix PREFIX BODY ...)
 168 ;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
 169 ;;; The name prefix is only changed within the dynamic scope of the
 170 ;;; with-test-prefix expression.  Return the value returned by the last
 171 ;;; BODY expression.
 172 (defmacro with-test-prefix (prefix . body)
 173   `(with-test-prefix* ,prefix (lambda () ,@body)))
 174
 175 (define (current-test-prefix)
 176   (fluid-ref prefix-fluid))
 177
 178 \f
 179 ;;;; register-reporter, etc. --- the global reporter list
 180
 181 ;;; The global list of reporters.
 182 (define reporters '())
 183
 184 ;;; The default reporter, to be used only if no others exist.
 185 (define default-reporter #f)
 186
 187 ;;; Add the procedure REPORTER to the current set of reporter functions.
 188 ;;; Signal an error if that reporter procedure object is already registered.
 189 (define (register-reporter reporter)
 190   (if (memq reporter reporters)
 191       (error "register-reporter: reporter already registered: " reporter))
 192   (set! reporters (cons reporter reporters)))
 193
 194 ;;; Remove the procedure REPORTER from the current set of reporter
 195 ;;; functions.  Signal an error if REPORTER is not currently registered.
 196 (define (unregister-reporter reporter)
 197   (if (memq reporter reporters)
 198       (set! reporters (delq! reporter reporters))
 199       (error "unregister-reporter: reporter not registered: " reporter)))
 200
 201 ;;; Return true iff REPORTER is in the current set of reporter functions.
 202 (define (reporter-registered? reporter)
 203   (if (memq reporter reporters) #t #f))
 204
 205
 206 ;;; Send RESULT to all currently registered reporter functions.
 207 (define (report result)
 208   (if (pair? reporters)
 209       (for-each (lambda (reporter) (reporter result))
 210                 reporters)
 211       (default-reporter result)))
 212
 213 \f
 214 ;;;; Some useful reporter functions.
 215
 216 ;;; Return a list of the form (COUNTER RESULTS), where:
 217 ;;; - COUNTER is a reporter procedure, and
 218 ;;; - RESULTS is a procedure taking no arguments which returns the
 219 ;;;   results seen so far by COUNTER.  The return value is an alist
 220 ;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
 221 (define (make-count-reporter)
 222   (let ((counts (map (lambda (outcome) (cons outcome 0))
 223                      '(pass fail xpass xfail error))))
 224     (list
 225      (lambda (result)
 226        (let ((pair (assq (car result) counts)))
 227          (if pair (set-cdr! pair (+ 1 (cdr pair)))
 228              (error "count-reporter: unexpected test result: " result))))
 229      (lambda ()
 230        (append counts '())))))
 231
 232 ;;; Print a count reporter's results nicely.  Pass this function the value
 233 ;;; returned by a count reporter's RESULTS procedure.
 234 (define print-counts
 235   (let ((tags '(pass fail xpass xfail error))
 236         (labels
 237          '("passes:               "
 238            "failures:             "
 239            "unexpected passes:    "
 240            "expected failures:    "
 241            "errors:               ")))
 242     (lambda (results . port?)
 243       (let ((port (if (pair? port?)
 244                       (car port?)
 245                       (current-output-port))))
 246         (newline port)
 247         (display-line-port port "Totals for this test run:")
 248         (for-each
 249          (lambda (tag label)
 250            (let ((result (assq tag results)))
 251              (if result
 252                  (display-line-port port label (cdr result))
 253                  (display-line-port port
 254                                     "Test suite bug: "
 255                                     "no total available for `" tag "'"))))
 256          tags labels)
 257         (newline port)))))
 258
 259 ;;; Handy functions.  Should be in a library somewhere.
 260 (define (display-line . objs)
 261   (for-each display objs)
 262   (newline))
 263 (define (display-line-port port . objs)
 264   (for-each (lambda (obj) (display obj port))
 265             objs)
 266   (newline port))
 267
 268 ;;; Turn a test name into a nice human-readable string.
 269 (define (format-test-name name)
 270   (call-with-output-string
 271    (lambda (port)
 272      (let loop ((name name))
 273        (if (pair? name)
 274            (begin
 275              (display (car name) port)
 276              (if (pair? (cdr name))
 277                  (display ": " port))
 278              (loop (cdr name))))))))
 279
 280 ;;; Return a reporter procedure which prints all results to the file
 281 ;;; FILE, in human-readable form.  FILE may be a filename, or a port.
 282 (define (make-log-reporter file)
 283   (let ((port (if (output-port? file) file
 284                   (open-output-file file))))
 285     (lambda (result)
 286       (display (car result) port)
 287       (display ": " port)
 288       (display (format-test-name (cadr result)) port)
 289       (newline port)
 290       (force-output port))))
 291
 292 ;;; A reporter that reports all results to the user.
 293 (define (full-reporter result)
 294   (let ((label (case (car result)
 295                  ((pass) "pass")
 296                  ((fail) "FAIL")
 297                  ((xpass) "XPASS")
 298                  ((xfail) "xfail")
 299                  ((error) "ERROR")
 300                  (else #f))))
 301     (if label
 302         (display-line label ": " (format-test-name (cadr result)))
 303         (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
 304                result))))
 305
 306 ;;; A reporter procedure which shows interesting results (failures,
 307 ;;; unexpected passes) to the user.
 308 (define (user-reporter result)
 309   (case (car result)
 310     ((fail xpass) (full-reporter result))))
 311
 312 (set! default-reporter full-reporter)
 313
 314 \f
 315 ;;;; Marking independent groups of tests.
 316
 317 ;;; When test code encounters an error (like "file not found" or "()
 318 ;;; is not a pair"), that may mean that that particular test can't
 319 ;;; continue, or that some nearby tests shouldn't be run, but it
 320 ;;; doesn't mean the whole test suite must be aborted.
 321 ;;;
 322 ;;; Wrap each group of interdependent tests in a CATCH-TEST-ERRORS
 323 ;;; form, so that if an error occurs, that group will be aborted, but
 324 ;;; control will continue after the catch-test-errors form.
 325
 326 ;;; Evaluate thunk, catching errors.  If THUNK returns without
 327 ;;; signalling any errors, return a list containing its value.
 328 ;;; Otherwise, return #f.
 329 (define (catch-test-errors* thunk)
 330
 331   (letrec ((handler
 332             (lambda (key . args)
 333               (display-line "ERROR in test "
 334                             (format-test-name (current-test-prefix))
 335                             ":")
 336               (apply display-error
 337                      (make-stack #t handler)
 338                      (current-error-port)
 339                      args)
 340               (throw 'catch-test-errors))))
 341
 342     ;; I don't know if we should really catch everything here.  If you
 343     ;; find a case where an error is signalled which really should abort
 344     ;; the whole test case, feel free to adjust this appropriately.
 345     (catch 'catch-test-errors
 346            (lambda ()
 347              (lazy-catch #t
 348                          (lambda () (list (thunk)))
 349                          handler))
 350            (lambda args
 351              (report (list 'error (current-test-prefix)))
 352              #f))))
 353
 354 ;;; (catch-test-errors BODY ...)
 355 ;;; Evaluate the expressions BODY ...  If a BODY expression signals an
 356 ;;; error, record that in the test results, and return #f.  Otherwise,
 357 ;;; return a list containing the value of the last BODY expression.
 358 (defmacro catch-test-errors body
 359   `(catch-test-errors* (lambda () ,@body)))
 360
 361 \f
 362 ;;;; Indicating tests that are expected to fail.
 363
 364 ;;; Fluid indicating whether we're currently expecting tests to fail.
 365 (define expected-failure-fluid (make-fluid))
 366
 367 ;;; Hmm.  The documentation treats EXPECT-FAILURE-IF as the primitive,
 368 ;;; but in the implementation, EXPECT-FAILURE-IF* is the primitive.
 369
 370 ;;; (expect-failure-if TEST BODY ...)
 371 ;;; Evaluate the expression TEST, then evaluate BODY ...
 372 ;;; If TEST evaluates to a true value, expect all tests whose results
 373 ;;; are reported by the BODY expressions to fail.
 374 ;;; Return the value of the last BODY form.
 375 (defmacro expect-failure-if (test . body)
 376   `(expect-failure-if* ,test (lambda () ,@body)))
 377
 378 ;;; Call THUNK; if SHOULD-FAIL is true, expect any tests whose results
 379 ;;; are reported by THUNK to fail.  Return the value returned by THUNK.
 380 (define (expect-failure-if* should-fail thunk)
 381   (with-fluids ((expected-failure-fluid (not (not should-fail))))
 382     (thunk)))
 383
 384 ;;; (expect-failure BODY ...)
 385 ;;; Evaluate the expressions BODY ..., expecting all tests whose results
 386 ;;; they report to fail.
 387 (defmacro expect-failure body
 388   `(expect-failure-if #t ,@body))
 389
 390 (define (pessimist?)
 391   (fluid-ref expected-failure-fluid))
 392
 393 \f
 394 ;;;; Reporting passes and failures.
 395
 396 (define (full-name name)
 397   (append (current-test-prefix) (list name)))
 398
 399 (define (pass name)
 400   (report (list (if (pessimist?) 'xpass 'pass)
 401                 (full-name name))))
 402
 403 (define (fail name)
 404   (report (list (if (pessimist?) 'xfail 'fail)
 405                 (full-name name))))
 406
 407 (define (pass-if name condition)
 408   ((if condition pass fail) name))
 409
 410 \f
 411 ;;;; Helping test cases find their files
 412
 413 ;;; Returns FILENAME, relative to the directory the test suite data
 414 ;;; files were installed in, and makes sure the file exists.
 415 (define (data-file filename)
 416   (let ((f (in-vicinity datadir filename)))
 417     (or (file-exists? f)
 418         (error "Test suite data file does not exist: " f))
 419     f))