Test multiple packages

lisp-unit.lisp

@@ -57,7 +57,8 @@ functions or even macros does not require reloading any tests.
   ;; Print parameters
   (:export :*print-summary*
            :*print-failures*
-           :*print-errors*)
+           :*print-errors*
+           :*summarize-results*)
   ;; Forms for assertions
   (:export :assert-eq
            :assert-eql
@@ -91,6 +92,8 @@ functions or even macros does not require reloading any tests.
            :print-failures
            :print-errors
            :summarize-results)
+  ;; Functions for test results
+  (:export :reduce-test-results-dbs)
   ;; Functions for extensibility via signals
   (:export :signal-results
            :test-run-complete
@@ -123,6 +126,9 @@ functions or even macros does not require reloading any tests.
 (defparameter *print-errors* nil
   "Print error messages if non-NIL.")
 
+(defparameter *summarize-results* t
+  "Summarize all of the unit test results.")
+
 (defparameter *use-debugger* nil
   "If not NIL, enter the debugger when an error is encountered in an
 assertion.")
@@ -434,10 +440,6 @@ output if a test fails.
                   (expand-macro-form ,form nil)
                   ',expansion ,extras))
 
-(defmacro assert-false (form &rest extras)
-  "Assert whether the form is false."
-  `(expand-assert :result ,form ,form nil ,extras))
-
 (defmacro assert-equality (test expected form &rest extras)
   "Assert whether expected and form are equal according to test."
   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
@@ -447,9 +449,30 @@ output if a test fails.
   `(expand-assert :output ,form (expand-output-form ,form)
                   ,output ,extras))
 
+(defmacro assert-false (form &rest extras)
+  "Assert whether the form is false."
+  `(expand-t-or-f nil ,form ,extras))
+
 (defmacro assert-true (form &rest extras)
   "Assert whether the form is true."
-  `(expand-assert :result ,form ,form t ,extras))
+  `(expand-t-or-f t ,form ,extras))
+
+(defmacro expand-t-or-f (t-or-f form extras)
+  "Expand the true/false assertions to report the arguments."
+  (let ((args (gensym))
+	(fname (gensym)))
+    `(let ((,args (list ,@(cdr form)))
+	   (,fname #',(car form)))
+       (internal-assert
+        :result ',form
+        (lambda () (apply ,fname ,args)) ; Evaluate the form
+        (lambda () ,t-or-f)
+        ;; Concatenate the args with the extras
+        (lambda ()
+          (nconc
+           (mapcan #'list ',(cdr form) ,args)
+           (funcall (expand-extras ,extras))))
+        #'eql))))
 
 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
   "Expand the assertion to the internal format."
@@ -791,6 +814,88 @@ output if a test fails.
     (format stream " | ~D missing tests~2%"
             (length (missing-tests results)))))
 
+(defun default-db-merge-function (results new-results)
+  "Signal an error by default if a merge is required."
+  (lambda (key value1 value2)
+    (error
+     "Cannot merge TEST-RESULTS-DB instances ~A and ~A as key ~A has
+two values, ~A and ~A"
+     results new-results key value1 value2)))
+
+(defun nappend-test-results-db (results new-results &key merge)
+  "Merge the results of NEW-RESULTS in to RESULTS. Any conflicts
+between RESULTS and NEW-RESULTS are handled by the function MERGE.
+
+The lambda list for the MERGE functions is
+
+  (key results-value new-results-value)
+
+where:
+  KEY is the key which appears in RESULTS and NEW-RESULTS.
+  RESULTS-VALUE is the value appearing RESULTS.
+  NEW-RESULTS-VALUE is the value appearing in NEW-RESULTS.
+
+If MERGE is NIL, then an error is signalled when a conflict occurs.
+"
+  (check-type results test-results-db)
+  (check-type new-results test-results-db)
+  (check-type merge (or null function))
+  (loop
+   with results-db = (database results)
+   with new-results-db = (database new-results)
+   with merge =
+   (or merge (default-db-merge-function results new-results))
+   ;; Merge test databases
+   for key being each hash-key in new-results-db
+   using (hash-value new-results-value)
+   do
+   (multiple-value-bind (results-value presentp)
+       (gethash key results-db)
+     (setf
+      (gethash key results-db)
+      (if presentp
+          (funcall merge key results-value new-results-value)
+          new-results-value)))
+   finally
+   ;; Update counters
+   (incf (pass results) (pass new-results))
+   (incf (fail results) (fail new-results))
+   (incf (exerr results) (exerr new-results))
+   ;; Merge failures, errors, and missing test details
+   (setf
+    ;; Failures
+    (failed-tests results)
+    (append (failed-tests results) (failed-tests new-results))
+    ;; Errors
+    (error-tests results)
+    (append (error-tests results) (error-tests new-results))
+    ;; Missing tests
+    (missing-tests results)
+    (append (missing-tests results) (missing-tests new-results))))
+   ;; Return the merged results
+   results)
+
+(defun reduce-test-results-dbs (all-results &key merge)
+  "Return a new instance of TEST-RESULTS-DB which contains all of the
+results in the sequence RESULTS. Any conflicts are handled by the
+function MERGE.
+
+The lambda list for the MERGE function is
+
+  (key value-1 value-2)
+
+where:
+  KEY is the key which appears at least twice in the sequence RESULTS.
+  VALUE-1 and VALUE-2 are the conflicting values for the given KEY.
+
+If MERGE is NIL, then an error is signalled when a conflict occurs."
+  (loop
+   with accumulated-test-results-db = (make-instance 'test-results-db)
+   for new-results in all-results do
+   (nappend-test-results-db
+    accumulated-test-results-db new-results :merge merge)
+   finally (return accumulated-test-results-db)))
+
 ;;; Run the tests
 
 (define-condition test-run-complete ()
@@ -801,47 +906,54 @@ output if a test fails.
   (:documentation
    "Signaled when a test run is finished."))
 
-(defun %run-all-thunks (&optional (package *package*))
+(defun %run-all-thunks (&optional (packages (list *package*)))
   "Run all of the test thunks in the package."
-  (with-package-table (table package)
-    (loop
-     with results = (make-instance 'test-results-db)
-     for test-name being each hash-key in table
-     using (hash-value unit-test)
-     if unit-test do
-     (record-result test-name (code unit-test) results)
-     else do
-     (push test-name (missing-tests results))
-     ;; Summarize and return the test results
-     finally
-     (when *signal-results*
-       (signal 'test-run-complete :results results))
-     (summarize-results results)
-     (return results))))
-
-(defun %run-thunks (test-names &optional (package *package*))
-  "Run the list of test thunks in the package."
-  (with-package-table (table package)
-    (loop
-     with results = (make-instance 'test-results-db)
-     for test-name in test-names
-     as unit-test = (gethash test-name table)
-     if unit-test do
-     (record-result test-name (code unit-test) results)
-     else do
-     (push test-name (missing-tests results))
-     finally
-     (when *signal-results*
-       (signal 'test-run-complete :results results))
-     (summarize-results results)
-     (return results))))
-
-(defun run-tests (&optional (test-names :all) (package *package*))
+  (when (and packages (atom packages))
+    (setf packages (list packages)))
+  (let ((results (make-instance 'test-results-db)))
+    (dolist (package packages)
+      (with-package-table (table package)
+	(loop
+	  for test-name being each hash-key in table
+	    using (hash-value unit-test)
+	  if unit-test do
+	    (record-result test-name (code unit-test) results)
+	  else do
+	    (push test-name (missing-tests results)))))
+    ;; Summarize and return the test results
+    (when *signal-results*
+      (signal 'test-run-complete :results results))
+    (when *summarize-results*
+      (summarize-results results))
+    results))
+
+(defun %run-thunks (test-names &optional (packages (list *package*)))
+  "Run the list of test thunks in the packages."
+  (when (and packages (atom packages))
+    (setf packages (list packages)))
+  (let ((results (make-instance 'test-results-db)))
+    (dolist (package packages)
+      (with-package-table (table package)
+	(loop
+	  for test-name in test-names
+	  as unit-test = (gethash test-name table)
+	  if unit-test do
+	    (record-result test-name (code unit-test) results)
+	  else do
+	    (push test-name (missing-tests results)))))
+    (when *signal-results*
+      (signal 'test-run-complete :results results))
+    (when *summarize-results*
+      (summarize-results results))
+    results))
+
+
+(defun run-tests (&optional (test-names :all) (packages (list *package*)))
   "Run the specified tests in package."
   (reset-counters)
   (if (eq :all test-names)
-      (%run-all-thunks package)
-      (%run-thunks test-names package)))
+      (%run-all-thunks packages)
+      (%run-thunks test-names packages)))
 
 (defun run-tags (&optional (tags :all) (package *package*))
   "Run the tests associated with the specified tags in package."