;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; ID:      $Id: suite.lisp,v 1.4 2003/08/04 16:42:27 kevin Exp $
;;;; Purpose: Suite functions for XLUnit
;;;;
;;;; *************************************************************************

(in-package #:xlunit)

(defclass test-suite ()
  ((name :initform "" :initarg :name :reader test-suite-name)
   (tests :initarg :tests :accessor tests :initform nil)
   (description :initarg :description :reader description
		:initform "No description.")))

(defmacro get-suite (class-name)
  `(suite (make-instance ',class-name)))
 

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

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

(defmethod run-on-test ((suite test-suite)
		     &key (result (make-instance 'test-result))
		     (handle-errors t))
  (setup-testsuite-named (slot-value suite 'name))
  (dolist (test (tests suite))
    (run-on-test test :result result :handle-errors handle-errors))
  (teardown-testsuite-named (slot-value suite 'name))
  result)


(defmethod add-test ((ob test-suite) (new-test test))
  (setf (tests ob)
        (delete-if #'(lambda (existing-tests-or-suite)
                       (cond ((typep existing-tests-or-suite 'test-suite)
                              (eq existing-tests-or-suite new-test))
                             ((typep existing-tests-or-suite 'test-case)
                              (eql (name existing-tests-or-suite)
                                   (name new-test)))))
                   (tests ob)))
  (setf (tests ob) (append (tests ob) (list new-test))))

#|
(defmethod remove-test ((test test-case) (suite test-suite))
  (remhash (name test) (tests-hash suite)))

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

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

;; Dynamic test suite

(defun make-test-suite-for-fixture 
    (fixture &key
	     (name 
	      (format nil "Automatic for ~A"
		      (if (slot-boundp fixture 'name) 
			  (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 (class-name (class-of fixture)) 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)
      (when (and (> (length (symbol-name s)) 5)
		 (string-equal "test-" (subseq (symbol-name s) 0 5))
		 (fboundp s)
		 (typep (symbol-function s) 'generic-function)
		 (ignore-errors
		   (plusp (length (compute-applicable-methods 
				   (ensure-generic-function s)
				   (list instance))))))
	(push s res)))
    (nreverse res)))


;----------------------------------------------------------------------
; macro def-test-method
;
; Creates the representation of a test method (included within a
; test-case object) and add it to the corresponding suite class.
; => clos version of the pluggable selector pattern
;
; use:  (def-test-method test-assert-false (clos-unit-test)
;          (assert-true (eql (+ 1 2) 4) "comment"))
;
; new: it calls the textui-test-run function during eval, so to
;      allow the usual lisp-like incremental developing and test.
;----------------------------------------------------------------------
                                                                                 
(defmacro def-test-method (method-name class-name &body method-body)
  `(let ((,(caar class-name)
          (make-instance ',(cadar class-name)
            :name ',method-name)))
     (setf (method-body ,(caar class-name))
           #'(lambda() ,@method-body))
     (add-test (suite ,(caar class-name)) ,(caar class-name))
     (textui-test-run ,(caar class-name))))