diff options
Diffstat (limited to 'src/testiere.lisp')
| -rw-r--r-- | src/testiere.lisp | 177 |
1 files changed, 177 insertions, 0 deletions
diff --git a/src/testiere.lisp b/src/testiere.lisp new file mode 100644 index 0000000..df516e0 --- /dev/null +++ b/src/testiere.lisp @@ -0,0 +1,177 @@ +;;;; testiere.lisp -- core testiere functionality + +(in-package #:testiere) + +(defstruct testiere-hook + ;; a function that extracts '(:tests ...), returning them and the modified form + (extractor nil) + ;; a function that accepts a form and returns a list of restart handlers + (restarts-expander nil)) + +(defvar *testiere-hooks* + (make-hash-table) + "Registry of macro functions and testiere-hook") + +(defun register-hook (macro extractor &optional restarts-expander) + "Register a new hook for use with testiere. + +MACRO is a symbol naming a macro-function + +EXTRACTOR is a function of one argument, FORM representing the &WHOLE +of the macro-function call. It returns two values: a modified s form +identical with FORM except (:tests ...) forms have been +removed. The second value should be the conatenation of the CDRs of +these (:tests ...) forms. + +RESTARTS-EXPANDER is an optional functionof one argument. It returns +the restart handler clauses of a RESTART-CASE form. These are the +restarts to try when tests fail." + (setf (gethash (macro-function macro) *testiere-hooks*) + (make-testiere-hook + :extractor extractor + :restarts-expander restarts-expander))) + +(defvar *cached-macroexpand-hook* nil) + +(defun testiere-hook (expander form environment) + (let* ((hook + (gethash expander *testiere-hooks*))) + (cond + (hook + (with-slots (extractor restarts-expander) hook + (multiple-value-bind (form test-forms) (funcall extractor form) + (if test-forms + (let ((tests (expand-test-forms test-forms))) + (if restarts-expander + `(prog1 ,(funcall expander form environment) + (restart-case (progn ,@tests) + ,@(funcall restarts-expander form))) + `(prog1 ,(funcall expander form environment) + ,@tests))) + (funcall expander form environment))))) + (t + (funcall expander form environment))))) + +(defun expand-test-forms (forms) + (mapcar #'expand-test-form forms)) + +(defun expand-test-form (form) + (ematch form + ((list :fails failing-form) + `(assert (handler-case (progn ,failing-form nil) + (error () t)) + () + "~s should have signalled an error but did not." + ',failing-form)) + + ((list :signals condition signalling-form) + `(assert (handler-case (progn ,signalling-form) + (,condition () t) + (condition () nil)) + () + "~s should have signalled ~s but did not." + ',condition)) + + ((list* :funcall function args) + `(funcall ,function ,@args)) + + ((list* :with-defuns (list* stubs) body) + (expand-defun-stubs stubs body)) + + ((list* :with-generic name (list* method-stubs) body) + (expand-generic-stub name method-stubs body)) + + ((list* :let (list* bindings) body) + `(let ,bindings ,@(expand-test-forms body))) + + ((list :is form) + `(assert ,form () "~s failed" ',form)) + + ((list comparator a b) + (let ((a-result (gensym)) + (b-result (gensym)) + (pred-result (gensym))) + `(let* ((,a-result ,a) + (,b-result ,b) + (,pred-result (,comparator ,a-result ,b-result))) + (assert ,pred-result () "~s failed with ~s" + ',form + (list ',comparator ,a-result ,b-result))))))) + +(defun expand-defun-stubs (defs body) + (let* ((redef-names + (mapcar #'car defs)) + + (defun-cache + (loop :for name :in redef-names + :collect `(cons ',name + (and (fboundp ',name) + (fdefinition ',name))))) + + (defun-cache-var + (gensym "DEFUN-CACHE")) + + (defun-redefs + (loop :for (name lambda-list . fbod) :in defs + :collect `(setf (fdefinition ',name) + (lambda ,lambda-list ,@fbod)))) + + (defun-restore + (loop :for name :in redef-names + :collect `(if (cdr (assoc ',name ,defun-cache-var)) + (setf (fdefinition ',name) + (cdr (assoc ',name ,defun-cache-var))) + (fmakunbound ',name))))) + `(let ((,defun-cache-var (list ,@defun-cache))) + (unwind-protect + (progn ,@defun-redefs + ,@(expand-test-forms body)) + ,@defun-restore)))) + +(defun expand-generic-stub (name method-stubs body) + (let* ((orig-generic + (gensym "DEFGENERIC-CACHE")) + + (method-defs + (loop :for stub :in method-stubs + :collect `(defmethod ,name ,@stub)))) + + `(let ((,orig-generic (and (fboundp ',name) (fdefinition ',name)))) + (unwind-protect + (progn + ,@method-defs + ,@(expand-test-forms body)) + (when ,orig-generic + (setf (fdefinition ',name) ',orig-generic)))))) + + +(defun standard-extractor (orig-form) + "A somewhat naive default test form extractor. Returns two values, +orig-form without test forms included, and a collection of test forms." + (loop + :for form :in orig-form + :when (and (listp form) + (eq :tests (first form))) + :append (cdr form) :into tests-forms + :else + :collect form :into defun-form + :finally (return (values defun-form tests-forms)))) + + +(defun on () + (unless (member :testiere *features*) + (pushnew :testiere *features*) + (setf + *cached-macroexpand-hook* *macroexpand-hook* + *macroexpand-hook* 'testiere-hook ))) + +(defun off () + (when (member :testiere *features*) + (setf *features* (delete :testiere *features*)) + (setf *macroexpand-hook* *cached-macroexpand-hook* + *cached-macroexpand-hook* nil))) + + + + + |