X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Frun.lisp;h=e40a316144d668656e0111a2ec10d99ee9558d3e;hb=ea9fe5771807138bc553a2f669ef1aa4540e4fdc;hp=2f9d36311e050c02051ef6f7df13a923167a6c84;hpb=38ea1db6368d028601ae346b326150c56b4a33ab;p=fiveam.git

diff --git a/src/run.lisp b/src/run.lisp
index 2f9d363..e40a316 100644
--- a/src/run.lisp
+++ b/src/run.lisp
@@ -39,6 +39,9 @@
 (defparameter *debug-on-failure* nil
   "T if we should drop into a debugger on a failing check, NIL otherwise.")
 
+(defparameter *print-names* t
+  "T if we should print test running progress, NIL otherwise.")
+
 (defun import-testing-symbols (package-designator)
   (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
           package-designator))
@@ -117,10 +120,12 @@ run."))
 (defun results-status (result-list)
   "Given a list of test results (generated while running a test)
   return true if all of the results are of type TEST-PASSED,
-  faile otherwise."
-  (every (lambda (res)
-           (typep res 'test-passed))
-         result-list))
+  fail otherwise.
+  Returns a second value, which is the set of failed tests."
+  (let ((failed-tests
+          (remove-if #'test-passed-p result-list)))
+    (values (null failed-tests)
+            failed-tests)))
 
 (defun return-result-list (test-lambda)
   "Run the test function TEST-LAMBDA and return a list of all
@@ -182,12 +187,16 @@ run."))
   !!, !!!"))
 
 (defmethod %run ((test test-case))
+  (when *print-names*
+    (format *test-dribble* "~% Running test ~A " (name test)))
   (run-resolving-dependencies test))
 
 (defmethod %run ((tests list))
   (mapc #'%run tests))
 
 (defmethod %run ((suite test-suite))
+  (when *print-names*
+    (format *test-dribble* "~%Running test suite ~A" (name suite)))
   (let ((suite-results '()))
     (flet ((run-tests ()
              (loop
@@ -202,9 +211,7 @@ run."))
                       (run-tests)
                       (run-tests)))
              (setf suite-results result-list
-                   (status suite) (every (lambda (res)
-                                           (typep res 'test-passed))
-                                         suite-results)))
+                   (status suite) (every #'test-passed-p suite-results)))
         (with-run-state (result-list)
           (setf result-list (nconc result-list suite-results)))))))
 
@@ -220,14 +227,17 @@ run."))
 
 ;;;; ** Public entry points
 
-(defun run! (&optional (test-spec *suite*))
-  "Equivalent to (explain (run TEST-SPEC))."
+(defun run! (&optional (test-spec *suite*)
+             &key ((:print-names *print-names*) *print-names*))
+  "Equivalent to (explain! (run TEST-SPEC))."
   (explain! (run test-spec)))
 
 (defun explain! (result-list)
   "Explain the results of RESULT-LIST using a
-detailed-text-explainer with output going to *test-dribble*"
-  (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*))
+detailed-text-explainer with output going to *test-dribble*.
+Return a boolean indicating whether no tests failed."
+  (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*)
+  (notany #'test-failure-p result-list))
 
 (defun debug! (&optional (test-spec *suite*))
   "Calls (run! test-spec) but enters the debugger if any kind of error happens."
@@ -235,7 +245,7 @@ detailed-text-explainer with output going to *test-dribble*"
         (*debug-on-failure* t))
     (run! test-spec)))
 
-(defun run (test-spec)
+(defun run (test-spec &key ((:print-names *print-names*) *print-names*))
   "Run the test specified by TEST-SPEC.
 
 TEST-SPEC can be either a symbol naming a test or test suite, or