しばらくテストばかりしていたせいか、 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)
|#
