Commit | Line | Data |
---|---|---|
34e89877 MW |
1 | ;;; |
2 | ;;; This is a test suite written in the notation of | |
3 | ;;; SRFI-64, A Scheme API for test suites | |
4 | ;;; | |
5 | ||
6 | (test-begin "SRFI 64 - Meta-Test Suite") | |
7 | ||
8 | ;;; | |
9 | ;;; Ironically, in order to set up the meta-test environment, | |
10 | ;;; we have to invoke one of the most sophisticated features: | |
11 | ;;; custom test runners | |
12 | ;;; | |
13 | ||
14 | ;;; The `prop-runner' invokes `thunk' in the context of a new | |
15 | ;;; test runner, and returns the indicated properties of the | |
16 | ;;; last-executed test result. | |
17 | ||
18 | (define (prop-runner props thunk) | |
19 | (let ((r (test-runner-null)) | |
20 | (plist '())) | |
21 | ;; | |
22 | (test-runner-on-test-end! | |
23 | r | |
24 | (lambda (runner) | |
25 | (set! plist (test-result-alist runner)))) | |
26 | ;; | |
27 | (test-with-runner r (thunk)) | |
28 | ;; reorder the properties so they are in the order | |
29 | ;; given by `props'. Note that any property listed in `props' | |
30 | ;; that is not in the property alist will occur as #f | |
31 | (map (lambda (k) | |
32 | (assq k plist)) | |
33 | props))) | |
34 | ||
35 | ;;; `on-test-runner' creates a null test runner and then | |
36 | ;;; arranged for `visit' to be called with the runner | |
37 | ;;; whenever a test is run. The results of the calls to | |
38 | ;;; `visit' are returned in a list | |
39 | ||
40 | (define (on-test-runner thunk visit) | |
41 | (let ((r (test-runner-null)) | |
42 | (results '())) | |
43 | ;; | |
44 | (test-runner-on-test-end! | |
45 | r | |
46 | (lambda (runner) | |
47 | (set! results (cons (visit r) results)))) | |
48 | ;; | |
49 | (test-with-runner r (thunk)) | |
50 | (reverse results))) | |
51 | ||
52 | ;;; | |
53 | ;;; The `triv-runner' invokes `thunk' | |
54 | ;;; and returns a list of 6 lists, the first 5 of which | |
55 | ;;; are a list of the names of the tests that, respectively, | |
56 | ;;; PASS, FAIL, XFAIL, XPASS, and SKIP. | |
57 | ;;; The last item is a list of counts. | |
58 | ;;; | |
59 | ||
60 | (define (triv-runner thunk) | |
61 | (let ((r (test-runner-null)) | |
62 | (accum-pass '()) | |
63 | (accum-fail '()) | |
64 | (accum-xfail '()) | |
65 | (accum-xpass '()) | |
66 | (accum-skip '())) | |
67 | ;; | |
68 | (test-runner-on-bad-count! | |
69 | r | |
70 | (lambda (runner count expected-count) | |
71 | (error (string-append "bad count " (number->string count) | |
72 | " but expected " | |
73 | (number->string expected-count))))) | |
74 | (test-runner-on-bad-end-name! | |
75 | r | |
76 | (lambda (runner begin end) | |
77 | (error (string-append "bad end group name " end | |
78 | " but expected " begin)))) | |
79 | (test-runner-on-test-end! | |
80 | r | |
81 | (lambda (runner) | |
82 | (let ((n (test-runner-test-name runner))) | |
83 | (case (test-result-kind runner) | |
84 | ((pass) (set! accum-pass (cons n accum-pass))) | |
85 | ((fail) (set! accum-fail (cons n accum-fail))) | |
86 | ((xpass) (set! accum-xpass (cons n accum-xpass))) | |
87 | ((xfail) (set! accum-xfail (cons n accum-xfail))) | |
88 | ((skip) (set! accum-skip (cons n accum-skip))))))) | |
89 | ;; | |
90 | (test-with-runner r (thunk)) | |
91 | (list (reverse accum-pass) ; passed as expected | |
92 | (reverse accum-fail) ; failed, but was expected to pass | |
93 | (reverse accum-xfail) ; failed as expected | |
94 | (reverse accum-xpass) ; passed, but was expected to fail | |
95 | (reverse accum-skip) ; was not executed | |
96 | (list (test-runner-pass-count r) | |
97 | (test-runner-fail-count r) | |
98 | (test-runner-xfail-count r) | |
99 | (test-runner-xpass-count r) | |
100 | (test-runner-skip-count r))))) | |
101 | ||
102 | (define (path-revealing-runner thunk) | |
103 | (let ((r (test-runner-null)) | |
104 | (seq '())) | |
105 | ;; | |
106 | (test-runner-on-test-end! | |
107 | r | |
108 | (lambda (runner) | |
109 | (set! seq (cons (list (test-runner-group-path runner) | |
110 | (test-runner-test-name runner)) | |
111 | seq)))) | |
112 | (test-with-runner r (thunk)) | |
113 | (reverse seq))) | |
114 | ||
115 | ;;; | |
116 | ;;; Now we can start testing compliance with SRFI-64 | |
117 | ;;; | |
118 | ||
119 | (test-begin "1. Simple test-cases") | |
120 | ||
121 | (test-begin "1.1. test-assert") | |
122 | ||
123 | (define (t) | |
124 | (triv-runner | |
125 | (lambda () | |
126 | (test-assert "a" #t) | |
127 | (test-assert "b" #f)))) | |
128 | ||
129 | (test-equal | |
130 | "1.1.1. Very simple" | |
131 | '(("a") ("b") () () () (1 1 0 0 0)) | |
132 | (t)) | |
133 | ||
134 | (test-equal | |
135 | "1.1.2. A test with no name" | |
136 | '(("a") ("") () () () (1 1 0 0 0)) | |
137 | (triv-runner (lambda () (test-assert "a" #t) (test-assert #f)))) | |
138 | ||
139 | (test-equal | |
140 | "1.1.3. Tests can have the same name" | |
141 | '(("a" "a") () () () () (2 0 0 0 0)) | |
142 | (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t)))) | |
143 | ||
144 | (define (choke) | |
145 | (vector-ref '#(1 2) 3)) | |
146 | ||
147 | (test-equal | |
148 | "1.1.4. One way to FAIL is to throw an error" | |
149 | '(() ("a") () () () (0 1 0 0 0)) | |
150 | (triv-runner (lambda () (test-assert "a" (choke))))) | |
151 | ||
152 | (test-end);1.1 | |
153 | ||
154 | (test-begin "1.2. test-eqv") | |
155 | ||
156 | (define (mean x y) | |
157 | (/ (+ x y) 2.0)) | |
158 | ||
159 | (test-equal | |
160 | "1.2.1. Simple numerical equivalence" | |
161 | '(("c") ("a" "b") () () () (1 2 0 0 0)) | |
162 | (triv-runner | |
163 | (lambda () | |
164 | (test-eqv "a" (mean 3 5) 4) | |
165 | (test-eqv "b" (mean 3 5) 4.5) | |
166 | (test-eqv "c" (mean 3 5) 4.0)))) | |
167 | ||
168 | (test-end);1.2 | |
169 | ||
170 | (test-end "1. Simple test-cases") | |
171 | ||
172 | ;;; | |
173 | ;;; | |
174 | ;;; | |
175 | ||
176 | (test-begin "2. Tests for catching errors") | |
177 | ||
178 | (test-begin "2.1. test-error") | |
179 | ||
180 | (test-equal | |
181 | "2.1.1. Baseline test; PASS with no optional args" | |
182 | '(("") () () () () (1 0 0 0 0)) | |
183 | (triv-runner | |
184 | (lambda () | |
185 | ;; PASS | |
186 | (test-error (vector-ref '#(1 2) 9))))) | |
187 | ||
188 | (test-equal | |
189 | "2.1.2. Baseline test; FAIL with no optional args" | |
190 | '(() ("") () () () (0 1 0 0 0)) | |
191 | (triv-runner | |
192 | (lambda () | |
193 | ;; FAIL: the expr does not raise an error and `test-error' is | |
194 | ;; claiming that it will, so this test should FAIL | |
195 | (test-error (vector-ref '#(1 2) 0))))) | |
196 | ||
197 | (test-equal | |
198 | "2.1.3. PASS with a test name and error type" | |
199 | '(("a") () () () () (1 0 0 0 0)) | |
200 | (triv-runner | |
201 | (lambda () | |
202 | ;; PASS | |
203 | (test-error "a" #t (vector-ref '#(1 2) 9))))) | |
204 | ||
205 | (test-end "2.1. test-error") | |
206 | ||
207 | (test-end "2. Tests for catching errors") | |
208 | ||
209 | ;;; | |
210 | ;;; | |
211 | ;;; | |
212 | ||
213 | (test-begin "3. Test groups and paths") | |
214 | ||
215 | (test-equal | |
216 | "3.1. test-begin with unspecific test-end" | |
217 | '(("b") () () () () (1 0 0 0 0)) | |
218 | (triv-runner | |
219 | (lambda () | |
220 | (test-begin "a") | |
221 | (test-assert "b" #t) | |
222 | (test-end)))) | |
223 | ||
224 | (test-equal | |
225 | "3.2. test-begin with name-matching test-end" | |
226 | '(("b") () () () () (1 0 0 0 0)) | |
227 | (triv-runner | |
228 | (lambda () | |
229 | (test-begin "a") | |
230 | (test-assert "b" #t) | |
231 | (test-end "a")))) | |
232 | ||
233 | ;;; since the error raised by `test-end' on a mismatch is not a test | |
234 | ;;; error, we actually expect the triv-runner itself to fail | |
235 | ||
236 | (test-error | |
237 | "3.3. test-begin with mismatched test-end" | |
238 | #t | |
239 | (triv-runner | |
240 | (lambda () | |
241 | (test-begin "a") | |
242 | (test-assert "b" #t) | |
243 | (test-end "x")))) | |
244 | ||
245 | (test-equal | |
246 | "3.4. test-begin with name and count" | |
247 | '(("b" "c") () () () () (2 0 0 0 0)) | |
248 | (triv-runner | |
249 | (lambda () | |
250 | (test-begin "a" 2) | |
251 | (test-assert "b" #t) | |
252 | (test-assert "c" #t) | |
253 | (test-end "a")))) | |
254 | ||
255 | ;; similarly here, a mismatched count is a lexical error | |
256 | ;; and not a test failure... | |
257 | ||
258 | (test-error | |
259 | "3.5. test-begin with mismatched count" | |
260 | #t | |
261 | (triv-runner | |
262 | (lambda () | |
263 | (test-begin "a" 99) | |
264 | (test-assert "b" #t) | |
265 | (test-end "a")))) | |
266 | ||
267 | (test-equal | |
268 | "3.6. introspecting on the group path" | |
269 | '((() "w") | |
270 | (("a" "b") "x") | |
271 | (("a" "b") "y") | |
272 | (("a") "z")) | |
273 | ;; | |
274 | ;; `path-revealing-runner' is designed to return a list | |
275 | ;; of the tests executed, in order. Each entry is a list | |
276 | ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list | |
277 | ;; of test groups starting from the topmost | |
278 | ;; | |
279 | (path-revealing-runner | |
280 | (lambda () | |
281 | (test-assert "w" #t) | |
282 | (test-begin "a") | |
283 | (test-begin "b") | |
284 | (test-assert "x" #t) | |
285 | (test-assert "y" #t) | |
286 | (test-end) | |
287 | (test-assert "z" #t)))) | |
288 | ||
289 | ||
290 | (test-end "3. Test groups and paths") | |
291 | ||
292 | ;;; | |
293 | ;;; | |
294 | ;;; | |
295 | ||
296 | (test-begin "4. Handling set-up and cleanup") | |
297 | ||
298 | (test-equal "4.1. Normal exit path" | |
299 | '(in 1 2 out) | |
300 | (let ((ex '())) | |
301 | (define (do s) | |
302 | (set! ex (cons s ex))) | |
303 | ;; | |
304 | (triv-runner | |
305 | (lambda () | |
306 | (test-group-with-cleanup | |
307 | "foo" | |
308 | (do 'in) | |
309 | (do 1) | |
310 | (do 2) | |
311 | (do 'out)))) | |
312 | (reverse ex))) | |
313 | ||
314 | (test-equal "4.2. Exception exit path" | |
315 | '(in 1 out) | |
316 | (let ((ex '())) | |
317 | (define (do s) | |
318 | (set! ex (cons s ex))) | |
319 | ;; | |
320 | ;; the outer runner is to run the `test-error' in, to | |
321 | ;; catch the exception raised in the inner runner, | |
322 | ;; since we don't want to depend on any other | |
323 | ;; exception-catching support | |
324 | ;; | |
325 | (triv-runner | |
326 | (lambda () | |
327 | (test-error | |
328 | (triv-runner | |
329 | (lambda () | |
330 | (test-group-with-cleanup | |
331 | "foo" | |
332 | (do 'in) (test-assert #t) | |
333 | (do 1) (test-assert #t) | |
334 | (choke) (test-assert #t) | |
335 | (do 2) (test-assert #t) | |
336 | (do 'out))))))) | |
337 | (reverse ex))) | |
338 | ||
339 | (test-end "4. Handling set-up and cleanup") | |
340 | ||
341 | ;;; | |
342 | ;;; | |
343 | ;;; | |
344 | ||
345 | (test-begin "5. Test specifiers") | |
346 | ||
347 | (test-begin "5.1. test-match-named") | |
348 | ||
349 | (test-equal "5.1.1. match test names" | |
350 | '(("y") () () () ("x") (1 0 0 0 1)) | |
351 | (triv-runner | |
352 | (lambda () | |
353 | (test-skip (test-match-name "x")) | |
354 | (test-assert "x" #t) | |
355 | (test-assert "y" #t)))) | |
356 | ||
357 | (test-equal "5.1.2. but not group names" | |
358 | '(("z") () () () () (1 0 0 0 0)) | |
359 | (triv-runner | |
360 | (lambda () | |
361 | (test-skip (test-match-name "x")) | |
362 | (test-begin "x") | |
363 | (test-assert "z" #t) | |
364 | (test-end)))) | |
365 | ||
366 | (test-end) | |
367 | ||
368 | (test-begin "5.2. test-match-nth") | |
369 | ;; See also: [6.4. Short-circuit evaluation] | |
370 | ||
371 | (test-equal "5.2.1. skip the nth one after" | |
372 | '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) | |
373 | (triv-runner | |
374 | (lambda () | |
375 | (test-assert "v" #t) | |
376 | (test-skip (test-match-nth 2)) | |
377 | (test-assert "w" #t) ; 1 | |
378 | (test-assert "x" #t) ; 2 SKIP | |
379 | (test-assert "y" #t) ; 3 | |
380 | (test-assert "z" #t)))) ; 4 | |
381 | ||
382 | (test-equal "5.2.2. skip m, starting at n" | |
383 | '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) | |
384 | (triv-runner | |
385 | (lambda () | |
386 | (test-assert "v" #t) | |
387 | (test-skip (test-match-nth 2 2)) | |
388 | (test-assert "w" #t) ; 1 | |
389 | (test-assert "x" #t) ; 2 SKIP | |
390 | (test-assert "y" #t) ; 3 SKIP | |
391 | (test-assert "z" #t)))) ; 4 | |
392 | ||
393 | (test-end) | |
394 | ||
395 | (test-begin "5.3. test-match-any") | |
396 | (test-equal "5.3.1. basic disjunction" | |
397 | '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) | |
398 | (triv-runner | |
399 | (lambda () | |
400 | (test-assert "v" #t) | |
401 | (test-skip (test-match-any (test-match-nth 3) | |
402 | (test-match-name "x"))) | |
403 | (test-assert "w" #t) ; 1 | |
404 | (test-assert "x" #t) ; 2 SKIP(NAME) | |
405 | (test-assert "y" #t) ; 3 SKIP(COUNT) | |
406 | (test-assert "z" #t)))) ; 4 | |
407 | ||
408 | (test-equal "5.3.2. disjunction is commutative" | |
409 | '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) | |
410 | (triv-runner | |
411 | (lambda () | |
412 | (test-assert "v" #t) | |
413 | (test-skip (test-match-any (test-match-name "x") | |
414 | (test-match-nth 3))) | |
415 | (test-assert "w" #t) ; 1 | |
416 | (test-assert "x" #t) ; 2 SKIP(NAME) | |
417 | (test-assert "y" #t) ; 3 SKIP(COUNT) | |
418 | (test-assert "z" #t)))) ; 4 | |
419 | ||
420 | (test-end) | |
421 | ||
422 | (test-begin "5.4. test-match-all") | |
423 | (test-equal "5.4.1. basic conjunction" | |
424 | '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) | |
425 | (triv-runner | |
426 | (lambda () | |
427 | (test-assert "v" #t) | |
428 | (test-skip (test-match-all (test-match-nth 2 2) | |
429 | (test-match-name "x"))) | |
430 | (test-assert "w" #t) ; 1 | |
431 | (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) | |
432 | (test-assert "y" #t) ; 3 SKIP(COUNT) | |
433 | (test-assert "z" #t)))) ; 4 | |
434 | ||
435 | (test-equal "5.4.2. conjunction is commutative" | |
436 | '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) | |
437 | (triv-runner | |
438 | (lambda () | |
439 | (test-assert "v" #t) | |
440 | (test-skip (test-match-all (test-match-name "x") | |
441 | (test-match-nth 2 2))) | |
442 | (test-assert "w" #t) ; 1 | |
443 | (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) | |
444 | (test-assert "y" #t) ; 3 SKIP(COUNT) | |
445 | (test-assert "z" #t)))) ; 4 | |
446 | ||
447 | (test-end) | |
448 | ||
449 | (test-end "5. Test specifiers") | |
450 | ||
451 | ;;; | |
452 | ;;; | |
453 | ;;; | |
454 | ||
455 | (test-begin "6. Skipping selected tests") | |
456 | ||
457 | (test-equal | |
458 | "6.1. Skip by specifier - match-name" | |
459 | '(("x") () () () ("y") (1 0 0 0 1)) | |
460 | (triv-runner | |
461 | (lambda () | |
462 | (test-begin "a") | |
463 | (test-skip (test-match-name "y")) | |
464 | (test-assert "x" #t) ; PASS | |
465 | (test-assert "y" #f) ; SKIP | |
466 | (test-end)))) | |
467 | ||
468 | (test-equal | |
469 | "6.2. Shorthand specifiers" | |
470 | '(("x") () () () ("y") (1 0 0 0 1)) | |
471 | (triv-runner | |
472 | (lambda () | |
473 | (test-begin "a") | |
474 | (test-skip "y") | |
475 | (test-assert "x" #t) ; PASS | |
476 | (test-assert "y" #f) ; SKIP | |
477 | (test-end)))) | |
478 | ||
479 | (test-begin "6.3. Specifier Stack") | |
480 | ||
481 | (test-equal | |
482 | "6.3.1. Clearing the Specifier Stack" | |
483 | '(("x" "x") ("y") () () ("y") (2 1 0 0 1)) | |
484 | (triv-runner | |
485 | (lambda () | |
486 | (test-begin "a") | |
487 | (test-skip "y") | |
488 | (test-assert "x" #t) ; PASS | |
489 | (test-assert "y" #f) ; SKIP | |
490 | (test-end) | |
491 | (test-begin "b") | |
492 | (test-assert "x" #t) ; PASS | |
493 | (test-assert "y" #f) ; FAIL | |
494 | (test-end)))) | |
495 | ||
496 | (test-equal | |
497 | "6.3.2. Inheriting the Specifier Stack" | |
498 | '(("x" "x") () () () ("y" "y") (2 0 0 0 2)) | |
499 | (triv-runner | |
500 | (lambda () | |
501 | (test-skip "y") | |
502 | (test-begin "a") | |
503 | (test-assert "x" #t) ; PASS | |
504 | (test-assert "y" #f) ; SKIP | |
505 | (test-end) | |
506 | (test-begin "b") | |
507 | (test-assert "x" #t) ; PASS | |
508 | (test-assert "y" #f) ; SKIP | |
509 | (test-end)))) | |
510 | ||
511 | (test-end);6.3 | |
512 | ||
513 | (test-begin "6.4. Short-circuit evaluation") | |
514 | ||
515 | (test-equal | |
516 | "6.4.1. In test-match-all" | |
517 | '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1)) | |
518 | (triv-runner | |
519 | (lambda () | |
520 | (test-begin "a") | |
521 | (test-skip (test-match-all "y" (test-match-nth 2))) | |
522 | ;; let's label the substructure forms so we can | |
523 | ;; see which one `test-match-nth' is going to skip | |
524 | ;; ; # "y" 2 result | |
525 | (test-assert "x" #t) ; 1 - #f #f PASS | |
526 | (test-assert "y" #f) ; 2 - #t #t SKIP | |
527 | (test-assert "y" #f) ; 3 - #t #f FAIL | |
528 | (test-assert "x" #f) ; 4 - #f #f FAIL | |
529 | (test-assert "z" #f) ; 5 - #f #f FAIL | |
530 | (test-end)))) | |
531 | ||
532 | (test-equal | |
533 | "6.4.2. In separate skip-list entries" | |
534 | '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2)) | |
535 | (triv-runner | |
536 | (lambda () | |
537 | (test-begin "a") | |
538 | (test-skip "y") | |
539 | (test-skip (test-match-nth 2)) | |
540 | ;; let's label the substructure forms so we can | |
541 | ;; see which one `test-match-nth' is going to skip | |
542 | ;; ; # "y" 2 result | |
543 | (test-assert "x" #t) ; 1 - #f #f PASS | |
544 | (test-assert "y" #f) ; 2 - #t #t SKIP | |
545 | (test-assert "y" #f) ; 3 - #t #f SKIP | |
546 | (test-assert "x" #f) ; 4 - #f #f FAIL | |
547 | (test-assert "z" #f) ; 5 - #f #f FAIL | |
548 | (test-end)))) | |
549 | ||
550 | (test-begin "6.4.3. Skipping test suites") | |
551 | ||
552 | (test-equal | |
553 | "6.4.3.1. Introduced using 'test-begin'" | |
554 | '(("x") () () () () (1 0 0 0 0)) | |
555 | (triv-runner | |
556 | (lambda () | |
557 | (test-begin "a") | |
558 | (test-skip "b") | |
559 | (test-begin "b") ; not skipped | |
560 | (test-assert "x" #t) | |
561 | (test-end "b") | |
562 | (test-end "a")))) | |
563 | ||
564 | (test-expect-fail 1) ;; ??? | |
565 | (test-equal | |
566 | "6.4.3.2. Introduced using 'test-group'" | |
567 | '(() () () () () (0 0 0 0 1)) | |
568 | (triv-runner | |
569 | (lambda () | |
570 | (test-begin "a") | |
571 | (test-skip "b") | |
572 | (test-group | |
573 | "b" ; skipped | |
574 | (test-assert "x" #t)) | |
575 | (test-end "a")))) | |
576 | ||
577 | (test-equal | |
578 | "6.4.3.3. Non-skipped 'test-group'" | |
579 | '(("x") () () () () (1 0 0 0 0)) | |
580 | (triv-runner | |
581 | (lambda () | |
582 | (test-begin "a") | |
583 | (test-skip "c") | |
584 | (test-group "b" (test-assert "x" #t)) | |
585 | (test-end "a")))) | |
586 | ||
587 | (test-end) ; 6.4.3 | |
588 | ||
589 | (test-end);6.4 | |
590 | ||
591 | (test-end "6. Skipping selected tests") | |
592 | ||
593 | ;;; | |
594 | ;;; | |
595 | ;;; | |
596 | ||
597 | (test-begin "7. Expected failures") | |
598 | ||
599 | (test-equal "7.1. Simple example" | |
600 | '(() ("x") ("z") () () (0 1 1 0 0)) | |
601 | (triv-runner | |
602 | (lambda () | |
603 | (test-assert "x" #f) | |
604 | (test-expect-fail "z") | |
605 | (test-assert "z" #f)))) | |
606 | ||
607 | (test-equal "7.2. Expected exception" | |
608 | '(() ("x") ("z") () () (0 1 1 0 0)) | |
609 | (triv-runner | |
610 | (lambda () | |
611 | (test-assert "x" #f) | |
612 | (test-expect-fail "z") | |
613 | (test-assert "z" (choke))))) | |
614 | ||
615 | (test-equal "7.3. Unexpectedly PASS" | |
616 | '(() () ("y") ("x") () (0 0 1 1 0)) | |
617 | (triv-runner | |
618 | (lambda () | |
619 | (test-expect-fail "x") | |
620 | (test-expect-fail "y") | |
621 | (test-assert "x" #t) | |
622 | (test-assert "y" #f)))) | |
623 | ||
624 | ||
625 | ||
626 | (test-end "7. Expected failures") | |
627 | ||
628 | ;;; | |
629 | ;;; | |
630 | ;;; | |
631 | ||
632 | (test-begin "8. Test-runner") | |
633 | ||
634 | ;;; | |
635 | ;;; Because we want this test suite to be accurate even | |
636 | ;;; when the underlying implementation chooses to use, e.g., | |
637 | ;;; a global variable to implement what could be thread variables | |
638 | ;;; or SRFI-39 parameter objects, we really need to save and restore | |
639 | ;;; their state ourselves | |
640 | ;;; | |
641 | (define (with-factory-saved thunk) | |
642 | (let* ((saved (test-runner-factory)) | |
643 | (result (thunk))) | |
644 | (test-runner-factory saved) | |
645 | result)) | |
646 | ||
647 | (test-begin "8.1. test-runner-current") | |
648 | (test-assert "8.1.1. automatically restored" | |
649 | (let ((a 0) | |
650 | (b 1) | |
651 | (c 2)) | |
652 | ; | |
653 | (triv-runner | |
654 | (lambda () | |
655 | (set! a (test-runner-current)) | |
656 | ;; | |
657 | (triv-runner | |
658 | (lambda () | |
659 | (set! b (test-runner-current)))) | |
660 | ;; | |
661 | (set! c (test-runner-current)))) | |
662 | ;; | |
663 | (and (eq? a c) | |
664 | (not (eq? a b))))) | |
665 | ||
666 | (test-end) | |
667 | ||
668 | (test-begin "8.2. test-runner-simple") | |
669 | (test-assert "8.2.1. default on-test hook" | |
670 | (eq? (test-runner-on-test-end (test-runner-simple)) | |
671 | test-on-test-end-simple)) | |
672 | (test-assert "8.2.2. default on-final hook" | |
673 | (eq? (test-runner-on-final (test-runner-simple)) | |
674 | test-on-final-simple)) | |
675 | (test-end) | |
676 | ||
677 | (test-begin "8.3. test-runner-factory") | |
678 | ||
679 | (test-assert "8.3.1. default factory" | |
680 | (eq? (test-runner-factory) test-runner-simple)) | |
681 | ||
682 | (test-assert "8.3.2. settable factory" | |
683 | (with-factory-saved | |
684 | (lambda () | |
685 | (test-runner-factory test-runner-null) | |
686 | ;; we have no way, without bringing in other SRFIs, | |
687 | ;; to make sure the following doesn't print anything, | |
688 | ;; but it shouldn't: | |
689 | (test-with-runner | |
690 | (test-runner-create) | |
691 | (lambda () | |
692 | (test-begin "a") | |
693 | (test-assert #t) ; pass | |
694 | (test-assert #f) ; fail | |
695 | (test-assert (vector-ref '#(3) 10)) ; fail with error | |
696 | (test-end "a"))) | |
697 | (eq? (test-runner-factory) test-runner-null)))) | |
698 | ||
699 | (test-end) | |
700 | ||
701 | ;;; This got tested about as well as it could in 8.3.2 | |
702 | ||
703 | (test-begin "8.4. test-runner-create") | |
704 | (test-end) | |
705 | ||
706 | ;;; This got tested about as well as it could in 8.3.2 | |
707 | ||
708 | (test-begin "8.5. test-runner-factory") | |
709 | (test-end) | |
710 | ||
711 | (test-begin "8.6. test-apply") | |
712 | (test-equal "8.6.1. Simple (form 1) test-apply" | |
713 | '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) | |
714 | (triv-runner | |
715 | (lambda () | |
716 | (test-begin "a") | |
717 | (test-assert "w" #t) | |
718 | (test-apply | |
719 | (test-match-name "p") | |
720 | (lambda () | |
721 | (test-begin "p") | |
722 | (test-assert "x" #t) | |
723 | (test-end) | |
724 | (test-begin "z") | |
725 | (test-assert "p" #t) ; only this one should execute in here | |
726 | (test-end))) | |
727 | (test-assert "v" #t)))) | |
728 | ||
729 | (test-equal "8.6.2. Simple (form 2) test-apply" | |
730 | '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) | |
731 | (triv-runner | |
732 | (lambda () | |
733 | (test-begin "a") | |
734 | (test-assert "w" #t) | |
735 | (test-apply | |
736 | (test-runner-current) | |
737 | (test-match-name "p") | |
738 | (lambda () | |
739 | (test-begin "p") | |
740 | (test-assert "x" #t) | |
741 | (test-end) | |
742 | (test-begin "z") | |
743 | (test-assert "p" #t) ; only this one should execute in here | |
744 | (test-end))) | |
745 | (test-assert "v" #t)))) | |
746 | ||
747 | (test-expect-fail 1) ;; depends on all test-match-nth being called. | |
748 | (test-equal "8.6.3. test-apply with skips" | |
749 | '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3)) | |
750 | (triv-runner | |
751 | (lambda () | |
752 | (test-begin "a") | |
753 | (test-assert "w" #t) | |
754 | (test-skip (test-match-nth 2)) | |
755 | (test-skip (test-match-nth 4)) | |
756 | (test-apply | |
757 | (test-runner-current) | |
758 | (test-match-name "p") | |
759 | (test-match-name "q") | |
760 | (lambda () | |
761 | ; only execute if SKIP=no and APPLY=yes | |
762 | (test-assert "x" #t) ; # 1 SKIP=no APPLY=no | |
763 | (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes | |
764 | (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes | |
765 | (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no | |
766 | 0)) | |
767 | (test-assert "v" #t)))) | |
768 | ||
769 | ;;; Unfortunately, since there is no way to UNBIND the current test runner, | |
770 | ;;; there is no way to test the behavior of `test-apply' in the absence | |
771 | ;;; of a current runner within our little meta-test framework. | |
772 | ;;; | |
773 | ;;; To test the behavior manually, you should be able to invoke: | |
774 | ;;; | |
775 | ;;; (test-apply "a" (lambda () (test-assert "a" #t))) | |
776 | ;;; | |
777 | ;;; from the top level (with SRFI 64 available) and it should create a | |
778 | ;;; new, default (simple) test runner. | |
779 | ||
780 | (test-end) | |
781 | ||
782 | ;;; This entire suite depends heavily on 'test-with-runner'. If it didn't | |
783 | ;;; work, this suite would probably go down in flames | |
784 | (test-begin "8.7. test-with-runner") | |
785 | (test-end) | |
786 | ||
787 | ;;; Again, this suite depends heavily on many of the test-runner | |
788 | ;;; components. We'll just test those that aren't being exercised | |
789 | ;;; by the meta-test framework | |
790 | (test-begin "8.8. test-runner components") | |
791 | ||
792 | (define (auxtrack-runner thunk) | |
793 | (let ((r (test-runner-null))) | |
794 | (test-runner-aux-value! r '()) | |
795 | (test-runner-on-test-end! r (lambda (r) | |
796 | (test-runner-aux-value! | |
797 | r | |
798 | (cons (test-runner-test-name r) | |
799 | (test-runner-aux-value r))))) | |
800 | (test-with-runner r (thunk)) | |
801 | (reverse (test-runner-aux-value r)))) | |
802 | ||
803 | (test-equal "8.8.1. test-runner-aux-value" | |
804 | '("x" "" "y") | |
805 | (auxtrack-runner | |
806 | (lambda () | |
807 | (test-assert "x" #t) | |
808 | (test-begin "a") | |
809 | (test-assert #t) | |
810 | (test-end) | |
811 | (test-assert "y" #f)))) | |
812 | ||
813 | (test-end) ; 8.8 | |
814 | ||
815 | (test-end "8. Test-runner") | |
816 | ||
817 | (test-begin "9. Test Result Properties") | |
818 | ||
819 | (test-begin "9.1. test-result-alist") | |
820 | ||
821 | (define (symbol-alist? l) | |
822 | (if (null? l) | |
823 | #t | |
824 | (and (pair? l) | |
825 | (pair? (car l)) | |
826 | (symbol? (caar l)) | |
827 | (symbol-alist? (cdr l))))) | |
828 | ||
829 | ;;; check the various syntactic forms | |
830 | ||
831 | (test-assert (symbol-alist? | |
832 | (car (on-test-runner | |
833 | (lambda () | |
834 | (test-assert #t)) | |
835 | (lambda (r) | |
836 | (test-result-alist r)))))) | |
837 | ||
838 | (test-assert (symbol-alist? | |
839 | (car (on-test-runner | |
840 | (lambda () | |
841 | (test-assert #t)) | |
842 | (lambda (r) | |
843 | (test-result-alist r)))))) | |
844 | ||
845 | ;;; check to make sure the required properties are returned | |
846 | ||
847 | (test-equal '((result-kind . pass)) | |
848 | (prop-runner | |
849 | '(result-kind) | |
850 | (lambda () | |
851 | (test-assert #t))) | |
852 | ) | |
853 | ||
854 | (test-equal | |
855 | '((result-kind . fail) | |
856 | (expected-value . 2) | |
857 | (actual-value . 3)) | |
858 | (prop-runner | |
859 | '(result-kind expected-value actual-value) | |
860 | (lambda () | |
861 | (test-equal 2 (+ 1 2))))) | |
862 | ||
863 | (test-end "9.1. test-result-alist") | |
864 | ||
865 | (test-begin "9.2. test-result-ref") | |
866 | ||
867 | (test-equal '(pass) | |
868 | (on-test-runner | |
869 | (lambda () | |
870 | (test-assert #t)) | |
871 | (lambda (r) | |
872 | (test-result-ref r 'result-kind)))) | |
873 | ||
874 | (test-equal '(pass) | |
875 | (on-test-runner | |
876 | (lambda () | |
877 | (test-assert #t)) | |
878 | (lambda (r) | |
879 | (test-result-ref r 'result-kind)))) | |
880 | ||
881 | (test-equal '(fail pass) | |
882 | (on-test-runner | |
883 | (lambda () | |
884 | (test-assert (= 1 2)) | |
885 | (test-assert (= 1 1))) | |
886 | (lambda (r) | |
887 | (test-result-ref r 'result-kind)))) | |
888 | ||
889 | (test-end "9.2. test-result-ref") | |
890 | ||
891 | (test-begin "9.3. test-result-set!") | |
892 | ||
893 | (test-equal '(100 100) | |
894 | (on-test-runner | |
895 | (lambda () | |
896 | (test-assert (= 1 2)) | |
897 | (test-assert (= 1 1))) | |
898 | (lambda (r) | |
899 | (test-result-set! r 'foo 100) | |
900 | (test-result-ref r 'foo)))) | |
901 | ||
902 | (test-end "9.3. test-result-set!") | |
903 | ||
904 | (test-end "9. Test Result Properties") | |
905 | ||
906 | ;;; | |
907 | ;;; | |
908 | ;;; | |
909 | ||
910 | #| Time to stop having fun... | |
911 | ||
912 | (test-begin "9. For fun, some meta-test errors") | |
913 | ||
914 | (test-equal | |
915 | "9.1. Really PASSes, but test like it should FAIL" | |
916 | '(() ("b") () () ()) | |
917 | (triv-runner | |
918 | (lambda () | |
919 | (test-assert "b" #t)))) | |
920 | ||
921 | (test-expect-fail "9.2. Expect to FAIL and do so") | |
922 | (test-expect-fail "9.3. Expect to FAIL but PASS") | |
923 | (test-skip "9.4. SKIP this one") | |
924 | ||
925 | (test-assert "9.2. Expect to FAIL and do so" #f) | |
926 | (test-assert "9.3. Expect to FAIL but PASS" #t) | |
927 | (test-assert "9.4. SKIP this one" #t) | |
928 | ||
929 | (test-end) | |
930 | |# | |
931 | ||
932 | (test-end "SRFI 64 - Meta-Test Suite") | |
933 | ||
934 | ;;; |