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