2011年4月13日水曜日

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

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

|#

2011年4月10日日曜日

hippie-expandでSLIMEの補完を利用する

モードごとに補完関数を切り替えるelispを書いたので、 Common Lisp編集中にはelisp用のtry-complete-lisp-symbolではなく SLIMEの補完を行えるようなelispも書いてみました。

補完候補を探す箇所以外はほとんどtry-complete-lisp-symbolと違いはありません。

(defun try-complete-slime-symbol (old)
(unless old
(he-init-string (he-lisp-symbol-beg) (point))
(unless (he-string-member he-search-string he-tried-table)
(setq he-tried-table (cons he-search-string he-tried-table)))
(setq he-expand-list
(and (not (equal he-search-string ""))
(sort
(case slime-complete-symbol-function
((slime-simple-complete-symbol)
(get-completions/slime-simple-complete he-search-string))
((slime-fuzzy-completions)
(get-completions/slime-fuzzy-complete-symbol he-search-string))
((slime-complete-symbol*)
(get-completions/slime-complete-symbol*))
(t (error "unexpected slime-complete-symbol-function")))
'string-lessp))))
(while (and he-expand-list
(he-string-member (car he-expand-list) he-tried-table))
(setq he-expand-list (cdr he-expand-list)))
(if (null he-expand-list)
(progn
(when old (he-reset-string))
nil)
(progn
(he-substitute-string (car he-expand-list))
(setq he-expand-list (cdr he-expand-list))
t)))

(defun get-completions/slime-simple-complete-symbol (prefix)
(car (slime-simple-completions prefix)))

(defun get-completions/slime-fuzzy-complete-symbol (prefix)
(car (slime-fuzzy-completions prefix)))


(defun get-completions/slime-complete-symbol* ()
" -> slime-maybe-complete-as-filename , slime-expand-abbreviations-and-complete"
(let ((end (move-marker (make-marker) (slime-symbol-end-pos)))
(beg (move-marker (make-marker) (slime-symbol-start-pos))))
(let ((completions (slime-contextual-completions beg end)))
(car completions))))

2011年4月1日金曜日

hippie-expandの略語展開関数をmodeごとに指定する

Emacsの補完機能の一つにhippie-expandというものがあります。

hippie-expandは補完用関数のリストを設定すると、そのリストの先頭から順番に補完を試してくれます。

私は主にlisp系言語で遊んでいるので、補完用関数のリストに lispのシンボル補完用関数を設定していたのですが、lispプログラミング以外を行っている時にもlispのシンボルが候補にあがってしまいます。

Emacsのことなのですでに解決策はあるのでしょうが、とりあえず自作でmojor-mode/minor-modeごとに補完用関数を切り替えられるようなelispを書いてみました。

(require 'cl)

(defvar mode-specified-try-functions-table (make-hash-table))

(defun set-mode-specified-try-functions (mode functions)
(setf (gethash mode mode-specified-try-functions-table)
functions))
(defun set-default-try-functions (functions)
(setf (gethash :default mode-specified-try-functions-table)
functions))

(defun expand-try-functions-of (mode)
(let ((result
(gethash mode mode-specified-try-functions-table)))
(if (listp result) result
(list result))))

(defun current-hippie-expand-try-function-list ()
(remove-duplicates
(remove nil
(append
(apply
'append
(mapcar 'expand-try-functions-of minor-mode-list))
(expand-try-functions-of major-mode)
(expand-try-functions-of :default)))
:from-end t))

(defadvice hippie-expand (around mode-specified-hippie-expand)
(let ((hippie-expand-try-functions-list
(current-hippie-expand-try-function-list)))
ad-do-it))

(defun enable-mode-specified-hippie-expand ()
(interactive)
(ad-enable-advice 'hippie-expand
'around
'mode-specified-hippie-expand)
(ad-activate 'hippie-expand))

(defun disable-mode-specified-hippie-expand ()
(interactive)
(ad-disable-advice 'hippie-expand
'around
'mode-specified-hippie-expand)
(ad-deactivate 'hippie-expand))

;;(provide 'mode-specified-hippie-expand)

;;;; examples
(set-default-try-functions
'(try-complete-file-name-partially
try-complete-file-name
try-expand-all-abbrevs
try-expand-dabbrev
try-expand-dabbrev-all-buffers
try-expand-dabbrev-from-kill))

(dolist (mode
'(emacs-lisp-mode
slimre-repl-mode
lisp-mode
common-lisp-mode
lisp-interaction-mode))
(set-mode-specified-try-functions
mode
'(try-complete-lisp-symbol-partially
try-complete-lisp-symbol)))

;;;; enable
(enable-mode-specified-hippie-expand)