;;; -*- Mode: Lisp -*-
;;;; xptestsuite.lisp --- Test suite based on Extreme Programming
;;;;                      Framework by Kent Beck
;;;;
;;;; Inspired by http://www.xprogramming.com/testfram.htm
;;;;
;;;; Author: Craig Brozefsky <craig@onshore.com>
;;;; Put in public domain by onShore, Inc
;;;;
;;;; $Id: xptestsuite.lisp,v 1.5 2003/06/26 18:28:09 tril Exp $

(in-package "XP-TEST")

(defclass test-fixture ()
  ((test-thunk
    :initarg :test-thunk
    :reader test-thunk
    :initform 'perform-test
    :documentation
    "A thunk or symbol which will be applied to this instance, a
test-case, to perform that test-case. Defaults to 'perform-test")
   (test-name
    :initarg :test-name
    :reader test-name
    :documentation
    "The name of this test-case, used in reports.")
   (test-description
    :initarg :description
    :reader description
    :documentation
    "Short description of this test-case, uses in reports"))
  (:documentation
   "Base class for test-fixtures.  Test-cases are instances of test-fixtures."))

(defmethod setup ((test test-fixture))
  "Method called before performing a test, should set up the
environment the test-case needs to operate in."
  t)

(defmethod teardown ((test test-fixture))
  "Method called after performing a test.  Should reverse everything that the
setup method did for this instance."
  t)

(define-condition test-failure (simple-condition) ()
  (:documentation "Base class for all test failures."))

(defun failure (format-str &rest args)
  "Signal a test failure and exit the test."
  (signal 'test-failure
	  #+(or cmu allegro clisp) :format-control
	  #-(or cmu allegro clisp) :format-string
	  format-str
	  :format-arguments args))

(defmacro test-assert (test)
  `(unless ,test
    (failure "Test assertion failed: ~s" ',test)))


(defmethod perform-test ((test test-fixture))
  "Default method for performing tests upon a test-fixture."
  t)

(defmacro handler-case-if (test form &body cases)
  `(if ,test
       (handler-case
        ,form
	,@cases)
     ,form))

(defmacro unwind-protect-if (test protected cleanup)
  `(if ,test
       (unwind-protect
	   ,protected
	 ,cleanup)
     (progn ,protected ,cleanup)))

(defmethod run-test ((test test-fixture) &key (handle-errors t))
  "Perform the test represented by the given test-case or test-suite.
Returns one or more test-result objects, one for each test-case
performed."
  (let ((start-time (get-universal-time))
	(failures ())
	(errs ()))
    (unwind-protect-if handle-errors
	(handler-case-if handle-errors
	 (let ((res (progn (setup test)
			   (apply (test-thunk test) (list test)))))
	   (if (typep res 'test-failure)
	       (setf failures (cons res failures))))
	 (test-failure (failure)
		       (setf failures (cons failure failures)))
	 (t (err)
	    (setf errs (cons err errs))))
      (handler-case-if handle-errors
       (teardown test)
       (t (err)
	  (setf errs (cons err errs)))))
    (make-instance 'test-result
		   :test test
		   :start-time start-time
		   :stop-time (get-universal-time)
		   :failures failures
		   :errors errs)))

(defmacro def-test-fixture (name supers slotdefs &rest class-options)
  "Define a new test-fixture class.  Works just like defclass, but
ensure that test-fixture is a super."
  `(defclass ,name ,(append supers (list 'test-fixture))
     ,slotdefs ,@class-options))

(defmacro make-test-case (name fixture &key
			       (test-thunk 'perform-test)
			       (test-suite nil)
			       (description "No description."))
  "Create a test-case which is an instance of FIXTURE.  TEST-THUNK is
the method that will be invoked when perfoming this test, and can be a
symbol or a lambda taking a single argument, the test-fixture
instance.  DESCRIPTION is obviously what it says it is."
  (let ((newtest (gensym "new-test")))
    `(let ((,newtest (make-instance ,fixture
				    :test-name ,name
				    :test-thunk ,(if (eq test-thunk 'perform-test)
						     ''perform-test
						   test-thunk)
				    :description ,description)))
       (if ,test-suite (add-test ,newtest ,test-suite))
       ,newtest)))
	   
(defclass test-suite ()
  ((name
    :initarg :name
    :reader test-suite-name)
   (tests
    :initarg :tests
    :accessor tests-hash
    :initform (make-hash-table :test 'equal))
   (description
    :initarg :description
    :reader description
    :initform "No description.")))

(defmethod tests ((suite test-suite))
  (let ((tlist nil))
    (maphash #'(lambda (k v)
		 (declare (ignore k))
		 (setf tlist (cons v tlist)))
	     (tests-hash suite))
    (reverse tlist)))

(defmacro make-test-suite (name description &rest testspecs)
  "Returns a new test-suite.  TESTSPECS are just like lists of
arguments to MAKE-TEST-CASE."
  (let* ((newsuite (gensym "test-suite"))
	 (testforms (mapcar #'(lambda (spec)
				(list
				 'add-test
				 (cons 'make-test-case spec)
				 newsuite))
			    testspecs)))
    `(let ((,newsuite (make-instance 'test-suite :name ,name
				     :description ,description)))
       ,@testforms
       ,newsuite)))

(defmethod add-test ((test test-fixture) (suite test-suite))
  (setf (gethash (test-name test) (tests-hash suite)) test))

(defmethod add-test ((test test-suite) (suite test-suite))
  (setf (gethash (test-suite-name test) (tests-hash suite)) test))

(defmethod remove-test ((test test-fixture) (suite test-suite))
  (remhash (test-name test) (tests-hash suite)))

(defmethod remove-test ((test test-suite) (suite test-suite))
  (remhash (test-suite-name test) (tests-hash suite)))

(defmethod test-named ((name string) (suite test-suite))
  (gethash name (tests-hash suite)))

(defmethod setup-testsuite-named (name)
  (declare (ignore name))
  t)

(defmethod teardown-testsuite-named (name)
  (declare (ignore name))
  t)

(defmethod run-test ((suite test-suite) &key (handle-errors t))
  (setup-testsuite-named (slot-value suite 'name))
  (let ((res (mapcar (lambda (test) (run-test test
                                              :handle-errors handle-errors))
                     (tests suite))))
    (teardown-testsuite-named (slot-value suite 'name))
    res))


(defclass test-result ()
  ((start-time
    :initarg :start-time
    :reader start-time)
   (stop-time
    :initarg :stop-time
    :reader stop-time)
   (test
    :initarg :test
    :reader result-test)
   (failures
    :initarg :failures
    :reader test-failures
    :initform nil)
   (errors
    :initarg :errors
    :reader test-errors
    :initform nil))
  (:documentation
   "The result of applying a test"))

(defmethod report-result ((result test-result) &key (stream t) (verbose nil) (showsuccess nil) (showerrors t) (showfailures t) (showdescriptions nil))
  "Print out a test-result object for a report to STREAM, default to
standard-output.  If VERBOSE is non-nil then will produce a lengthy
and informative report, also sets SHOWSUCCESS and SHOWDESCRIPTIONS.
If SHOWSUCCESS is NIL, prints nothing for tests that succeed.
If SHOWERRORS is non-NIL, prints the test name and the error for tests that errored.
If SHOWFAILURES is non-NIL, prints the test name and the failure for tests that failed.
If SHOWDESCRITPIONS is non-NIL, prints a description with each test that is printed."
  (if verbose
    (progn
      (setf showsuccess t)
      (setf showdescriptions t)
    ))

  (if (or showsuccess (test-failures result) (test-errors result))
    (progn
      (if verbose (format stream
		      "------------------------------------------------------~%"))

      (format stream "Test ~A ~A ~%"
	  (test-name (result-test result))
	  (cond
	   ((test-failures result) "Failed")
	   ((test-errors result) "Errored")
	   (t "Passed")))

      (if showdescriptions (format stream "Description: ~A~%" (description (result-test result))))

      (if (and showfailures (test-failures result))
	    (progn
	      (if verbose (format stream "Failures:~%"))
	      (mapcar #'(lambda (fail) (format stream "    ~A~%" fail))
		      (test-failures result))))

      (if (and showerrors (test-errors result))
	    (progn
	      (if verbose (format stream "Errors:~%"))
	      (mapcar #'(lambda (fail) (format stream "    ~A~%" fail))
		      (test-errors result))))

      (format stream "~%")

  ))

  (not (or (test-failures result) (test-errors result)))
)

(defmethod report-result ((results list) &key (stream t) (verbose nil))
  (dolist (foo results)
    (report-result foo :stream stream :verbose verbose)))

; Display a summary of the number of successful tests, the total number of tests,
; and the percentage of success.  Returns T if all tests succeeded, NIL otherwise.
(defun test-summary (results)
  (multiple-value-bind (successes failures)
      (count-results results)
    (let ((ntests (+ successes failures)))
      (format t "~A/~A tests succeeded (~5,1f%), ~A failed~%"
	    successes
	    ntests
	    (* 100 (/ successes ntests))
            failures)
    ) 
    (= failures 0)
  )
)

; COUNT-RESULTS processes the return value from RUN-TEST
;
; Returns the number of successes and failures respectively
; as a multiple values list
(defun count-results (results &optional (successes 0) (failures 0))

  (cond ((null results) (values successes failures))
        ((listp (car results)) (multiple-value-bind (carsucc carfail) (count-results (car results) successes failures)
	     (multiple-value-bind (cdrsucc cdrfail) (count-results (cdr results) successes failures)
	       (values (+ carsucc cdrsucc) (+ carfail cdrfail))
	       )))
        ((or (test-failures (car results)) (test-errors (car results)))
	   (count-results (cdr results) successes (+ failures 1)))
        (t (count-results (cdr results) (+ successes 1) failures))
))