diff options
Diffstat (limited to 'src/testiere.lisp')
| -rw-r--r-- | src/testiere.lisp | 91 |
1 files changed, 51 insertions, 40 deletions
diff --git a/src/testiere.lisp b/src/testiere.lisp index c7c7e73..acd3460 100644 --- a/src/testiere.lisp +++ b/src/testiere.lisp @@ -70,19 +70,24 @@ string, to be processed by CL:FORMAT." :using (:hash-value test-thunk) :do (run-test form-key test-thunk)))))) -(defun run-suites (packages &key (automatic-continue nil) (require-all t)) +(defun run-suites (&key packages (automatic-continue nil) (require-all t)) "PACKAGES is a list of pacakge designators. Attempts to run test -suites named in PACKAGES. +suites named in PACKAGES. If PACKAGES is NIL, then all known test +suites are run. 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)))) + (let ((packages + (if packages packages + (loop :for p :being :the :hash-keys :of *suite-dict* + :collect p)))) + (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. @@ -113,8 +118,8 @@ restarts to try when tests fail." (with-slots (extractor restarts-expander form-key-fn) hook (multiple-value-bind (form test-forms) (funcall extractor form) (if test-forms - (let ((key (funcall form-key-fn form)) - (tests (expand-test-forms test-forms))) + (let* ((key (funcall form-key-fn form)) + (tests (expand-test-forms key test-forms))) (if restarts-expander `(prog1 ,(funcall expander form environment) (restart-case (progn ,@tests) @@ -127,57 +132,63 @@ restarts to try when tests fail." (t (funcall expander form environment))))) -(defun expand-test-forms (forms) - (mapcar #'expand-test-form forms)) +(defun expand-test-forms (key forms) + (loop :for form :in forms :collect (expand-test-form key form))) -(defun expand-test-form (form) +(defun expand-test-form (key form) (ematch form ((list :fails failing-form) - `(assert (handler-case (progn ,failing-form nil) + `(unless (handler-case (progn ,failing-form nil) (error () t)) - () - "~s should have signalled an error but did not." - ',failing-form)) + (failed ',key "~s should have signalled an error but did not." + ',failing-form))) ((list :signals condition signalling-form) - `(assert (handler-case (progn ,signalling-form) + `(unless (handler-case (progn ,signalling-form) (,condition () t) (condition () nil)) - () - "~s should have signalled ~s but did not." - ',signalling-form - ',condition)) + (failed ',key "~s should have signalled ~s but did not." + ',signalling-form + ',condition))) ((list* :funcall function args) - `(funcall ,function ,@args)) + (let ((err (gensym "ERROR-"))) + `(handler-case (funcall ,function ,@args) + (error (,err) (failed ',key "~s signalled an error: ~s" + '(funcall ,function ,@args) + ,err))))) ((list* :with-defuns (list* stubs) body) - (expand-defun-stubs stubs body)) + (expand-defun-stubs key stubs body)) ((list* :with-generic name (list* method-stubs) body) - (expand-generic-stub name method-stubs body)) + (expand-generic-stub key name method-stubs body)) ((list* :let (list* bindings) body) - `(let ,bindings ,@(expand-test-forms body))) + `(let ,bindings ,@(expand-test-forms key body))) ((list :do form) - form) + (let ((err (gensym "ERROR-"))) + `(handler-case ,form + (error (,err) + (failed ',key "Side effecting code ~s signalled an error ~s" + ',form ,err))))) ((list :is form) - `(assert ,form () "~s failed" ',form)) + `(unless ,form + (failed ',key "~s returned NIL" ',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 ((left (gensym "LEFT-")) + (right (gensym "RIGHT-")) + (pred-result (gensym "RESULT-"))) + `(let* ((,left ,a) + (,right ,b) + (,pred-result (,comparator ,left ,right))) + (unless ,pred-result + (failed ',key "~s is NIL" ',form))))))) + +(defun expand-defun-stubs (key defs body) (let* ((redef-names (mapcar #'car defs)) @@ -204,10 +215,10 @@ restarts to try when tests fail." `(let ((,defun-cache-var (list ,@defun-cache))) (unwind-protect (progn ,@defun-redefs - ,@(expand-test-forms body)) + ,@(expand-test-forms key body)) ,@defun-restore)))) -(defun expand-generic-stub (name method-stubs body) +(defun expand-generic-stub (key name method-stubs body) (let* ((orig-generic (gensym "DEFGENERIC-CACHE")) @@ -219,7 +230,7 @@ restarts to try when tests fail." (unwind-protect (progn ,@method-defs - ,@(expand-test-forms body)) + ,@(expand-test-forms key body)) (when ,orig-generic (setf (fdefinition ',name) ',orig-generic)))))) |