;;; A test framework similar to Kent Beck's Smalltalk version.

;;; Copyright (c) 1999 Matthias Hölzl, all rights reserved

;;; Test-suites are defined with (define-test-suite), test-cases can
;;; be added with ADD-TEST or (more concisely) with ADD-TESTS.  The
;;; tests can then be run with RUN-ALL-KNOWN-TESTS (which runs all
;;; test-suites) or with RUN-TESTS (which runs an individual test
;;; suite).  You may want to look at the file run-tests.lisp for
;;; example uses.

(defpackage "TEST-FRAMEWORK"
  (:nicknames "TF")
  (:use "COMMON-LISP")
  (:export "TEST" "TEST-SUITE"
	   "TEST-SUITE-ID" "TEST-SUITE-TESTS"
	   "GENERAL-TEST-CASE" "EMPTY-TEST-CASE" "TEST-CASE"
	   "TEST-CASE-DESCRIPTION" "TEST-CASE-TEST"
	   "DEFINE-TEST-FUNCTION"
	   
	   "DEFINE-TEST-SUITE"
	   "TEST-SUITES" "TEST-SUITE"
	   "SET-UP-TEST" "TEAR-DOWN-TEST"
	   "ADD-TEST" "ADD-TESTS"
	   "*TRACE-ADD-TESTS*"

	   "TEST-RESULT"
	   "TEST-RESULT-TEST-SUITE"
	   "NR-OF-TESTS" "NR-OF-FAILURES" "FAILED-TESTS"
	   
	   "TEST-RUNNER"
	   "RUN-ALL-TESTS" "RUN-ALL-KNOWN-TESTS"

	   "NUKE-ALL-TESTS"
	   
	   "TEST-FAILURE" "VALUE-TEST-FAILURE"
	   "EXPECTED-VALUE" "RECEIVED-VALUE"
	   "FAIL-TEST" "FAIL-VALUE-COMPARISON"
	   "EXPECT" "EXPECT-TRUE" "EXPECT-FALSE"
	   "EXPECT-SUBTYPE" "EXPECT-INSTANCE"
	   "EXPECT-EXCEPTION"
	   
	   "UNEXPECTED-FAILURE" "*BREAK-ON-UNEXPECTED-ERRORS*"

	   "RUN-TESTS" "RUN-TEST-CASE"
	   "PRINT-TEST-SUMMARY"
	   "PRINT-TEST-FAILURES" "PRINT-FAILURE"))

(in-package "TEST-FRAMEWORK")

;;; Tests

(defclass test () ())

(defclass general-test-case (test) ())

(defclass empty-test-case (general-test-case) ())

(defclass test-case (general-test-case)
  ((test-case-description :reader test-case-description
			  :initarg :description)
   (test-case-test :reader test-case-test
		   :initarg :test)))

(defvar *current-test-case* (make-instance 'empty-test-case))

(defmacro define-test-function (name (&rest args) &body body)
  (let ((test-case (gensym)))
    `(defun ,name ,args
       (lambda (,test-case)
	 (declare (ignorable ,test-case))
	 ,@body))))

(defclass test-suite (test)
  ((test-suite-id :reader test-suite-id :initarg :id)
   (test-suite-tests :accessor test-suite-tests :initform '())))

(defvar *test-suites* (make-hash-table))

(defun test-suites ()
  *test-suites*)

(defun test-suite (id &key (default nil))
  (gethash id *test-suites* default))

(defun (setf test-suite) (new-value id)
  (setf (gethash id *test-suites*) new-value))

(defmethod initialize-instance :after ((self test-suite) &rest initargs)
  (declare (ignorable initargs))
  (setf (test-suite (test-suite-id self)) self))

(defmacro define-test-suite (name)
  `(make-instance 'test-suite :id ',name))

;;; Setting up and tearing down tests.

(defgeneric set-up-test (test))

(defmethod set-up-test ((test test)))

(defgeneric tear-down-test (test))

(defmethod tear-down-test ((test test)))

;;; Adding new tests.

(declaim (special *trace-add-tests*))
(defvar *trace-add-tests* nil)

(defmethod mumble-add-test ((test test))
  (when *trace-add-tests*
    (format t "~&Adding test:~:_ ~W.~%" test)))

(defmethod mumble-add-test ((test test-case))
  (when *trace-add-tests*
    (format t "~&Adding test-case~:_ ~W,~:_ ~W.~%"
	    (test-case-description test)
	    (test-case-test test))))

(defmethod mumble-add-test ((test test-suite))
  (when *trace-add-tests*
    (format t "~&Recursively adding test-suite~:_ ~W,~:_ length ~W.~%"
	    (test-suite-id test)
	    (length (test-suite-tests test)))))

(defgeneric add-test (test-suite-designator test))

(defmethod add-test ((test-suite test-suite) (test test))
  (mumble-add-test test)
  (push test (test-suite-tests test-suite))
  test-suite)

(defmethod add-test ((test-suite-name symbol) (test test))
  (let ((test-suite (test-suite test-suite-name)))
    (if test-suite
	(add-test test-suite test)
      (warn "No test suite named ~A." test-suite-name))))

(defun add-tests (test-suite test-class &rest tests)
  (cond ((null tests) nil)
	(t (destructuring-bind (description test-fun &rest rest)
	       tests
	     (add-test test-suite
		       (make-instance test-class
			   :description description :test test-fun))
	     (apply #'add-tests test-suite test-class rest)))))

;;; Handling errors in tests.

(define-condition test-failure (warning)
  ((runner :reader runner :initarg :runner)
   (test-case :reader test-case :initarg :test-case))
  (:report print-test-failure))

(defun print-test-failure (condition stream)
  (format stream "Failed test ~S."
	  (test-case-description (test-case condition))))

(define-condition value-test-failure (test-failure)
  ((expected-value :reader expected-value :initarg :expected)
   (received-value :reader received-value :initarg :got))
  (:report print-value-test-failure))

(defun print-value-test-failure (condition stream)
  (format stream "Failed test~:_ ~S~:_ (expected ~S, got ~S)."
	  (test-case-description (test-case condition))
	  (expected-value condition)
	  (received-value condition)))

(define-condition subtype-test-failure (value-test-failure)
  ()
  (:report print-subtype-test-failure))

(defun print-subtype-test-failure (condition stream)
  (format stream
	  "Failed test ~S~:_ (expected a subtype of ~S,~:_ got ~S)."
	  (test-case-description (test-case condition))
	  (expected-value condition)
	  (received-value condition)))

(define-condition instance-test-failure (value-test-failure)
  ()
  (:report print-instance-test-failure))

(defun print-instance-test-failure (condition stream)
  (format stream
	  "Failed test ~S~:_ (expected an instance of ~S,~:_ got ~S)."
	  (test-case-description (test-case condition))
	  (expected-value condition)
	  (received-value condition)))

(defgeneric fail-test (test-case))

(defmethod fail-test ((test-case empty-test-case))
  (warn "Cannot fail empty test-case."))

(declaim (special *current-runner*))

(defmethod fail-test ((test-case test-case))
  (warn 'test-failure
	:runner *current-runner*
	:test-case test-case))

(defgeneric fail-value-comparison (test-case expected got))

(defmethod fail-value-comparison
    ((test-case empty-test-case) expected got)
  (declare (ignore expected got))
  (warn "Cannot compare values in empty test case."))

(defmethod fail-value-comparison
    ((test-case test-case) expected got)
  (warn 'value-test-failure
	:runner *current-runner* :test-case test-case
	:expected expected :got got))

(defun fail-subtype-test (test-case expected got)
  (warn 'subtype-test-failure
	:runner *current-runner* :test-case test-case
	:expected expected :got got))

(defun fail-instance-test (test-case expected got)
  (warn 'instance-test-failure
	:runner *current-runner* :test-case test-case
	:expected expected :got got))

(defun expect (test-result expected-value &key (test #'eql))
  (unless (funcall test test-result expected-value)
    (if (member test (list #'eq #'eql #'equal #'equalp #'=))
	(fail-value-comparison *current-test-case*
			       expected-value test-result)
      (fail-test *current-test-case*))))

(defun expect-true (object)
  (unless object
    (fail-test *current-test-case*)))

(defun expect-false (object)
  (when object
    (fail-value-comparison *current-test-case* nil object)))

(defun expect-subtype (test-result expected-type)
  (multiple-value-bind (subtype? known?)
      (subtypep test-result expected-type)
    (unless (or subtype? (not known?))
      (fail-subtype-test
       *current-test-case* expected-type test-result))))

(defun expect-instance (test-result expected-class)
  (unless (typep test-result expected-class)
    (fail-instance-test
     *current-test-case* expected-class test-result)))

(defmacro expect-exception ((exception) &body body)
  `(handler-case
    (progn
      ,@body
      (fail-test *current-test-case*))
    (,exception ())))

;;; Unexpected failures.

(define-condition unexpected-failure (warning)
  ((original-exception :reader original-exception
		       :initarg :original-exception)))

(defun note-failure (failure runner)
  (incf (nr-of-failures runner))
  (push failure (failed-tests runner)))

(defmethod register-failed-test (failure)
  (note-failure failure (runner failure)))

(defmethod register-unexpected-failure ((failure condition))
  (let ((new-failure (make-condition 'unexpected-failure
				     :original-exception failure)))
    (register-unexpected-failure new-failure)))

(defmethod register-unexpected-failure ((failure unexpected-failure))
  (note-failure failure *current-runner*))

;;; Verbosity.

(defvar *test-suite-verbosity* :verbose)

(declaim (type (member :silent :progress-only :verbose :gabby)
	       *test-suite-verbosity*))

;;; Test Results.

(defclass test-result ()
  ((test-result-test-suite :reader test-result-test-suite :initarg :suite)
   (nr-of-tests :reader nr-of-tests :initarg :nr-of-tests)
   (nr-of-failures :reader nr-of-failures :initarg :nr-of-failures)
   (failed-tests :reader failed-tests :initarg :failed-tests)))

;;; Printing (part I)

(defgeneric print-failure (failure))

(defmethod print-failure ((failure test-failure))
  (fresh-line)
  (print-test-failure failure t))

(defmethod print-failure ((failure value-test-failure))
  (fresh-line)
  (print-value-test-failure failure t))

(defmethod print-failure ((failure instance-test-failure))
  (fresh-line)
  (print-instance-test-failure failure t))

(defmethod print-failure ((failure unexpected-failure))
  (let ((original (original-exception failure)))
    (format t "~&Unexpected error: ~A~%" original)))

(defgeneric print-test-failures (test-result))

(defmethod print-test-failures ((test-result test-result))
  (dolist (failure (failed-tests test-result))
    (print-failure failure)))

(defun maybe-print-test-suite-header (test-suite)
  (case *test-suite-verbosity*
    ((:gabby)
     (format t "~&*** Running test-suite ~A ***~%"
	     (test-suite-id test-suite)))
    ((:silent))
    (otherwise
     (format t "~&~A~%" (test-suite-id test-suite)))))

(defun maybe-print-test-suite-trailer (test-suite)
  (when (eql *test-suite-verbosity* :gabby)
    (format t "~&--- Done with test suite ~A ---~%"
	    (test-suite-id test-suite))))

(defun print-test-summary (test-result)
  (print-test-summary-using-verbosity test-result *test-suite-verbosity*)
  (force-output *standard-output*))

(defgeneric print-test-summary-using-verbosity (test-result verbosity))

(defmethod print-test-summary-using-verbosity
  ((test-result test-result) (vebosity (eql :silent))))

(defmethod print-test-summary-using-verbosity
    ((test-result test-result) (verbosity (eql :progress-only)))
  (format t "~&~A test~:P, ~A failure~:P~%"
	  (nr-of-tests test-result) (nr-of-failures test-result)))
    
(defmethod print-test-summary-using-verbosity
    ((test-result test-result) (verbosity (eql :verbose)))
  (format t "~&~A test~:P, ~A failure~:P~%"
	  (nr-of-tests test-result) (nr-of-failures test-result))
  (print-test-failures test-result))

(defmethod print-test-summary-using-verbosity
    ((test-result test-result) (verbosity (eql :gabby)))
  (cond ((zerop (nr-of-failures test-result))
	 (format t "~&>>> ~A test~:P completed without errors. <<<~%"
		 (nr-of-tests test-result)))
	((= (nr-of-failures test-result) 1)
	 (format t "~&!!! There was one failure !!!~%")
	 (print-test-failures test-result))
	(t
	 (format t "~&!!! There were ~A failures !!!~%"
		 (nr-of-failures test-result))
	 (print-test-failures test-result))))

;;; Runners.

(defclass general-test-runner () ())

(defclass empty-test-runner (general-test-runner) ())

(defclass test-runner (general-test-runner)
  ((runner-test-suite :reader runner-test-suite
		      :initarg :test-suite)
   (current-test :accessor current-test :initform 0)
   (nr-of-failures :accessor nr-of-failures :initform 0)
   (failed-tests :accessor failed-tests :initform '())))

(defvar *current-runner* (make-instance 'empty-test-runner))

(defgeneric run-all-tests (suite-or-runner))

(defmethod run-all-tests ((runner empty-test-runner)))

(defmethod run-all-tests ((runner test-runner))
  (setf *current-runner* runner)
  (let ((suite (runner-test-suite runner)))
    (maybe-print-test-suite-header suite)
    (run-tests suite runner)
    (maybe-print-test-suite-trailer suite))
  (let ((result (make-instance 'test-result
			       :suite (runner-test-suite runner)
			       :nr-of-tests (current-test runner)
			       :nr-of-failures (nr-of-failures runner)
			       :failed-tests (reverse (failed-tests runner)))))
    (print-test-summary result)
    result))

(defmethod run-all-tests ((suite test-suite))
  (let ((runner (make-instance 'test-runner
			       :test-suite suite)))
    (run-all-tests runner)))

(defmethod run-all-tests ((suite-name symbol))
  (let ((suite (test-suite suite-name)))
    (if suite
	(run-all-tests suite)
      (progn
	(warn "No test suite named ~A." suite-name)
	(make-instance 'test-suite :id suite-name)))))

(defun run-all-known-tests (&optional (verbosity nil))
  (let ((*test-suite-verbosity* (or verbosity *test-suite-verbosity*))
	(results ()))
    (maphash
     (lambda (key test-suite)
       (declare (ignore key))
       (push (run-all-tests test-suite) results))
     (test-suites))
    results))

(defmethod mumble-passed-test ((test-case empty-test-case))
  (case *test-suite-verbosity*
    ((:gabby)
     (format t "~&Passed empty test~%"))
    ((:silent))
    (otherwise
     (princ "."))))

(defmethod mumble-passed-test ((test-case test-case))
  (case *test-suite-verbosity*
    ((:gabby)
     (format t "~&Passed test ~S.~%" (test-case-description test-case)))
    ((:silent))
    (otherwise
     (princ "."))))

(defun mumble-failed-test (test-case)
  (case *test-suite-verbosity*
    ((:gabby)
     (format t "~&>Failed test~:_ ~S.~%" (test-case-description test-case)))
    ((:silent))
    (otherwise
     (princ "F"))))

(defun mumble-unexpected-error (test-case)
  (case *test-suite-verbosity*
    ((:gabby)
     (format t "~&>Unexpected error in test~:_ ~S.~%"
	     (test-case-description test-case)))
    ((:silent))
    (otherwise
     (princ "E"))))

(defgeneric run-test-case (test-case runner))

(defmethod run-test-case ((test-case general-test-case) (runner test-runner))
  (incf (current-test runner)))

(defmethod run-test-case ((test-case empty-test-case) (runner test-runner))
  (call-next-method)
  (mumble-passed-test test-case))

(declaim (special *break-on-unexpected-errors*))
(defvar *break-on-unexpected-errors* nil)

(defmethod run-test-case ((test-case test-case) (runner test-runner))
  (setf *current-test-case* test-case)
  (call-next-method)
  (handler-case
   (unwind-protect
       (progn
	 (set-up-test test-case)
	 (let ((test-fun (test-case-test test-case)))
	   (funcall test-fun test-case))
	 (mumble-passed-test test-case))
     (tear-down-test test-case))
   (test-failure (failure)
     (register-failed-test failure)
     (mumble-failed-test test-case))
   (condition (failure)
     (cond (*break-on-unexpected-errors*
	    (break))
	   (t
	    (register-unexpected-failure failure)
	    (mumble-unexpected-error test-case))))))

(defgeneric run-tests (test runner))

(defmethod run-tests ((test general-test-case) (runner test-runner))
  (run-test-case test runner))

(defmethod run-tests ((test test-suite) (runner test-runner))
  (let ((tests (reverse (test-suite-tests test))))
    (dolist (test tests)
      (run-tests test runner))))

;;; Resetting the framework.

(defun nuke-all-tests ()
  (setf *current-test-case* (make-instance 'empty-test-case))
  (setf *test-suites* (make-hash-table))
  (setf *current-runner* (make-instance 'empty-test-runner))
  'tests-nuked)