;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:        src.lisp
;;;; Purpose:     eXtreme Lisp Test Suite
;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
;;;;
;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
;;;; $Id: src.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
;;;; *************************************************************************

(in-package #:xltest)


(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
	  :format-control format-str
	  :format-arguments args))

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

(defun assert-equal (v1 v2)
  (unless (equal v1 v2)
    (failure "Test equals failed: ~s ~s" v1 v2)))

(defun assert-true (v)
  (unless v
    (failure "Test true failed: ~s" v)))

(defun assert-false (v)
  (when v
    (failure "Test false failed")))


(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 ((failures ())
	(errs ()))
    (unwind-protect-if handle-errors
	(handler-case-if handle-errors
	 (let ((res (progn (setup test)
			   (funcall (test-thunk test) 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
		   :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))

(defun make-test-case (name fixture &key
				    (test-thunk 'perform-test)
				    (test-suite nil)
				    (description nil))
  "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 (make-instance fixture
		   :test-name name
		   :test-thunk 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)))

(defun make-test-suite (name-or-fixture &optional description testspecs)
  "Returns a new test-suite based on a name and TESTSPECS or a fixture
instance"
  (etypecase name-or-fixture
    (symbol
     (make-test-suite-for-fixture (make-instance name-or-fixture)))
    (string
     (let ((suite (make-instance 'test-suite :name name-or-fixture
				 :description description)))
       (dolist (testspec testspecs)
	 (add-test (apply #'make-test-case testspec) suite))
       suite))))

(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))
  (let ((start-time (get-internal-real-time)))
    (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))
      (make-instance 'suite-results 
	:suite suite
	:test-results res
	:start-time start-time
	:stop-time (get-internal-real-time)))))


(defclass test-result ()
  ((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"))

(defclass suite-results ()
  ((suite :initarg :suite :reader suite)
   (start-time :initarg :start-time :reader start-time)
   (stop-time :initarg :stop-time :reader stop-time)
   (test-results :initarg :test-results :reader test-results))
  (:documentation "Results of running a suite"))


(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."
  (when (or verbose (test-failures result) (test-errors result))
    (when verbose
      (format stream
	      "------------------------------------------------------~%"))
    (format stream "~A~A"
	    (test-name (result-test result))
	    (cond
	     ((test-failures result) ":")
	     ((test-errors result) ":")
	     (t ": Passed")))
    (when (test-failures result)
      (format stream " Failures: ~{~A~^; ~}" (test-failures result)))
    (when (test-errors result)
      (format stream " Errors: ~{~A~^; ~}" (test-errors result)))
    (fresh-line stream)
    (when verbose
      (when (description (result-test result))
	(format stream "Description: ~A~%" 
		(description (result-test result)))))))
  
(defmethod report-result ((results suite-results) &key (stream t)
						       (verbose nil))
  (format stream "~&.............~%")
  (format stream "~&Time: ~D~%" 
	  (float
	   (/ (- (stop-time results) (start-time results))
	      internal-time-units-per-second)))
  (if (some (lambda (res) (or (test-failures res) (test-errors res)))
	    (test-results results))
      (dolist (foo (test-results results))
	(report-result foo :stream stream :verbose verbose))
    (format stream "~&OK (~D tests)~%" (length (test-results results)))))


;;; Dynamic test suite addition by Kevin Rosenberg 8/2003

(defun make-test-suite-for-fixture 
    (fixture &key
	     (name 
	      (format nil "Automatic for ~A"
		      (if (slot-boundp fixture 'test-name) 
			  (test-name fixture)
			(type-of fixture))))
	     description)
  (let ((suite  (make-instance 'test-suite
		  :name name
		  :description description))
	(fns (find-test-generic-functions fixture)))
    (dolist (fn fns)
      (make-test-case fn (class-name (class-of fixture))
		      :test-thunk fn
		      :test-suite suite))
    suite))

(defun find-test-generic-functions (instance)
  "Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'.
This is used to dynamically generate a list of tests for a fixture."
  (let ((res)
	(package (symbol-package (class-name (class-of instance)))))
    (do-symbols (s package)
      (multiple-value-bind (sym status)
	  (find-symbol (symbol-name s) package)
	(when (and (or (eq status :external)
		       (eq status :internal))
		   (fboundp sym)
		   (eq (symbol-package sym) package)
		   (> (length (symbol-name sym)) 5)
		   (string-equal "test-" (subseq (symbol-name sym) 0 5))
		   (typep (symbol-function sym) 'generic-function)
		   (plusp 
		    (length 
		     (compute-applicable-methods 
		      (ensure-generic-function sym)
		      (list instance)))))
	  (push sym res))))
    (nreverse res)))