test suites; readme

2 files changed, 52 insertions, 40 deletions

diff --git a/src/package.lisp b/src/package.lisp
index 9594019..bbeb7d4 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -7,6 +7,7 @@
    #:on
    #:off
    #:register-hook
+   #:run-suites
    ;; legacy
    #:defun/t
    #:with-stub
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))))))