testing.scm

A framework written in Java for implementing high-level and dynamic languages, compiling them into J

;; Copyright (c) 2005, 2006 Per Bothner
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(cond-expand
 (chicken
  (require-extension syntax-case))
 (guile
  (use-modules (ice-9 syncase) (srfi srfi-9)
	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
	       (srfi srfi-39)))
 (sisc
  (require-extension (srfi 9 34 35 39)))
 (kawa
  (module-compile-options warn-undefined-variable: #t
			  warn-invoke-unknown-method: #t)
  (provide 'srfi-64)
  (provide 'testing)
  (require 'srfi-34)
  (require 'srfi-35))
 (else ()
  ))

(cond-expand
 (kawa
  (define-syntax %test-export
    (syntax-rules ()
      ((%test-export test-begin . other-names)
       (module-export %test-begin . other-names)))))
 (else
  (define-syntax %test-export
    (syntax-rules ()
      ((%test-export . names) (if #f #f))))))

;; List of exported names
(%test-export
 test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
 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-with-cleanup
 test-result-ref test-result-set! test-result-clear test-result-remove
 test-result-kind test-passed?
 test-log-to-file
 ; Misc test-runner functions
 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 field setter and getter functions - see %test-record-define:
 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!
 ;; default/simple call-back functions, used in default test-runner,
 ;; but can be called to construct more complex ones.
 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
 (srfi-9
  (define-syntax %test-record-define
    (syntax-rules ()
      ((%test-record-define alloc runner? (name index setter getter) ...)
       (define-record-type test-runner
	 (alloc)
	 runner?
	 (name setter getter) ...)))))
 (else
  (define %test-runner-cookie (list "test-runner"))
  (define-syntax %test-record-define
    (syntax-rules ()
      ((%test-record-define alloc runner? (name index getter setter) ...)
       (begin
	 (define (runner? obj)
	   (and (vector? obj)
		(> (vector-length obj) 1)
		(eq (vector-ref obj 0) %test-runner-cookie)))
	 (define (alloc)
	   (let ((runner (make-vector 22)))
	     (vector-set! runner 0 %test-runner-cookie)
	     runner))
	 (begin
	   (define (getter runner)
	     (vector-ref runner index)) ...)
	 (begin
	   (define (setter runner value)
	     (vector-set! runner index value)) ...)))))))

(%test-record-define
 %test-runner-alloc test-runner?
 ;; Cumulate count of all tests that have passed and were expected to.
 (pass-count 1 test-runner-pass-count test-runner-pass-count!)
 (fail-count 2 test-runner-fail-count test-runner-fail-count!)
 (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
 (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
 (skip-count 5 test-runner-skip-count test-runner-skip-count!)
 (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
 (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
 ;; Normally #t, except when in a test-apply.
 (run-list 8 %test-runner-run-list %test-runner-run-list!)
 (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
 (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
 (group-stack 11 test-runner-group-stack test-runner-group-stack!)
 (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
 (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
 ;; Call-back when entering a group. Takes (runner suite-name count).
 (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
 ;; Call-back when leaving a group.
 (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
 ;; Call-back when leaving the outermost group.
 (on-final 16 test-runner-on-final test-runner-on-final!)
 ;; Call-back when expected number of tests was wrong.
 (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
 ;; Call-back when name in test=end doesn't match test-begin.
 (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
 ;; Cumulate count of all tests that have been done.
 (total-count 19 %test-runner-total-count %test-runner-total-count!)
 ;; Stack (list) of (count-at-start . expected-count):
 (count-list 20 %test-runner-count-list %test-runner-count-list!)
 (result-alist 21 test-result-alist test-result-alist!)
 ;; Field can be used by test-runner for any purpose.
 ;; test-runner-simple uses it for a log file.
 (aux-value 22 test-runner-aux-value test-runner-aux-value!)
)

(define (test-runner-reset runner)
    (test-runner-pass-count! runner 0)
    (test-runner-fail-count! runner 0)
    (test-runner-xpass-count! runner 0)
    (test-runner-xfail-count! runner 0)
    (test-runner-skip-count! runner 0)
    (%test-runner-total-count! runner 0)
    (%test-runner-count-list! runner '())
    (%test-runner-run-list! runner #t)
    (%test-runner-skip-list! runner '())
    (%test-runner-fail-list! runner '())
    (%test-runner-skip-save! runner '())
    (%test-runner-fail-save! runner '())
    (test-runner-group-stack! runner '()))

(define (test-runner-group-path runner)
  (reverse (test-runner-group-stack runner)))

(define (%test-null-callback runner) #f)

(define (test-runner-null)
  (let ((runner (%test-runner-alloc)))
    (test-runner-reset runner)
    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
    (test-runner-on-group-end! runner %test-null-callback)
    (test-runner-on-final! runner %test-null-callback)
    (test-runner-on-test-begin! runner %test-null-callback)
    (test-runner-on-test-end! runner %test-null-callback)
    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
    runner))

;; Not part of the specification.  FIXME
;; Controls whether a log file is generated.
(define test-log-to-file #t)

(define (test-runner-simple)
  (let ((runner (%test-runner-alloc)))
    (test-runner-reset runner)
    (test-runner-on-group-begin! runner test-on-group-begin-simple)
    (test-runner-on-group-end! runner test-on-group-end-simple)
    (test-runner-on-final! runner test-on-final-simple)
    (test-runner-on-test-begin! runner test-on-test-begin-simple)
    (test-runner-on-test-end! runner test-on-test-end-simple)
    (test-runner-on-bad-count! runner test-on-bad-count-simple)
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
    runner))

(cond-expand
 (srfi-39
  (define test-runner-current (make-parameter #f))
  (define test-runner-factory (make-parameter test-runner-simple)))
 (else
  (define %test-runner-current #f)
  (define-syntax test-runner-current
    (syntax-rules ()
      ((test-runner-current)
       %test-runner-current)
      ((test-runner-current runner)
       (set! %test-runner-current runner))))
  (define %test-runner-factory test-runner-simple)
  (define-syntax test-runner-factory
    (syntax-rules ()
      ((test-runner-factory)
       %test-runner-factory)
      ((test-runner-factory runner)
       (set! %test-runner-factory runner))))))

;; A safer wrapper to test-runner-current.
(define (test-runner-get)
  (let ((r (test-runner-current)))
    (if (not r)
	(cond-expand
	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
	 (else #t)))
    r))

(define (%test-specificier-matches spec runner)
  (spec runner))

(define (test-runner-create)
  ((test-runner-factory)))

(define (%test-any-specifier-matches list runner)
  (let ((result #f))
    (let loop ((l list))
      (cond ((null? l) result)
	    (else
	     (if (%test-specificier-matches (car l) runner)
		 (set! result #t))
	     (loop (cdr l)))))))

;; Returns #f, #t, or 'xfail.
(define (%test-should-execute runner)
  (let ((run (%test-runner-run-list runner)))
    (cond ((or
	    (not (or (eqv? run #t)
		     (%test-any-specifier-matches run runner)))
	    (%test-any-specifier-matches
	     (%test-runner-skip-list runner)
	     runner))
	    (test-result-set! runner 'result-kind 'skip)
	    #f)
	  ((%test-any-specifier-matches
	    (%test-runner-fail-list runner)
	    runner)
	   (test-result-set! runner 'result-kind 'xfail)
	   'xfail)
	  (else #t))))

(define (%test-begin suite-name count)
  (if (not (test-runner-current))
      (test-runner-current (test-runner-create)))
  (let ((runner (test-runner-current)))
    ((test-runner-on-group-begin runner) runner suite-name count)
    (%test-runner-skip-save! runner
			       (cons (%test-runner-skip-list runner)
				     (%test-runner-skip-save runner)))
    (%test-runner-fail-save! runner
			       (cons (%test-runner-fail-list runner)
				     (%test-runner-fail-save runner)))
    (%test-runner-count-list! runner
			     (cons (cons (%test-runner-total-count runner)
					 count)
				   (%test-runner-count-list runner)))
    (test-runner-group-stack! runner (cons suite-name
					(test-runner-group-stack runner)))))
(cond-expand
 (kawa
  ;; Kawa has test-begin built in, implemented as:
  ;; (begin
  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
  ;;   (%test-begin suite-name [count]))
  ;; This puts test-begin but only test-begin in the default environment.,
  ;; which makes normal test suites loadable without non-portable commands.
  )
 (else
  (define-syntax test-begin
    (syntax-rules ()
      ((test-begin suite-name)
       (%test-begin suite-name #f))
      ((test-begin suite-name count)
       (%test-begin suite-name count))))))

(define (test-on-group-begin-simple runner suite-name count)
  (if (null? (test-runner-group-stack runner))
      (begin
	(display "%%%% Starting test ")
	(display suite-name)
	(if test-log-to-file
	    (let* ((log-file-name
		    (if (string? test-log-to-file) test-log-to-file
			(string-append suite-name ".log")))
		   (log-file
		    (cond-expand (mzscheme
				  (open-output-file log-file-name 'truncate/replace))
				 (else (open-output-file log-file-name)))))
	      (display "%%%% Starting test " log-file)
	      (display suite-name log-file)
	      (newline log-file)
	      (test-runner-aux-value! runner log-file)
	      (display "  (Writing full log to \"")
	      (display log-file-name)
	      (display "\")")))
	(newline)))
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)