diff options
Diffstat (limited to 'src/testiere.lisp')
| -rw-r--r-- | src/testiere.lisp | 107 |
1 files changed, 84 insertions, 23 deletions
diff --git a/src/testiere.lisp b/src/testiere.lisp index 6ccf5ae..c7c7e73 100644 --- a/src/testiere.lisp +++ b/src/testiere.lisp @@ -4,15 +4,87 @@ (defstruct testiere-hook ;; a function that extracts '(:tests ...), returning them and the modified form - (extractor nil) + (extractor (error "required")) ;; a function that accepts a form and returns a list of restart handlers - (restarts-expander nil)) + (restarts-expander nil) + ;; a function that accepts an sexpr and returns a list of symbols + ;; (MACRO NAME . MORE) where MACRO names the macro being expanded, + ;; NAME is some kind of unique name in the package where the form is + ;; being defined, and MORE is a possibly empty list of arbitrary + ;; symbols. These lists should uniquely name, a particular + ;; invocation of a macro up to comparison by EQUAL. + (form-key-fn (error "required"))) (defvar *testiere-hooks* (make-hash-table) "Registry of macro functions and testiere-hook") -(defun register-hook (macro extractor &optional restarts-expander) +(defvar *suite-dict* + (make-hash-table :test #'eq) + "PACKAGE -> {FORM-KEY -> TEST-LAMBDA}") + +(defun add-test-to-package-suite (form-key test-thunk) + (let ((suite (or (gethash (symbol-package (second form-key)) *suite-dict*) + (setf (gethash (symbol-package (second form-key)) *suite-dict*) + (make-hash-table :test #'equal))))) + (setf (gethash form-key suite) test-thunk))) + +(define-condition testiere-error (error) + ((reason :initarg :reason))) + +(define-condition test-failure-error (testiere-error) + ((test :initarg :test))) + +(defun failed (test reason-fmt &rest fmt-args) + "Signal a TEST-FAILURE-ERROR. TEST is a deignator for the +test. REASON-FMT is a format string and FMT-ARGS are arguments to that +string, to be processed by CL:FORMAT." + (error 'test-failure-error + :test test + :reason (apply #'format nil reason-fmt fmt-args))) + +(defun report (fmt-string &rest args) + (apply #'format *standard-output* fmt-string args)) + +(defun run-test (key thunk) + (report " Testing ~{~a~^ ~}~65,1t~:[[FAIL]~;[pass]~]~%" + key + (restart-case (funcall thunk) + (report-and-continue-tests () nil)))) + +(defun report-and-continue-tests (e) + (declare (ignore e)) + (invoke-restart 'report-and-continue-tests)) + +(defun run-package-suite (package &optional required) + (let ((suite (gethash (find-package package) *suite-dict*))) + (cond ((not suite) + (if required + (error 'testiere-error + :reason (format nil "No test suite found for package ~s" + (package-name package))) + (report "~%No tests found for package ~s~%" (package-name package)))) + (t + (report "~%Running tests for package ~s~%" (package-name package)) + (loop :for form-key :being :the :hash-keys :of suite + :using (:hash-value test-thunk) + :do (run-test form-key test-thunk)))))) + +(defun run-suites (packages &key (automatic-continue nil) (require-all t)) + "PACKAGES is a list of pacakge designators. Attempts to run test +suites named in PACKAGES. + +If AUTOMATIC-CONTINUE is T then all TEST-FAILURE-ERRORs will be +handled by printing a test failure before continuing with the suite. + +If REQUIRE-ALL is T then an error will be signalled if no suite exists +for one of the members of PACKAGES." + (if automatic-continue + (handler-bind ((test-failure-error #'report-and-continue-tests)) + (loop :for p :in packages :do (run-package-suite p require-all))) + (loop :for p :in packages :do (run-package-suite p require-all)))) + +(defun register-hook (macro extractor form-key-fn &optional restarts-expander) "Register a new hook for use with testiere. MACRO is a symbol naming a macro-function @@ -29,25 +101,28 @@ restarts to try when tests fail." (setf (gethash (macro-function macro) *testiere-hooks*) (make-testiere-hook :extractor extractor + :form-key-fn form-key-fn :restarts-expander restarts-expander))) (defvar *cached-macroexpand-hook* nil) (defun testiere-hook (expander form environment) - (let* ((hook - (gethash expander *testiere-hooks*))) + (let* ((hook (gethash expander *testiere-hooks*))) (cond (hook - (with-slots (extractor restarts-expander) hook + (with-slots (extractor restarts-expander form-key-fn) hook (multiple-value-bind (form test-forms) (funcall extractor form) (if test-forms - (let ((tests (expand-test-forms test-forms))) + (let ((key (funcall form-key-fn form)) + (tests (expand-test-forms test-forms))) (if restarts-expander `(prog1 ,(funcall expander form environment) (restart-case (progn ,@tests) - ,@(funcall restarts-expander form))) + ,@(funcall restarts-expander form)) + (add-test-to-package-suite ',key (lambda () ,@tests t))) `(prog1 ,(funcall expander form environment) - ,@tests))) + ,@tests + (add-test-to-package-suite ',key (lambda () ,@tests t))))) (funcall expander form environment))))) (t (funcall expander form environment))))) @@ -148,20 +223,6 @@ restarts to try when tests fail." (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*) |