SIGNAL a condition on test failures, for use with ASDF:TEST-SYSTEM

src/package.lisp

@@ -79,7 +79,8 @@
    #:*on-failure*
    #:*verbose-failures*
    #:*print-names*
-   #:results-status))
+   #:results-status
+   #:test-spec-failure))
 
 ;;;; You can use #+5am to put your test-defining code inline with your
 ;;;; other code - and not require people to have fiveam to run your

src/run.lisp

@@ -266,6 +266,35 @@ run."))
   (when-let (test (get-test test-name))
     (%run test)))
 
+(define-condition test-spec-failure (asdf:test-op-test-failures)
+  ((test-spec :initarg :test-spec
+              :reader  test-spec-failure-spec))
+  (:documentation
+   "Super-class of conditions signalled by RUN to indicate test failures.
+See also documentation for parent condition ASDF:TEST-OP-TEST-FAILURES"))
+
+(define-condition test-spec-failure-no-tests (test-spec-failure) ()
+  (:documentation
+   "Condition to indicate that the given test spec did not result in any tests being run.")
+  (:report
+   (lambda (condition stream)
+     (write-string "Error: no tests ran for test spec: " stream)
+     (prin1 (test-spec-failure-spec condition) stream))))
+
+(define-condition test-spec-failure-tests-failed (test-spec-failure)
+    ((result-list :initarg :result-list
+                  :reader  test-spec-failure-result-list))
+  (:documentation "Condition to indicate that the given test spec has one or more failing tests.")
+  (:report
+   (lambda (condition stream)
+     (write-string "Failing tests in test spec " stream)
+     (prin1 (test-spec-failure-spec condition) stream)
+     (terpri stream)
+     (let ((*print-names*  nil)
+           (*test-dribble* stream))
+       (explain!
+        (test-spec-failure-result-list condition))))))
+
 (defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%")))
 
 (defvar *!* *initial-!*)
@@ -319,7 +348,29 @@ performed by the !, !! and !!! functions."
                             (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.")
                             :debug)
                            (t nil)))))
-    (funcall *!*)))
+    (let ((result-list (funcall *!*)))
+      (multiple-value-bind (all-pass? failed skipped)
+          (results-status result-list)
+        (cond
+          ((= (length result-list) (length skipped))
+           (restart-case (signal 'test-spec-failure-no-tests
+                                 :test-spec test-spec)
+             ;; here for FiveAM's test suite, where RUN is called
+             ;; from RUN
+             (ignore-failure ())))
+          ((not all-pass?)
+           (restart-case
+               (signal 'test-spec-failure-tests-failed
+                       :test-spec       test-spec
+                       :result-list     result-list
+                       :tests-run-count (length result-list)
+                       :failed-test-names
+                       (mapcar (lambda (test-result)
+                                 (prin1-to-string
+                                  (name (test-case test-result))))
+                          failed))
+             (ignore-failure ())))))
+      result-list)))
 
 (defun ! ()
   "Rerun the most recently run test and explain the results."

t/tests.lisp

@@ -7,8 +7,12 @@
 (def-suite test-suite :description "Suite for tests which should fail.")
 
 (defmacro with-test-results ((results test-name) &body body)
-  `(let ((,results (with-*test-dribble* nil (run ',test-name))))
-     ,@body))
+  `(handler-bind
+       ((test-spec-failure (lambda (condition)
+                             (declare (ignore condition))
+                             (invoke-restart 'ignore-failure))))
+     (let ((,results (with-*test-dribble* nil (run ',test-name))))
+       ,@body)))
 
 (def-fixture null-fixture ()
   `(progn ,@(&body)))
@@ -129,7 +133,7 @@
     (is (= 2 (length (remove-if-not #'test-passed-p results))))
     (is (= 1 (length (remove-if-not #'test-failure-p results))))))
 
-(def-test circular-0 (:depends-on (and circular-1 circular-2 or1) 
+(def-test circular-0 (:depends-on (and circular-1 circular-2 or1)
                       :suite test-suite)
   (fail "we depend on a circular dependency, we should not be tested."))
 
@@ -187,7 +191,7 @@
 (def-test before ()
   (with-test-results (results before-test-suite)
     (is (some #'test-skipped-p results)))
-  
+
   (with-test-results (results before-test-suite-2)
     (is (every #'test-passed-p results))))
 
@@ -273,8 +277,27 @@
 
 (def-test return-values ()
   "Return values indicate test failures."
-  (is-true (with-*test-dribble* nil (explain! (run 'is1))))
-  (is-true (with-*test-dribble* nil (run! 'is1)))
-
-  (is-false (with-*test-dribble* nil (explain! (run 'is2))))
-  (is-false (with-*test-dribble* nil (run! 'is2))))
+  (handler-bind
+      ((test-spec-failure (lambda (condition)
+                            (declare (ignore condition))
+                            (invoke-restart 'ignore-failure))))
+    (is-true (with-*test-dribble* nil (explain! (run 'is1))))
+    (is-true (with-*test-dribble* nil (run! 'is1)))
+
+    (is-false (with-*test-dribble* nil (explain! (run 'is2))))
+    (is-false (with-*test-dribble* nil (run! 'is2)))))
+
+(def-test signals-on-empty-test-suite ()
+  (signals test-spec-failure
+    (run ())))
+
+(def-test signals-on-failing-tests ()
+  (signals test-spec-failure
+    (run 'fail1)))
+
+(def-test does-not-signal-on-success ()
+  (is (= 0
+         (handler-case (progn (run 'is1) 0)
+           (test-spec-failure (condition)
+             (declare (ignore condition))
+             1)))))