Add: automatic test suite construction

3 files changed, 114 insertions, 27 deletions

diff --git a/examples/examples.lisp b/examples/examples.lisp
index 4088d32..c9f8a07 100644
--- a/examples/examples.lisp
+++ b/examples/examples.lisp
@@ -7,7 +7,8 @@
 (in-package :testiere.examples)
 
 ;;; Turn Testiere On.
-(testiere:on)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (testiere:on))
 
 ;;; BASIC TESTS
 
diff --git a/src/standard-hooks.lisp b/src/standard-hooks.lisp
index 86725ca..0548865 100644
--- a/src/standard-hooks.lisp
+++ b/src/standard-hooks.lisp
@@ -2,6 +2,29 @@
 
 (in-package :testiere)
 
+;;; COMMON FUNCTIONS
+
+(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 standard-form-key (form)
+  "The first is a list (MACRO NAME) that uniquely identifies the form
+form which tests are being defined. NAME's package is the suite to
+which the tests of FORM will be be added.
+
+This form key function is sutable for Common Lisp definition macros."
+  (list (first form) (second form)))
+
+
 ;;; DEFSTRUCT
 
 ;; (defstruct moo
@@ -11,6 +34,7 @@
 
 (register-hook
  'cl:defstruct
+ #'standard-form-key
  #'standard-extractor)
 
 ;;; DEFCLASS
@@ -30,6 +54,7 @@
 (register-hook
  'cl:defclass
  #'standard-extractor
+ #'standard-form-key
  #'defclass-restarts-expander)
 
 ;;; DEFMETHOD
@@ -40,7 +65,7 @@
 ;;   (:tests ...)
 ;;   (flah  (moo-blah x) (barbar y)))
 
-(register-hook 'cl:defmethod #'standard-extractor)
+(register-hook 'cl:defmethod #'standard-extractor #'standard-form-key)
 
 ;;; DEFUN
 
@@ -57,7 +82,7 @@
        ()
        (fmakunbound ',name)))))
 
-(register-hook 'cl:defun #'standard-extractor #'defun-restarts-expander)
+(register-hook 'cl:defun #'standard-extractor #'standard-form-key #'defun-restarts-expander)
 
 ;;; DEFTYPE
 
@@ -67,4 +92,4 @@
 ;;   (:tests ...)
 ;;   `(or number null))
 
-(register-hook 'cl:deftype #'standard-extractor)
+(register-hook 'cl:deftype #'standard-extractor #'standard-form-key)
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*)