mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

Implement SRFI-64 - A Scheme API for test suites.

Browse source 
* module/srfi/srfi-64.scm: New file.
* module/srfi/srfi-64/testing.scm: New file.
* module/Makefile.am: Add rule for srfi-64.go dependency on
  srfi-64/testing.scm.
  (SRFI_SOURCES): Add srfi/srfi-64.scm.
  (NOCOMP_SOURCES): Add srfi/srfi-64/testing.scm.
* doc/ref/srfi-modules.texi (SRFI-64): New node.
* test-suite/tests/srfi-64.test: New file.
* test-suite/tests/srfi-64-test.scm: New file.
* test-suite/Makefile.am (SCM_TESTS): Add test-suite/tests/srfi-64.test.
  (EXTRA_DIST): Add tests/srfi-64-test.scm.
This commit is contained in:
Mark H Weaver 2014-01-29 02:20:01 -05:00
parent 9060dc29d5
commit 34e8987734
7 changed files with 2091 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

8
doc/ref/srfi-modules.texi
View file

@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-60:: Integers as bits. * SRFI-60:: Integers as bits.
* SRFI-61:: A more general `cond' clause * SRFI-61:: A more general `cond' clause
* SRFI-62:: S-expression comments. * SRFI-62:: S-expression comments.
* SRFI-64:: A Scheme API for test suites.
* SRFI-67:: Compare procedures * SRFI-67:: Compare procedures
* SRFI-69:: Basic hash tables. * SRFI-69:: Basic hash tables.
* SRFI-87:: => in case clauses. * SRFI-87:: => in case clauses.
@ -5271,6 +5272,13 @@ needed to get SRFI-61 itself. Extended @code{cond} is documented in
Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS
S-expression comments by default. S-expression comments by default.
@node SRFI-64
@subsection SRFI-64 - A Scheme API for test suites.
@cindex SRFI-64
See @uref{http://srfi.schemers.org/srfi-64/srfi-64.html, the
specification of SRFI-64}.
@node SRFI-67 @node SRFI-67
@subsection SRFI-67 - Compare procedures @subsection SRFI-67 - Compare procedures
@cindex SRFI-67 @cindex SRFI-67

7
module/Makefile.am
View file

@ -1,6 +1,7 @@
## Process this file with automake to produce Makefile.in. ## Process this file with automake to produce Makefile.in.
## ##
## Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ## Copyright (C) 2009, 2010, 2011, 2012, 2013,
## 2014 Free Software Foundation, Inc.
## ##
## This file is part of GUILE. ## This file is part of GUILE.
## ##
@ -264,6 +265,8 @@ SCRIPTS_SOURCES += \
endif BUILD_ICE_9_POPEN endif BUILD_ICE_9_POPEN
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
SRFI_SOURCES = \ SRFI_SOURCES = \
srfi/srfi-2.scm \ srfi/srfi-2.scm \
srfi/srfi-4.scm \ srfi/srfi-4.scm \
@ -293,6 +296,7 @@ SRFI_SOURCES = \
srfi/srfi-39.scm \ srfi/srfi-39.scm \
srfi/srfi-45.scm \ srfi/srfi-45.scm \
srfi/srfi-60.scm \ srfi/srfi-60.scm \
srfi/srfi-64.scm \
srfi/srfi-67.scm \ srfi/srfi-67.scm \
srfi/srfi-69.scm \ srfi/srfi-69.scm \
srfi/srfi-88.scm \ srfi/srfi-88.scm \
@ -400,6 +404,7 @@ NOCOMP_SOURCES = \
ice-9/r6rs-libraries.scm \ ice-9/r6rs-libraries.scm \
ice-9/quasisyntax.scm \ ice-9/quasisyntax.scm \
srfi/srfi-42/ec.scm \ srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \ srfi/srfi-67/compare.scm \
system/base/lalr.upstream.scm \ system/base/lalr.upstream.scm \
system/repl/describe.scm \ system/repl/describe.scm \

55
module/srfi/srfi-64.scm Normal file
View file

@ -0,0 +1,55 @@
;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites.
;; Copyright (C) 2014 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (srfi srfi-64)
#:export
(test-begin
test-end test-assert test-eqv test-eq test-equal
test-approximate test-assert test-error test-apply test-with-runner
test-match-nth test-match-all test-match-any test-match-name
test-skip test-expect-fail test-read-eval-string
test-runner-group-path test-group test-group-with-cleanup
test-result-ref test-result-set! test-result-clear test-result-remove
test-result-kind test-passed?
test-log-to-file
test-runner? test-runner-reset test-runner-null
test-runner-simple test-runner-current test-runner-factory test-runner-get
test-runner-create test-runner-test-name
test-runner-pass-count test-runner-pass-count!
test-runner-fail-count test-runner-fail-count!
test-runner-xpass-count test-runner-xpass-count!
test-runner-xfail-count test-runner-xfail-count!
test-runner-skip-count test-runner-skip-count!
test-runner-group-stack test-runner-group-stack!
test-runner-on-test-begin test-runner-on-test-begin!
test-runner-on-test-end test-runner-on-test-end!
test-runner-on-group-begin test-runner-on-group-begin!
test-runner-on-group-end test-runner-on-group-end!
test-runner-on-final test-runner-on-final!
test-runner-on-bad-count test-runner-on-bad-count!
test-runner-on-bad-end-name test-runner-on-bad-end-name!
test-result-alist test-result-alist!
test-runner-aux-value test-runner-aux-value!
test-on-group-begin-simple test-on-group-end-simple
test-on-bad-count-simple test-on-bad-end-name-simple
test-on-final-simple test-on-test-end-simple
test-on-final-simple))
(cond-expand-provide (current-module) '(srfi-64))
(include-from-path "srfi/srfi-64/testing.scm")

1040
module/srfi/srfi-64/testing.scm Normal file
View file

File diff suppressed because it is too large Load diff

4
test-suite/Makefile.am
View file

@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-43.test \ tests/srfi-43.test \
tests/srfi-45.test \ tests/srfi-45.test \
tests/srfi-60.test \ tests/srfi-60.test \
tests/srfi-64.test \
tests/srfi-67.test \ tests/srfi-67.test \
tests/srfi-69.test \ tests/srfi-69.test \
tests/srfi-88.test \ tests/srfi-88.test \
@ -174,7 +175,8 @@ EXTRA_DIST = \
guile-test \ guile-test \
test-suite/lib.scm \ test-suite/lib.scm \
$(SCM_TESTS) \ $(SCM_TESTS) \
tests/rnrs-test-a.scm tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
ChangeLog-2008 ChangeLog-2008

934
test-suite/tests/srfi-64-test.scm Normal file
View file

@ -0,0 +1,934 @@
;;;
;;; This is a test suite written in the notation of
;;; SRFI-64, A Scheme API for test suites
;;;
(test-begin "SRFI 64 - Meta-Test Suite")
;;;
;;; Ironically, in order to set up the meta-test environment,
;;; we have to invoke one of the most sophisticated features:
;;; custom test runners
;;;
;;; The `prop-runner' invokes `thunk' in the context of a new
;;; test runner, and returns the indicated properties of the
;;; last-executed test result.
(define (prop-runner props thunk)
(let ((r (test-runner-null))
(plist '()))
;;
(test-runner-on-test-end!
r
(lambda (runner)
(set! plist (test-result-alist runner))))
;;
(test-with-runner r (thunk))
;; reorder the properties so they are in the order
;; given by `props'. Note that any property listed in `props'
;; that is not in the property alist will occur as #f
(map (lambda (k)
(assq k plist))
props)))
;;; `on-test-runner' creates a null test runner and then
;;; arranged for `visit' to be called with the runner
;;; whenever a test is run. The results of the calls to
;;; `visit' are returned in a list
(define (on-test-runner thunk visit)
(let ((r (test-runner-null))
(results '()))
;;
(test-runner-on-test-end!
r
(lambda (runner)
(set! results (cons (visit r) results))))
;;
(test-with-runner r (thunk))
(reverse results)))
;;;
;;; The `triv-runner' invokes `thunk'
;;; and returns a list of 6 lists, the first 5 of which
;;; are a list of the names of the tests that, respectively,
;;; PASS, FAIL, XFAIL, XPASS, and SKIP.
;;; The last item is a list of counts.
;;;
(define (triv-runner thunk)
(let ((r (test-runner-null))
(accum-pass '())
(accum-fail '())
(accum-xfail '())
(accum-xpass '())
(accum-skip '()))
;;
(test-runner-on-bad-count!
r
(lambda (runner count expected-count)
(error (string-append "bad count " (number->string count)
" but expected "
(number->string expected-count)))))
(test-runner-on-bad-end-name!
r
(lambda (runner begin end)
(error (string-append "bad end group name " end
" but expected " begin))))
(test-runner-on-test-end!
r
(lambda (runner)
(let ((n (test-runner-test-name runner)))
(case (test-result-kind runner)
((pass) (set! accum-pass (cons n accum-pass)))
((fail) (set! accum-fail (cons n accum-fail)))
((xpass) (set! accum-xpass (cons n accum-xpass)))
((xfail) (set! accum-xfail (cons n accum-xfail)))
((skip) (set! accum-skip (cons n accum-skip)))))))
;;
(test-with-runner r (thunk))
(list (reverse accum-pass) ; passed as expected
(reverse accum-fail) ; failed, but was expected to pass
(reverse accum-xfail) ; failed as expected
(reverse accum-xpass) ; passed, but was expected to fail
(reverse accum-skip) ; was not executed
(list (test-runner-pass-count r)
(test-runner-fail-count r)
(test-runner-xfail-count r)
(test-runner-xpass-count r)
(test-runner-skip-count r)))))
(define (path-revealing-runner thunk)
(let ((r (test-runner-null))
(seq '()))
;;
(test-runner-on-test-end!
r
(lambda (runner)
(set! seq (cons (list (test-runner-group-path runner)
(test-runner-test-name runner))
seq))))
(test-with-runner r (thunk))
(reverse seq)))
;;;
;;; Now we can start testing compliance with SRFI-64
;;;
(test-begin "1. Simple test-cases")
(test-begin "1.1. test-assert")
(define (t)
(triv-runner
(lambda ()
(test-assert "a" #t)
(test-assert "b" #f))))
(test-equal
"1.1.1. Very simple"
'(("a") ("b") () () () (1 1 0 0 0))
(t))
(test-equal
"1.1.2. A test with no name"
'(("a") ("") () () () (1 1 0 0 0))
(triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
(test-equal
"1.1.3. Tests can have the same name"
'(("a" "a") () () () () (2 0 0 0 0))
(triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
(define (choke)
(vector-ref '#(1 2) 3))
(test-equal
"1.1.4. One way to FAIL is to throw an error"
'(() ("a") () () () (0 1 0 0 0))
(triv-runner (lambda () (test-assert "a" (choke)))))
(test-end);1.1
(test-begin "1.2. test-eqv")
(define (mean x y)
(/ (+ x y) 2.0))
(test-equal
"1.2.1. Simple numerical equivalence"
'(("c") ("a" "b") () () () (1 2 0 0 0))
(triv-runner
(lambda ()
(test-eqv "a" (mean 3 5) 4)
(test-eqv "b" (mean 3 5) 4.5)
(test-eqv "c" (mean 3 5) 4.0))))
(test-end);1.2
(test-end "1. Simple test-cases")
;;;
;;;
;;;
(test-begin "2. Tests for catching errors")
(test-begin "2.1. test-error")
(test-equal
"2.1.1. Baseline test; PASS with no optional args"
'(("") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
;; PASS
(test-error (vector-ref '#(1 2) 9)))))
(test-equal
"2.1.2. Baseline test; FAIL with no optional args"
'(() ("") () () () (0 1 0 0 0))
(triv-runner
(lambda ()
;; FAIL: the expr does not raise an error and `test-error' is
;; claiming that it will, so this test should FAIL
(test-error (vector-ref '#(1 2) 0)))))
(test-equal
"2.1.3. PASS with a test name and error type"
'(("a") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
;; PASS
(test-error "a" #t (vector-ref '#(1 2) 9)))))
(test-end "2.1. test-error")
(test-end "2. Tests for catching errors")
;;;
;;;
;;;
(test-begin "3. Test groups and paths")
(test-equal
"3.1. test-begin with unspecific test-end"
'(("b") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a")
(test-assert "b" #t)
(test-end))))
(test-equal
"3.2. test-begin with name-matching test-end"
'(("b") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a")
(test-assert "b" #t)
(test-end "a"))))
;;; since the error raised by `test-end' on a mismatch is not a test
;;; error, we actually expect the triv-runner itself to fail
(test-error
"3.3. test-begin with mismatched test-end"
#t
(triv-runner
(lambda ()
(test-begin "a")
(test-assert "b" #t)
(test-end "x"))))
(test-equal
"3.4. test-begin with name and count"
'(("b" "c") () () () () (2 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a" 2)
(test-assert "b" #t)
(test-assert "c" #t)
(test-end "a"))))
;; similarly here, a mismatched count is a lexical error
;; and not a test failure...
(test-error
"3.5. test-begin with mismatched count"
#t
(triv-runner
(lambda ()
(test-begin "a" 99)
(test-assert "b" #t)
(test-end "a"))))
(test-equal
"3.6. introspecting on the group path"
'((() "w")
(("a" "b") "x")
(("a" "b") "y")
(("a") "z"))
;;
;; `path-revealing-runner' is designed to return a list
;; of the tests executed, in order. Each entry is a list
;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
;; of test groups starting from the topmost
;;
(path-revealing-runner
(lambda ()
(test-assert "w" #t)
(test-begin "a")
(test-begin "b")
(test-assert "x" #t)
(test-assert "y" #t)
(test-end)
(test-assert "z" #t))))
(test-end "3. Test groups and paths")
;;;
;;;
;;;
(test-begin "4. Handling set-up and cleanup")
(test-equal "4.1. Normal exit path"
'(in 1 2 out)
(let ((ex '()))
(define (do s)
(set! ex (cons s ex)))
;;
(triv-runner
(lambda ()
(test-group-with-cleanup
"foo"
(do 'in)
(do 1)
(do 2)
(do 'out))))
(reverse ex)))
(test-equal "4.2. Exception exit path"
'(in 1 out)
(let ((ex '()))
(define (do s)
(set! ex (cons s ex)))
;;
;; the outer runner is to run the `test-error' in, to
;; catch the exception raised in the inner runner,
;; since we don't want to depend on any other
;; exception-catching support
;;
(triv-runner
(lambda ()
(test-error
(triv-runner
(lambda ()
(test-group-with-cleanup
"foo"
(do 'in) (test-assert #t)
(do 1) (test-assert #t)
(choke) (test-assert #t)
(do 2) (test-assert #t)
(do 'out)))))))
(reverse ex)))
(test-end "4. Handling set-up and cleanup")
;;;
;;;
;;;
(test-begin "5. Test specifiers")
(test-begin "5.1. test-match-named")
(test-equal "5.1.1. match test names"
'(("y") () () () ("x") (1 0 0 0 1))
(triv-runner
(lambda ()
(test-skip (test-match-name "x"))
(test-assert "x" #t)
(test-assert "y" #t))))
(test-equal "5.1.2. but not group names"
'(("z") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
(test-skip (test-match-name "x"))
(test-begin "x")
(test-assert "z" #t)
(test-end))))
(test-end)
(test-begin "5.2. test-match-nth")
;; See also: [6.4. Short-circuit evaluation]
(test-equal "5.2.1. skip the nth one after"
'(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
(triv-runner
(lambda ()
(test-assert "v" #t)
(test-skip (test-match-nth 2))
(test-assert "w" #t) ; 1
(test-assert "x" #t) ; 2 SKIP
(test-assert "y" #t) ; 3
(test-assert "z" #t)))) ; 4
(test-equal "5.2.2. skip m, starting at n"
'(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
(triv-runner
(lambda ()
(test-assert "v" #t)
(test-skip (test-match-nth 2 2))
(test-assert "w" #t) ; 1
(test-assert "x" #t) ; 2 SKIP
(test-assert "y" #t) ; 3 SKIP
(test-assert "z" #t)))) ; 4
(test-end)
(test-begin "5.3. test-match-any")
(test-equal "5.3.1. basic disjunction"
'(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
(triv-runner
(lambda ()
(test-assert "v" #t)
(test-skip (test-match-any (test-match-nth 3)
(test-match-name "x")))
(test-assert "w" #t) ; 1
(test-assert "x" #t) ; 2 SKIP(NAME)
(test-assert "y" #t) ; 3 SKIP(COUNT)
(test-assert "z" #t)))) ; 4
(test-equal "5.3.2. disjunction is commutative"
'(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
(triv-runner
(lambda ()
(test-assert "v" #t)
(test-skip (test-match-any (test-match-name "x")
(test-match-nth 3)))
(test-assert "w" #t) ; 1
(test-assert "x" #t) ; 2 SKIP(NAME)
(test-assert "y" #t) ; 3 SKIP(COUNT)
(test-assert "z" #t)))) ; 4
(test-end)
(test-begin "5.4. test-match-all")
(test-equal "5.4.1. basic conjunction"
'(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
(triv-runner
(lambda ()
(test-assert "v" #t)
(test-skip (test-match-all (test-match-nth 2 2)
(test-match-name "x")))
(test-assert "w" #t) ; 1
(test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
(test-assert "y" #t) ; 3 SKIP(COUNT)
(test-assert "z" #t)))) ; 4
(test-equal "5.4.2. conjunction is commutative"
'(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
(triv-runner
(lambda ()
(test-assert "v" #t)
(test-skip (test-match-all (test-match-name "x")
(test-match-nth 2 2)))
(test-assert "w" #t) ; 1
(test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
(test-assert "y" #t) ; 3 SKIP(COUNT)
(test-assert "z" #t)))) ; 4
(test-end)
(test-end "5. Test specifiers")
;;;
;;;
;;;
(test-begin "6. Skipping selected tests")
(test-equal
"6.1. Skip by specifier - match-name"
'(("x") () () () ("y") (1 0 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip (test-match-name "y"))
(test-assert "x" #t) ; PASS
(test-assert "y" #f) ; SKIP
(test-end))))
(test-equal
"6.2. Shorthand specifiers"
'(("x") () () () ("y") (1 0 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip "y")
(test-assert "x" #t) ; PASS
(test-assert "y" #f) ; SKIP
(test-end))))
(test-begin "6.3. Specifier Stack")
(test-equal
"6.3.1. Clearing the Specifier Stack"
'(("x" "x") ("y") () () ("y") (2 1 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip "y")
(test-assert "x" #t) ; PASS
(test-assert "y" #f) ; SKIP
(test-end)
(test-begin "b")
(test-assert "x" #t) ; PASS
(test-assert "y" #f) ; FAIL
(test-end))))
(test-equal
"6.3.2. Inheriting the Specifier Stack"
'(("x" "x") () () () ("y" "y") (2 0 0 0 2))
(triv-runner
(lambda ()
(test-skip "y")
(test-begin "a")
(test-assert "x" #t) ; PASS
(test-assert "y" #f) ; SKIP
(test-end)
(test-begin "b")
(test-assert "x" #t) ; PASS
(test-assert "y" #f) ; SKIP
(test-end))))
(test-end);6.3
(test-begin "6.4. Short-circuit evaluation")
(test-equal
"6.4.1. In test-match-all"
'(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip (test-match-all "y" (test-match-nth 2)))
;; let's label the substructure forms so we can
;; see which one `test-match-nth' is going to skip
;; ; # "y" 2 result
(test-assert "x" #t) ; 1 - #f #f PASS
(test-assert "y" #f) ; 2 - #t #t SKIP
(test-assert "y" #f) ; 3 - #t #f FAIL
(test-assert "x" #f) ; 4 - #f #f FAIL
(test-assert "z" #f) ; 5 - #f #f FAIL
(test-end))))
(test-equal
"6.4.2. In separate skip-list entries"
'(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip "y")
(test-skip (test-match-nth 2))
;; let's label the substructure forms so we can
;; see which one `test-match-nth' is going to skip
;; ; # "y" 2 result
(test-assert "x" #t) ; 1 - #f #f PASS
(test-assert "y" #f) ; 2 - #t #t SKIP
(test-assert "y" #f) ; 3 - #t #f SKIP
(test-assert "x" #f) ; 4 - #f #f FAIL
(test-assert "z" #f) ; 5 - #f #f FAIL
(test-end))))
(test-begin "6.4.3. Skipping test suites")
(test-equal
"6.4.3.1. Introduced using 'test-begin'"
'(("x") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip "b")
(test-begin "b") ; not skipped
(test-assert "x" #t)
(test-end "b")
(test-end "a"))))
(test-expect-fail 1) ;; ???
(test-equal
"6.4.3.2. Introduced using 'test-group'"
'(() () () () () (0 0 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip "b")
(test-group
"b" ; skipped
(test-assert "x" #t))
(test-end "a"))))
(test-equal
"6.4.3.3. Non-skipped 'test-group'"
'(("x") () () () () (1 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a")
(test-skip "c")
(test-group "b" (test-assert "x" #t))
(test-end "a"))))
(test-end) ; 6.4.3
(test-end);6.4
(test-end "6. Skipping selected tests")
;;;
;;;
;;;
(test-begin "7. Expected failures")
(test-equal "7.1. Simple example"
'(() ("x") ("z") () () (0 1 1 0 0))
(triv-runner
(lambda ()
(test-assert "x" #f)
(test-expect-fail "z")
(test-assert "z" #f))))
(test-equal "7.2. Expected exception"
'(() ("x") ("z") () () (0 1 1 0 0))
(triv-runner
(lambda ()
(test-assert "x" #f)
(test-expect-fail "z")
(test-assert "z" (choke)))))
(test-equal "7.3. Unexpectedly PASS"
'(() () ("y") ("x") () (0 0 1 1 0))
(triv-runner
(lambda ()
(test-expect-fail "x")
(test-expect-fail "y")
(test-assert "x" #t)
(test-assert "y" #f))))
(test-end "7. Expected failures")
;;;
;;;
;;;
(test-begin "8. Test-runner")
;;;
;;; Because we want this test suite to be accurate even
;;; when the underlying implementation chooses to use, e.g.,
;;; a global variable to implement what could be thread variables
;;; or SRFI-39 parameter objects, we really need to save and restore
;;; their state ourselves
;;;
(define (with-factory-saved thunk)
(let* ((saved (test-runner-factory))
(result (thunk)))
(test-runner-factory saved)
result))
(test-begin "8.1. test-runner-current")
(test-assert "8.1.1. automatically restored"
(let ((a 0)
(b 1)
(c 2))
;
(triv-runner
(lambda ()
(set! a (test-runner-current))
;;
(triv-runner
(lambda ()
(set! b (test-runner-current))))
;;
(set! c (test-runner-current))))
;;
(and (eq? a c)
(not (eq? a b)))))
(test-end)
(test-begin "8.2. test-runner-simple")
(test-assert "8.2.1. default on-test hook"
(eq? (test-runner-on-test-end (test-runner-simple))
test-on-test-end-simple))
(test-assert "8.2.2. default on-final hook"
(eq? (test-runner-on-final (test-runner-simple))
test-on-final-simple))
(test-end)
(test-begin "8.3. test-runner-factory")
(test-assert "8.3.1. default factory"
(eq? (test-runner-factory) test-runner-simple))
(test-assert "8.3.2. settable factory"
(with-factory-saved
(lambda ()
(test-runner-factory test-runner-null)
;; we have no way, without bringing in other SRFIs,
;; to make sure the following doesn't print anything,
;; but it shouldn't:
(test-with-runner
(test-runner-create)
(lambda ()
(test-begin "a")
(test-assert #t) ; pass
(test-assert #f) ; fail
(test-assert (vector-ref '#(3) 10)) ; fail with error
(test-end "a")))
(eq? (test-runner-factory) test-runner-null))))
(test-end)
;;; This got tested about as well as it could in 8.3.2
(test-begin "8.4. test-runner-create")
(test-end)
;;; This got tested about as well as it could in 8.3.2
(test-begin "8.5. test-runner-factory")
(test-end)
(test-begin "8.6. test-apply")
(test-equal "8.6.1. Simple (form 1) test-apply"
'(("w" "p" "v") () () () ("x") (3 0 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-assert "w" #t)
(test-apply
(test-match-name "p")
(lambda ()
(test-begin "p")
(test-assert "x" #t)
(test-end)
(test-begin "z")
(test-assert "p" #t) ; only this one should execute in here
(test-end)))
(test-assert "v" #t))))
(test-equal "8.6.2. Simple (form 2) test-apply"
'(("w" "p" "v") () () () ("x") (3 0 0 0 1))
(triv-runner
(lambda ()
(test-begin "a")
(test-assert "w" #t)
(test-apply
(test-runner-current)
(test-match-name "p")
(lambda ()
(test-begin "p")
(test-assert "x" #t)
(test-end)
(test-begin "z")
(test-assert "p" #t) ; only this one should execute in here
(test-end)))
(test-assert "v" #t))))
(test-expect-fail 1) ;; depends on all test-match-nth being called.
(test-equal "8.6.3. test-apply with skips"
'(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
(triv-runner
(lambda ()
(test-begin "a")
(test-assert "w" #t)
(test-skip (test-match-nth 2))
(test-skip (test-match-nth 4))
(test-apply
(test-runner-current)
(test-match-name "p")
(test-match-name "q")
(lambda ()
; only execute if SKIP=no and APPLY=yes
(test-assert "x" #t) ; # 1 SKIP=no APPLY=no
(test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes
(test-assert "q" #t) ; # 3 SKIP=no APPLY=yes
(test-assert "x" #f) ; # 4 SKIP=yes APPLY=no
0))
(test-assert "v" #t))))
;;; Unfortunately, since there is no way to UNBIND the current test runner,
;;; there is no way to test the behavior of `test-apply' in the absence
;;; of a current runner within our little meta-test framework.
;;;
;;; To test the behavior manually, you should be able to invoke:
;;;
;;; (test-apply "a" (lambda () (test-assert "a" #t)))
;;;
;;; from the top level (with SRFI 64 available) and it should create a
;;; new, default (simple) test runner.
(test-end)
;;; This entire suite depends heavily on 'test-with-runner'. If it didn't
;;; work, this suite would probably go down in flames
(test-begin "8.7. test-with-runner")
(test-end)
;;; Again, this suite depends heavily on many of the test-runner
;;; components. We'll just test those that aren't being exercised
;;; by the meta-test framework
(test-begin "8.8. test-runner components")
(define (auxtrack-runner thunk)
(let ((r (test-runner-null)))
(test-runner-aux-value! r '())
(test-runner-on-test-end! r (lambda (r)
(test-runner-aux-value!
r
(cons (test-runner-test-name r)
(test-runner-aux-value r)))))
(test-with-runner r (thunk))
(reverse (test-runner-aux-value r))))
(test-equal "8.8.1. test-runner-aux-value"
'("x" "" "y")
(auxtrack-runner
(lambda ()
(test-assert "x" #t)
(test-begin "a")
(test-assert #t)
(test-end)
(test-assert "y" #f))))
(test-end) ; 8.8
(test-end "8. Test-runner")
(test-begin "9. Test Result Properties")
(test-begin "9.1. test-result-alist")
(define (symbol-alist? l)
(if (null? l)
#t
(and (pair? l)
(pair? (car l))
(symbol? (caar l))
(symbol-alist? (cdr l)))))
;;; check the various syntactic forms
(test-assert (symbol-alist?
(car (on-test-runner
(lambda ()
(test-assert #t))
(lambda (r)
(test-result-alist r))))))
(test-assert (symbol-alist?
(car (on-test-runner
(lambda ()
(test-assert #t))
(lambda (r)
(test-result-alist r))))))
;;; check to make sure the required properties are returned
(test-equal '((result-kind . pass))
(prop-runner
'(result-kind)
(lambda ()
(test-assert #t)))
)
(test-equal
'((result-kind . fail)
(expected-value . 2)
(actual-value . 3))
(prop-runner
'(result-kind expected-value actual-value)
(lambda ()
(test-equal 2 (+ 1 2)))))
(test-end "9.1. test-result-alist")
(test-begin "9.2. test-result-ref")
(test-equal '(pass)
(on-test-runner
(lambda ()
(test-assert #t))
(lambda (r)
(test-result-ref r 'result-kind))))
(test-equal '(pass)
(on-test-runner
(lambda ()
(test-assert #t))
(lambda (r)
(test-result-ref r 'result-kind))))
(test-equal '(fail pass)
(on-test-runner
(lambda ()
(test-assert (= 1 2))
(test-assert (= 1 1)))
(lambda (r)
(test-result-ref r 'result-kind))))
(test-end "9.2. test-result-ref")
(test-begin "9.3. test-result-set!")
(test-equal '(100 100)
(on-test-runner
(lambda ()
(test-assert (= 1 2))
(test-assert (= 1 1)))
(lambda (r)
(test-result-set! r 'foo 100)
(test-result-ref r 'foo))))
(test-end "9.3. test-result-set!")
(test-end "9. Test Result Properties")
;;;
;;;
;;;
#| Time to stop having fun...
(test-begin "9. For fun, some meta-test errors")
(test-equal
"9.1. Really PASSes, but test like it should FAIL"
'(() ("b") () () ())
(triv-runner
(lambda ()
(test-assert "b" #t))))
(test-expect-fail "9.2. Expect to FAIL and do so")
(test-expect-fail "9.3. Expect to FAIL but PASS")
(test-skip "9.4. SKIP this one")
(test-assert "9.2. Expect to FAIL and do so" #f)
(test-assert "9.3. Expect to FAIL but PASS" #t)
(test-assert "9.4. SKIP this one" #t)
(test-end)
|#
(test-end "SRFI 64 - Meta-Test Suite")
;;;

45
test-suite/tests/srfi-64.test Normal file
View file

@ -0,0 +1,45 @@
;;;; srfi-64.test --- Test suite for SRFI-64. -*- scheme -*-
;;;;
;;;; Copyright (C) 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-srfi-64)
#:use-module ((test-suite lib) #:select (report))
#:use-module (srfi srfi-64))
(define (guile-test-runner)
(let ((runner (test-runner-null)))
(test-runner-on-test-end! runner
(lambda (runner)
(let* ((result-alist (test-result-alist runner))
(result-kind (assq-ref result-alist 'result-kind))
(test-name (list (assq-ref result-alist 'test-name))))
(case result-kind
((pass) (report 'pass test-name))
((xpass) (report 'upass test-name))
((skip) (report 'untested test-name))
((fail xfail)
(apply report result-kind test-name result-alist))
(else #t)))))
runner))
(test-with-runner
(guile-test-runner)
(primitive-load-path "tests/srfi-64-test.scm"))
;;; Local Variables:
;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
;;; End: