テストツールその2

関数を簡単にテストするなら、このくらい単純で良いような気もしました。

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

;; clause -> ((arg1 arg2 ... ) result) = ((arg1 arg2 ... ) :eq result)
;; clause -> ((arg1 arg2 ... ) :not result)
;; clause -> ((arg1 arg2 ... ) :test test-fn)
(defparameter *test-report-function*
  #'(lambda (fn-name args expected actual)
      (format t "TEST FAILED. Form: (~A ~{~A~^ ~}), Expected: ~A, Actual: ~A~%"
	      fn-name args expected actual)))

(defmacro deftest (fn-name &body clauses)
  (let ((sym (gensym)))
    (labels
	((expander (clause)
	   (let ((result-spec (cdr clause))
		 (test-fn-form `(,fn-name ,@(car clause))))
	     (when (= (length result-spec) 1)
	       (setf result-spec (cons :eq result-spec)))
	     `(let ((,sym ,test-fn-form))
		,(let ((report-form `(funcall *test-report-function*
					      ',fn-name
					      ',(car clause)
					      ',result-spec
					      ,sym)))
		      (case (car result-spec)
			((:eq)
			 `(unless (eq ,sym ,(second result-spec))
			    ,report-form))
			((:eql)
			 `(unless (eql ,sym ,(second result-spec))
			    ,report-form))
			((:equal)
			 `(unless (equal ,sym ,(second result-spec))
			    ,report-form))
			((:not :not-eq)
			 `(when (eq ,sym ,(second result-spec))
			    ,report-form))
			((:not-eql)
			 `(when (eql ,sym ,(second result-spec))
			    ,report-form))
			((:not-equql)
			 `(when (equal ,sym ,(second result-spec))
			    ,report-form))
			((:test)
			 `(unless (funcall ,(second result-spec) ,sym)
			    ,report-form))
			(T (error "invalid test result keyword"))))))))
      `(setf (gethash ',fn-name *test-function-table*)
	     (lambda ()
	       ,@(mapcar #'expander clauses))))))

(defun run-test (fn-name)
  (multiple-value-bind (test-fn ?) (gethash fn-name *test-function-table*)
    (when ?
      (funcall test-fn))))

(defun run-test-all ()
  (maphash
   #'(lambda (key val)
       (when (functionp val)
	 (format t "TEST START : ~A~%" key)
	 (funcall val)))
   *test-function-table*))

;; example
(deftest length
   (('(1 2 3)) 3)
   ((#(1 2)) 2))
(deftest oddp
   ((2) :not-eq t)
   ((3) :eq t))
(deftest symbol-name
   ((:a) :equal "A")
   (('hoge) :equal "hoge"))

(run-test-all)
;; TEST START : LENGTH
;; TEST START : ODDP
;; TEST START : SYMBOL-NAME
;; TEST FAILED. Form: (SYMBOL-NAME 'HOGE), Expected: (EQUAL hoge), Actual: HOGE