;;; -*- Mode: Scheme -*-
;;;; Testing Utility for Scheme
;;; Copyright (C) 2007, 2009 Taylor R. Campbell.
;;;
;;; This file is part of TRC-Testing.
;;;
;;; TRC-Testing 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.
;;;
;;; TRC-Testing 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 TRC-Testing. If not, see
;;; .
;;; Parameters:
;;;
;;; (WITH-TEST-CASE-RUN )
;;; (WITH-TEST-SUITE-RUN )
;;; (NILADIC-TEST)
;;; (MONADIC-TEST )
;;; (POLYADIC-TEST )
;;; (COMPONENT-TEST )
;;; (TEST-FAILURE ...)
;;; (TEST-FAILURE:PREDICATE-DATUM )
;;; (TEST-FAILURE:COMPARE-DATUM
;;;
;;; )
(define-record-type
(%make-test-suite name description tests)
test-suite?
(name test-suite/name)
(description test-suite/description)
(tests test-suite/tests set-test-suite/tests!))
(define (make-test-suite name description)
(%make-test-suite name description '()))
(define-record-type
(make-test-case name description constructor)
test-case?
(name test-case/name)
(description test-case/description)
(constructor test-case/constructor))
(define (add-test! suite name test)
(let ((tests (test-suite/tests suite)))
(cond ((assv name tests)
=> (lambda (probe)
(set-cdr! probe test)))
(else
(set-test-suite/tests! suite (cons (cons name test) tests))))))
(define (run-test-case test-case)
(with-test-case-run (test-case/name test-case)
(test-case/description test-case)
(lambda ()
(receive (setup teardown bodies) ((test-case/constructor test-case))
(define (body->thunk body)
(lambda ()
(dynamic-wind setup body teardown)))
(cond ((not (pair? bodies))
(niladic-test))
((not (pair? (cdr bodies)))
(monadic-test (body->thunk (car bodies))))
(else
(polyadic-test (map body->thunk bodies))))))))
(define (run-test-suite test-suite)
(with-test-suite-run (test-suite/name test-suite)
(test-suite/description test-suite)
(lambda ()
(for-each (lambda (name.test)
(component-test (lambda () (run-test (cdr name.test)))))
(reverse (test-suite/tests test-suite))))))
(define (run-test test)
(cond ((test-case? test) (run-test-case test))
((test-suite? test) (run-test-suite test))
(else (error "Invalid test:" test))))
(define (find-test suite name)
(let loop ((tests (test-suite/tests suite)))
(cond ((not (pair? tests))
(error "No such test by name in suite:" name suite))
((eqv? name (caar tests))
(cdar tests))
(else
(loop (cdr tests))))))
;;;; Test Macros
(define-syntax test-predicate
(syntax-rules ()
((TEST-PREDICATE predicate expression)
(LET ((DATUM expression))
(IF (NOT (predicate expression))
(TEST-FAILURE:PREDICATE-DATUM 'predicate 'expression DATUM))))))
(define-syntax test-compare
(syntax-rules ()
((TEST-COMPARE comparator expected-expression actual-expression)
(LET ((EXPECTED-DATUM expected-expression)
(ACTUAL-DATUM actual-expression))
(IF (NOT (comparator EXPECTED-DATUM ACTUAL-DATUM))
(TEST-FAILURE:COMPARE-DATUM 'comparator
'expected-expression EXPECTED-DATUM
'actual-expression ACTUAL-DATUM))))))
(define-syntax test-eq
(syntax-rules ()
((TEST-EQ expected-expression actual-expression)
(TEST-COMPARE EQ? expected-expression actual-expression))))
(define-syntax test-eqv
(syntax-rules ()
((TEST-EQ expected-expression actual-expression)
(TEST-COMPARE EQV? expected-expression actual-expression))))
(define-syntax test-equal
(syntax-rules ()
((TEST-EQ expected-expression actual-expression)
(TEST-COMPARE EQUAL? expected-expression actual-expression))))
;;;; Syntactic Sugar
(define-syntax define-test-suite
(syntax-rules ()
((DEFINE-TEST-SUITE (suite-name parent) description)
(DEFINE suite-name
(LET ((suite-name (MAKE-TEST-SUITE 'suite-name 'description)))
(ADD-TEST! parent 'suite-name suite-name)
suite-name)))
((DEFINE-TEST-SUITE suite-name description)
(DEFINE suite-name (MAKE-TEST-SUITE 'suite-name 'description)))))
(define-syntax define-test-case
(syntax-rules ()
((DEFINE-TEST-CASE test-suite name test-case)
(ADD-TEST! test-suite `name test-case))
((DEFINE-TEST-CASE test-suite test-case-name (option ...) test ...)
(LET ((NAME `test-case-name))
(DEFINE-TEST-CASE test-suite ,NAME
(TEST-CASE ,NAME (option ...) test ...))))))
(define-syntax test-case
(syntax-rules ()
;; Do the syntactically fast case with no options.
;; WITH-EXTENDED-PARAMETER-OPERATORS* is *slow*.
((TEST-CASE test-case-name () test ...)
(%TEST-CASE test-case-name #F (test ...) ((VALUES)) ((VALUES))))
((TEST-CASE test-case-name (option ...) test ...)
(WITH-EXTENDED-PARAMETER-OPERATORS*
((%TEST-CASE*
() ;No named parameter pattern literals
(%TEST-CASE
(NAME ((NAME ?name)) ?name #F)
(DESCRIPTION ((DESCRIPTION ?description)) ?description #F)
(TESTS ((TESTS . ?tests)) ?tests #F)
;; Unfortunately, because of...issues with ellipsis, we
;; can't write the actual patterns we want to write here
;; for non-empty proper list bodies.
(SETUP ((SETUP . ?setup-body)) ?setup-body ((VALUES)))
(TEARDOWN ((TEARDOWN . ?teardown-body))
?teardown-body
((VALUES))))))
;; Force named parameters by using leading ones.
(%TEST-CASE* (NAME test-case-name) (TESTS test ...) option ...)))))
(define-syntax %test-case
(syntax-rules ()
((%TEST-CASE name
description
(test ...)
(setup-body0 setup-body1 ...)
(teardown-body0 teardown-body1 ...))
(MAKE-TEST-CASE `name
'description
(LAMBDA ()
(VALUES (LAMBDA () setup-body0 setup-body1 ...)
(LAMBDA () teardown-body0 teardown-body1 ...)
(LIST (LAMBDA () test)
...)))))))