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