ユニットテストの記法を考える

しばらくテストばかりしていたせいか、 Common Lispを触っているときもテストネタについて考えています。

Common Lispには既にかなりの数のユニットテストツールがありますが、車輪の再開発上等というか、自分で考えるのも良いだろうということで、括弧の数を減らすような書き方を考えてみました。

(defpackage net.phorni.unittest
  (:use :cl)
  (:nicknames :ut)
  (:export
   test
   run-test))

(in-package :net.phorni.unittest)

(defparameter *test-table* (make-hash-table))

;;;; condition
(define-condition <assertion-result> (simple-condition)
  ((form :accessor form-of :initarg :form)
   (assert-form :accessor assert-form-of :initarg :assert-form)
   (actual :accessor actual-of :initarg :actual)
   (test-case-name :accessor test-case-name-of :initarg :test-case-name)
   (test-name :accessor test-name-of :initarg :test-name)
   (result-type :accessor result-type-of :initarg :result-type)))

(define-condition <setup-error> (simple-condition)
  ((test-case-name :accessor test-case-name-of :initarg :test-case-name)
   (test-name :accessor test-name-of :initarg :test-name)
   (setup-type :accessor setup-type-of :initarg :setup-type)))

;;;; utility
(defmacro while (test &body body)
  `(loop
      :while ,test
      :do ,@body))

(defun symb (&rest xs)
  (values (intern (format nil "~{~A~}" xs))))

(defun collect-clauses (name lists)
  (mapcar
   #'cdr
   (remove-if-not
    #'(lambda (x)
	(and (listp x)
	     (symbolp (car x))
	     (eq (car x) name)))
    lists)))

(defun merge-clauses (name lists)
  (apply 'append
	 (collect-clauses name lists)))

(defun flatten (tree)
  (labels ((flatten% (x acc)
	     (if (atom x)
		 (cons x acc)
		 (if (null (cdr x))
		     (flatten% (car x) acc)
		     (flatten% (cdr x) (flatten% (car x) acc))))))
    (nreverse (flatten% tree nil))))

(defun at-symbol? (x)
  (and (symbolp x)
       (let ((name (symbol-name x)))
	 (and (< 1 (length name))
	      (char= #\@ (char name 0))))))

;;;; report
(defparameter *count* 0)
(defparameter *ng* 0)

(defun report (a)
  (let ((result-type (result-type-of a))
	(test-name (test-name-of a))
	(test-case-name (test-case-name-of a)))
    (incf *count*)
    (unless (eq :success result-type) (incf *ng*))
    (format t "~A : ~A => ~A~%"
	    test-name
	    test-case-name
	    result-type)))

(defun report-done ()
  (format t
	  "test: ~a, success: ~a, failure: ~a~%"
	  *count*
	  (- *count* *ng*)
	  *ng*))

(defvar *report-function-success* 'report)
(defvar *report-function-failure* 'report)
(defvar *report-function-error* 'report)
(defvar *report-function-done* 'report-done)


;;;; run test
(defun run-test (name)
  (let ((fn (gethash name *test-table*)))
    (when (functionp fn)
      (handler-bind
	  ((<assertion-result>
	    #'(lambda (a)
		(funcall
		 (case (result-type-of a)
		   (:success *report-function-success*)
		   (:failure *report-function-failure*)
		   (:error *report-function-error*)
		   (t #'identity))
		 a))))
	(funcall fn)))
    (funcall *report-function-done*)))

;;;; test macro
(defmacro test (test-name &body body)
  (let ((body (convert-syntax body)))
    (let ((before  (merge-clauses :before body))
	  (before-all (merge-clauses :before-all body))
	  (after (merge-clauses :after body))
	  (after-all (merge-clauses :after-all body))
	  (test-case-list (collect-clauses :case body))
	  (vars
	   (remove-duplicates (remove-if-not 'at-symbol? (flatten body))))
	  (after-sym (gensym))
	  (before-sym (gensym)))
      `(progn
	 (setf (gethash ',test-name *test-table*)
	       (lambda ()
		 (let ,vars
		   ,@before-all
		   (labels ((,after-sym () ,@(if after after (list nil)))
			    (,before-sym () ,@(if before before (list nil))))
		     ,@(mapcar
			#'(lambda (test-case)
			    `(test-case
				 ,test-name
				 ,(car test-case)
				 ,before-sym ,after-sym
			       ,@(cdr test-case)))
			test-case-list))
		   ,@after-all)))))))

(defun convert-syntax (body)
  (let ((rest (copy-tree body))
	(result nil))
    (while rest
      (let ((form (pop rest)))
	(push
	 (case form
	   (#1=(:before :before-all :after :after-all :case)
	       `(,form
		 ,@(let ((pos
			  (position-if
			   (lambda (x)
			     (find x '#1#))
			   rest)))
			(unless pos
			  (setf pos (length rest)))
			(prog1
			    (subseq rest 0 pos)
			  (setf rest (nthcdr pos rest))))))
	   (t
	    (error "syntax error")))
	 result)))
    (nreverse result)))

(defmacro test-case (test-name test-case-name before-fn after-fn &body body)
  (let ((sym (gensym)))
    (labels ((setup-form (fn type)
	       `(handler-case (,fn)
		  (t (,sym) (declare (ignore ,sym))
		     (error 'net.phorni.unittest::<setup-error>
			     :setup-type ,type
			     :test-name ',test-name
			     :test-case-name ',test-case-name)
		     (go :end-of-test-case)))))
      `(tagbody
	  ,(setup-form before-fn :before)
	  ,(parse-test-case-body test-name test-case-name body)
	  ,(setup-form after-fn :after)
	:end-of-test-case))))

(defun parse-test-case-body (test-name test-case-name body)
  (let ((form (car body))
	(assertion-type nil)
	(rest (copy-list (cdr body)))
	(result-sym (gensym))
	(arg-sym (gensym)))

    (setf assertion-type (intern (symbol-name (pop rest))))

    (if (eq assertion-type (intern "THROW"))
	(let ((condition (pop rest)))
	  `(handler-case
	       (let ((,arg-sym ,form))
		 (signal
		  'net.phorni.unittest::<assertion-result>
		  :form ',form
		  :assert-form '(:catch ,condition)
		  :test-name ',test-name
		  :test-case-name ',test-case-name
		  :actual ,arg-sym
		  :result-type :failure))
	     (,condition (,arg-sym)
	       (signal
		'net.phorni.unittest::<assertion-result>
		:form ',form
		:assert-form '(:catch ,condition)
		:test-name ',test-name
		:test-case-name ',test-case-name
		:actual ,arg-sym
		:result-type :success))
	     (t (,arg-sym)
	       (signal
		'net.phorni.unittest::<assertion-result>
		:form ',form
		:assert-form '(:catch ,condition)
		:test-name ',test-name
		:test-case-name ',test-case-name
		:actual ,arg-sym
		:result-type :error))))

	(let ((assertion-form
	       (case assertion-type
		 ((= /= < <= > >= eq eql equal string= string/= char= char/=)
		  `(,assertion-type ,result-sym ,(pop rest)))
		 ((should)
		  `(equal ,result-sym ,(pop rest)))
		 ((should-not)
		  `(not (equal ,result-sym ,(pop rest)))))))
	  `(handler-case (let ((,result-sym ,form))
			   (signal
			     'net.phorni.unittest::<assertion-result>
			     :form ',form
			     :assert-form ',assertion-form
			     :test-name ',test-name
			     :test-case-name ',test-case-name
			     :actual ,result-sym
			     :result-type (if ,assertion-form :success :failure)))
	     (net.phorni.unittest::<assertion-result> (a)
	       (signal a))
	     (t (,arg-sym)
	       (signal
		 'net.phorni.unittest::<assertion-result>
		 :form ',form
		 :assert-form ',assertion-form
		 :test-name ',test-name
		 :test-case-name ',test-case-name
		 :actual ,arg-sym
		 :result-type :error)))))))

;;;; example
#|
(test list
  :before
  (setf @a (list 10 20))

  :case "length"
  (length @a) = 2

  :case "nth-0"
  (nth 0 @a) = 10

  :case "nth-2"
  (nth 2 @a) eq nil

  :case "elt-2"
  (elt @a 2) throw error
  )

(run-test 'list)

|#