;;; -*- 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.3 2003/04/19 16:16:16 kevin Exp $

(in-package #:cl-user)

(defpackage #:xp-test-framework
  (:use #:common-lisp)
  (:nicknames #:xp-test #:xptest)
  (:export
     ;;; Framework classes
   #:setup
   #:teardown
   #:perform-test
   #:test-failure
   #:failure
   #:run-test
   #:def-test-fixture
   #:make-test-case
   #:make-test-suite
   #:setup-testsuite-named
   #:teardown-testsuite-named
   #:add-test
   #:test-named
   #:remove-test
   #:tests
   #:test-result
   #:report-result
   )
  (:documentation "This is the XP TestSuite Framework."))

(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 openmcl) :format-control
	  #-(or cmu allegro openmcl) :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))
  "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, otherwise just prints wether the test passed
or failed or errored out."
  (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 verbose
      (progn
	(format stream "Description: ~A~%" (description (result-test result)))
	(if (test-failures result)
	    (progn
	      (format stream "Failures:~%")
	      (mapcar #'(lambda (fail) (format stream "    ~A" fail))
		      (test-failures result))))
	(if (test-errors result)
	    (progn
	      (format stream "Errors:~%")
	      (mapcar #'(lambda (fail) (format stream "    ~A" fail))
		      (test-errors result))))))
  (format stream "~%~%"))

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