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