2 ;;; This is a test suite written in the notation of
3 ;;; SRFI-64, A Scheme API for test suites
6 (test-begin "SRFI 64 - Meta-Test Suite")
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
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.
18 (define (prop-runner props thunk)
19 (let ((r (test-runner-null))
22 (test-runner-on-test-end!
25 (set! plist (test-result-alist runner))))
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
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
40 (define (on-test-runner thunk visit)
41 (let ((r (test-runner-null))
44 (test-runner-on-test-end!
47 (set! results (cons (visit r) results))))
49 (test-with-runner r (thunk))
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.
60 (define (triv-runner thunk)
61 (let ((r (test-runner-null))
68 (test-runner-on-bad-count!
70 (lambda (runner count expected-count)
71 (error (string-append "bad count " (number->string count)
73 (number->string expected-count)))))
74 (test-runner-on-bad-end-name!
76 (lambda (runner begin end)
77 (error (string-append "bad end group name " end
78 " but expected " begin))))
79 (test-runner-on-test-end!
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)))))))
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)))))
102 (define (path-revealing-runner thunk)
103 (let ((r (test-runner-null))
106 (test-runner-on-test-end!
109 (set! seq (cons (list (test-runner-group-path runner)
110 (test-runner-test-name runner))
112 (test-with-runner r (thunk))
116 ;;; Now we can start testing compliance with SRFI-64
119 (test-begin "1. Simple test-cases")
121 (test-begin "1.1. test-assert")
127 (test-assert "b" #f))))
131 '(("a") ("b") () () () (1 1 0 0 0))
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))))
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))))
145 (vector-ref '#(1 2) 3))
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)))))
154 (test-begin "1.2. test-eqv")
160 "1.2.1. Simple numerical equivalence"
161 '(("c") ("a" "b") () () () (1 2 0 0 0))
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))))
170 (test-end "1. Simple test-cases")
176 (test-begin "2. Tests for catching errors")
178 (test-begin "2.1. test-error")
181 "2.1.1. Baseline test; PASS with no optional args"
182 '(("") () () () () (1 0 0 0 0))
186 (test-error (vector-ref '#(1 2) 9)))))
189 "2.1.2. Baseline test; FAIL with no optional args"
190 '(() ("") () () () (0 1 0 0 0))
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)))))
198 "2.1.3. PASS with a test name and error type"
199 '(("a") () () () () (1 0 0 0 0))
203 (test-error "a" #t (vector-ref '#(1 2) 9)))))
205 (test-end "2.1. test-error")
207 (test-end "2. Tests for catching errors")
213 (test-begin "3. Test groups and paths")
216 "3.1. test-begin with unspecific test-end"
217 '(("b") () () () () (1 0 0 0 0))
225 "3.2. test-begin with name-matching test-end"
226 '(("b") () () () () (1 0 0 0 0))
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
237 "3.3. test-begin with mismatched test-end"
246 "3.4. test-begin with name and count"
247 '(("b" "c") () () () () (2 0 0 0 0))
255 ;; similarly here, a mismatched count is a lexical error
256 ;; and not a test failure...
259 "3.5. test-begin with mismatched count"
268 "3.6. introspecting on the group path"
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
279 (path-revealing-runner
287 (test-assert "z" #t))))
290 (test-end "3. Test groups and paths")
296 (test-begin "4. Handling set-up and cleanup")
298 (test-equal "4.1. Normal exit path"
302 (set! ex (cons s ex)))
306 (test-group-with-cleanup
314 (test-equal "4.2. Exception exit path"
318 (set! ex (cons s ex)))
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
330 (test-group-with-cleanup
332 (do 'in) (test-assert #t)
333 (do 1) (test-assert #t)
334 (choke) (test-assert #t)
335 (do 2) (test-assert #t)
339 (test-end "4. Handling set-up and cleanup")
345 (test-begin "5. Test specifiers")
347 (test-begin "5.1. test-match-named")
349 (test-equal "5.1.1. match test names"
350 '(("y") () () () ("x") (1 0 0 0 1))
353 (test-skip (test-match-name "x"))
355 (test-assert "y" #t))))
357 (test-equal "5.1.2. but not group names"
358 '(("z") () () () () (1 0 0 0 0))
361 (test-skip (test-match-name "x"))
368 (test-begin "5.2. test-match-nth")
369 ;; See also: [6.4. Short-circuit evaluation]
371 (test-equal "5.2.1. skip the nth one after"
372 '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
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
382 (test-equal "5.2.2. skip m, starting at n"
383 '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
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
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))
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
408 (test-equal "5.3.2. disjunction is commutative"
409 '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
413 (test-skip (test-match-any (test-match-name "x")
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
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))
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
435 (test-equal "5.4.2. conjunction is commutative"
436 '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
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
449 (test-end "5. Test specifiers")
455 (test-begin "6. Skipping selected tests")
458 "6.1. Skip by specifier - match-name"
459 '(("x") () () () ("y") (1 0 0 0 1))
463 (test-skip (test-match-name "y"))
464 (test-assert "x" #t) ; PASS
465 (test-assert "y" #f) ; SKIP
469 "6.2. Shorthand specifiers"
470 '(("x") () () () ("y") (1 0 0 0 1))
475 (test-assert "x" #t) ; PASS
476 (test-assert "y" #f) ; SKIP
479 (test-begin "6.3. Specifier Stack")
482 "6.3.1. Clearing the Specifier Stack"
483 '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
488 (test-assert "x" #t) ; PASS
489 (test-assert "y" #f) ; SKIP
492 (test-assert "x" #t) ; PASS
493 (test-assert "y" #f) ; FAIL
497 "6.3.2. Inheriting the Specifier Stack"
498 '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
503 (test-assert "x" #t) ; PASS
504 (test-assert "y" #f) ; SKIP
507 (test-assert "x" #t) ; PASS
508 (test-assert "y" #f) ; SKIP
513 (test-begin "6.4. Short-circuit evaluation")
516 "6.4.1. In test-match-all"
517 '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
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
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
533 "6.4.2. In separate skip-list entries"
534 '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
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
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
550 (test-begin "6.4.3. Skipping test suites")
553 "6.4.3.1. Introduced using 'test-begin'"
554 '(("x") () () () () (1 0 0 0 0))
559 (test-begin "b") ; not skipped
564 (test-expect-fail 1) ;; ???
566 "6.4.3.2. Introduced using 'test-group'"
567 '(() () () () () (0 0 0 0 1))
574 (test-assert "x" #t))
578 "6.4.3.3. Non-skipped 'test-group'"
579 '(("x") () () () () (1 0 0 0 0))
584 (test-group "b" (test-assert "x" #t))
591 (test-end "6. Skipping selected tests")
597 (test-begin "7. Expected failures")
599 (test-equal "7.1. Simple example"
600 '(() ("x") ("z") () () (0 1 1 0 0))
604 (test-expect-fail "z")
605 (test-assert "z" #f))))
607 (test-equal "7.2. Expected exception"
608 '(() ("x") ("z") () () (0 1 1 0 0))
612 (test-expect-fail "z")
613 (test-assert "z" (choke)))))
615 (test-equal "7.3. Unexpectedly PASS"
616 '(() () ("y") ("x") () (0 0 1 1 0))
619 (test-expect-fail "x")
620 (test-expect-fail "y")
622 (test-assert "y" #f))))
626 (test-end "7. Expected failures")
632 (test-begin "8. Test-runner")
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
641 (define (with-factory-saved thunk)
642 (let* ((saved (test-runner-factory))
644 (test-runner-factory saved)
647 (test-begin "8.1. test-runner-current")
648 (test-assert "8.1.1. automatically restored"
655 (set! a (test-runner-current))
659 (set! b (test-runner-current))))
661 (set! c (test-runner-current))))
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))
677 (test-begin "8.3. test-runner-factory")
679 (test-assert "8.3.1. default factory"
680 (eq? (test-runner-factory) test-runner-simple))
682 (test-assert "8.3.2. settable factory"
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,
693 (test-assert #t) ; pass
694 (test-assert #f) ; fail
695 (test-assert (vector-ref '#(3) 10)) ; fail with error
697 (eq? (test-runner-factory) test-runner-null))))
701 ;;; This got tested about as well as it could in 8.3.2
703 (test-begin "8.4. test-runner-create")
706 ;;; This got tested about as well as it could in 8.3.2
708 (test-begin "8.5. test-runner-factory")
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))
719 (test-match-name "p")
725 (test-assert "p" #t) ; only this one should execute in here
727 (test-assert "v" #t))))
729 (test-equal "8.6.2. Simple (form 2) test-apply"
730 '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
736 (test-runner-current)
737 (test-match-name "p")
743 (test-assert "p" #t) ; only this one should execute in here
745 (test-assert "v" #t))))
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))
754 (test-skip (test-match-nth 2))
755 (test-skip (test-match-nth 4))
757 (test-runner-current)
758 (test-match-name "p")
759 (test-match-name "q")
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
767 (test-assert "v" #t))))
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.
773 ;;; To test the behavior manually, you should be able to invoke:
775 ;;; (test-apply "a" (lambda () (test-assert "a" #t)))
777 ;;; from the top level (with SRFI 64 available) and it should create a
778 ;;; new, default (simple) test runner.
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")
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")
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!
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))))
803 (test-equal "8.8.1. test-runner-aux-value"
811 (test-assert "y" #f))))
815 (test-end "8. Test-runner")
817 (test-begin "9. Test Result Properties")
819 (test-begin "9.1. test-result-alist")
821 (define (symbol-alist? l)
827 (symbol-alist? (cdr l)))))
829 ;;; check the various syntactic forms
831 (test-assert (symbol-alist?
836 (test-result-alist r))))))
838 (test-assert (symbol-alist?
843 (test-result-alist r))))))
845 ;;; check to make sure the required properties are returned
847 (test-equal '((result-kind . pass))
855 '((result-kind . fail)
859 '(result-kind expected-value actual-value)
861 (test-equal 2 (+ 1 2)))))
863 (test-end "9.1. test-result-alist")
865 (test-begin "9.2. test-result-ref")
872 (test-result-ref r 'result-kind))))
879 (test-result-ref r 'result-kind))))
881 (test-equal '(fail pass)
884 (test-assert (= 1 2))
885 (test-assert (= 1 1)))
887 (test-result-ref r 'result-kind))))
889 (test-end "9.2. test-result-ref")
891 (test-begin "9.3. test-result-set!")
893 (test-equal '(100 100)
896 (test-assert (= 1 2))
897 (test-assert (= 1 1)))
899 (test-result-set! r 'foo 100)
900 (test-result-ref r 'foo))))
902 (test-end "9.3. test-result-set!")
904 (test-end "9. Test Result Properties")
910 #| Time to stop having fun...
912 (test-begin "9. For fun, some meta-test errors")
915 "9.1. Really PASSes, but test like it should FAIL"
919 (test-assert "b" #t))))
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")
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)
932 (test-end "SRFI 64 - Meta-Test Suite")