Count passed assertions and only store details for failed assertions.
authorThomas M. Hermann <thomas.m.hermann@odonata-research.com>
Fri, 1 Feb 2013 05:43:19 +0000 (31 23:43 -0600)
committerThomas M. Hermann <thomas.m.hermann@odonata-research.com>
Fri, 1 Feb 2013 05:43:19 +0000 (31 23:43 -0600)
extensions/test-anything-protocol.lisp
lisp-unit.lisp

index 58b655b..d9acbca 100644 (file)
 (export '(write-tap write-tap-to-file))
 
 (defun %write-tap-test-result (name test-result i stream)
-  "output a single test, taking care to ensure the indentation level is the
-same before and after invocation."
+  "Output a single test, taking care to ensure the indentation level
+is the same before and after invocation."
   (pprint-logical-block (stream nil)
     (format stream
             "~:[ok~;not ok~] ~d ~s"
             (or (fail test-result)
                 (exerr test-result))
             i name)
-  
     (when (or (fail test-result)
               (exerr test-result))
       ;; indent only takes affect after a newline, so force one
@@ -58,7 +57,7 @@ same before and after invocation."
     (format stream "~0I~@:_")))
 
 (defun write-tap (test-results &optional (stream *standard-output*))
-  "write the test results to `stream` in TAP format. Returns the test
+  "Write the test results to `stream` in TAP format. Returns the test
 results."
   (check-type test-results test-results-db)
   (let ((i 0)
@@ -72,8 +71,8 @@ results."
   test-results)
 
 (defun write-tap-to-file (test-results path)
-  "write the test results to `path` in TAP format, overwriting `path`. Returns
-pathname to the output file"
+  "write the test results to `path` in TAP format, overwriting `path`.
+Returns pathname to the output file"
   (check-type path (or string pathname))
   (ensure-directories-exist path)
   (with-open-file (s path :direction :output :if-exists :supersede)
index 80cbd67..360f5e0 100644 (file)
@@ -101,7 +101,7 @@ functions or even macros does not require reloading any tests.
 
 ;;; Global counters
 
-(defparameter *pass* ()
+(defparameter *pass* 0
   "The passed assertion results.")
 
 (defparameter *fail* ()
@@ -109,7 +109,7 @@ functions or even macros does not require reloading any tests.
 
 (defun reset-counters ()
   "Reset the counters to empty lists."
-  (setf *pass* () *fail* ()))
+  (setf *pass* 0 *fail* ()))
 
 ;;; Global options
 
@@ -389,7 +389,7 @@ assertion.")
   `(lambda ()
      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 
-(defclass assert-result ()
+(defclass failure-result ()
   ((form
     :initarg :form
     :reader form)
@@ -408,81 +408,77 @@ assertion.")
    (test
     :type function
     :initarg :test
-    :reader test)
-   (passed
-    :type boolean
-    :reader passed))
+    :reader test))
   (:documentation
-   "Result of the assertion."))
+   "Failure details of the assertion."))
 
-(defclass equal-result (assert-result)
+(defclass equal-result (failure-result)
   ()
   (:documentation
-   "Result of an equal assertion type."))
-
-(defmethod initialize-instance :after ((self equal-result)
-                                       &rest initargs)
-  "Return the result of the equality assertion."
-  (with-slots (actual expected test passed) self
-    (setf passed
-          (and
-           (<= (length expected) (length actual))
-           (every test expected actual)))))
-
-(defclass error-result (assert-result)
+   "Result of a failed equal assertion."))
+
+(defun equal-result (test expected actual)
+  "Return the result of an equal assertion."
+  (and
+   (<= (length expected) (length actual))
+   (every test expected actual)))
+
+(defclass error-result (failure-result)
   ()
   (:documentation
-   "Result of an error assertion type."))
-
-(defmethod initialize-instance :after ((self error-result)
-                                       &rest initargs)
-  "Evaluate the result."
-  (with-slots (actual expected passed) self
-    (setf
-     passed
-     (or
-      (eql (car actual) (car expected))
-      (typep (car actual) (car expected))))))
-
-(defclass macro-result (assert-result)
+   "Result of a failed error assertion."))
+
+(defun error-result (test expected actual)
+  "Return the result of an error assertion."
+  (declare (ignore test))
+  (or
+   (eql (car actual) (car expected))
+   (typep (car actual) (car expected))))
+
+(defclass macro-result (failure-result)
   ()
   (:documentation
-   "Result of a macro assertion type."))
+   "Result of a failed macro expansion assertion."))
 
-(defmethod initialize-instance :after ((self macro-result)
-                                       &rest initargs)
-  "Return the result of the macro expansion."
-  (with-slots (actual expected passed) self
-    (setf passed (equal (car actual) (car expected)))))
+;;; FIXME: Review the internal tests for macros.
+(defun macro-result (test expected actual)
+  "Return the result of a macro assertion."
+  (declare (ignore test))
+  (equal (car actual) (car expected)))
 
-(defclass boolean-result (assert-result)
+(defclass boolean-result (failure-result)
   ()
   (:documentation
-   "Result of a result assertion type."))
+   "Result of a failed boolean assertion."))
 
-(defmethod initialize-instance :after ((self boolean-result)
-                                       &rest initargs)
-  "Return the result of the assertion."
-  (with-slots (actual expected passed) self
-    (setf passed (logically-equal (car actual) (car expected)))))
+(defun boolean-result (test expected actual)
+  "Return the result of a result assertion."
+  (declare (ignore test))
+  (logically-equal (car actual) (car expected)))
 
-(defclass output-result (assert-result)
+(defclass output-result (failure-result)
   ()
   (:documentation
-   "Result of an output assertion type."))
-
-(defmethod initialize-instance :after ((self output-result)
-                                       &rest initargs)
-  "Return the result of the printed output."
-  (with-slots (actual expected passed) self
-    (setf
-     passed
-     (string=
-      (string-trim '(#\newline #\return #\space) (car actual))
-      (car expected)))))
+   "Result of a failed output assertion."))
+
+(defun output-result (test expected actual)
+  "Return the result of an output assertion."
+  (declare (ignore test))
+  (string=
+   (string-trim '(#\newline #\return #\space) (car actual))
+   (car expected)))
+
+(defun assert-function (type)
+  "Return the function for the assertion type."
+  (ecase type
+    (:equal #'equal-result)
+    (:error #'error-result)
+    (:macro #'macro-result)
+    (:result #'boolean-result)
+    (:output #'output-result)))
 
 (defun assert-class (type)
-  "Return the class name for the assertion type."
+  "Return the class for the assertion type."
   (ecase type
     (:equal 'equal-result)
     (:error 'error-result)
@@ -493,19 +489,22 @@ assertion.")
 (defun internal-assert
        (type form code-thunk expected-thunk extras test)
   "Perform the assertion and record the results."
-  (let ((result
-         (make-instance
-          (assert-class type)
-          :form form
-          :actual (multiple-value-list (funcall code-thunk))
-          :expected (multiple-value-list (funcall expected-thunk))
-          :extras (when extras (funcall extras))
-          :test test)))
-    (if (passed result)
-        (push result *pass*)
-        (push result *fail*))
+  (let* ((actual (multiple-value-list (funcall code-thunk)))
+         (expected (multiple-value-list (funcall expected-thunk)))
+         (result
+          (funcall (assert-function type) test expected actual)))
+    (if result
+        (incf *pass*)
+        (push (make-instance
+               (assert-class type)
+               :form form
+               :actual actual
+               :expected expected
+               :extras (when extras (funcall extras))
+               :test test)
+              *fail*))
     ;; Return the result
-    (passed result)))
+    result))
 
 ;;; Unit test results
 
@@ -515,7 +514,7 @@ assertion.")
     :initarg :name
     :reader name)
    (pass
-    :type list
+    :type fixnum
     :initarg :pass
     :reader pass)
    (fail
@@ -533,7 +532,7 @@ assertion.")
   "Print a summary of the test result."
   (format t "~&~A: ~S assertions passed, ~S failed"
           (name test-result)
-          (length (pass test-result))
+          (pass test-result)
           (length (fail test-result)))
   (if (exerr test-result)
       (format t ", and an execution error.")
@@ -546,7 +545,7 @@ assertion.")
   (funcall (coerce `(lambda () ,@code) 'function)))
 
 (defun run-test-thunk (name code)
-  (let ((*pass* ())
+  (let ((*pass* 0)
         (*fail* ()))
     (handler-bind
         ((error
@@ -562,10 +561,11 @@ assertion.")
                    :exerr condition))))))
       (run-code code))
     ;; Return the result count
-    (make-instance 'test-result
-                   :name name
-                   :pass *pass*
-                   :fail *fail*)))
+    (make-instance
+     'test-result
+     :name name
+     :pass *pass*
+     :fail *fail*)))
 
 ;;; Test results database
 
@@ -622,8 +622,8 @@ assertion.")
     ;; Store the result
     (setf (gethash test-name (database results)) result)
     ;; Count passed tests
-    (when (pass result)
-      (incf (pass results) (length (pass result))))
+    (when (plusp (pass result))
+      (incf (pass results) (pass result)))
     ;; Count failed tests and record the name
     (when (fail result)
       (incf (fail results) (length (fail result)))
@@ -704,7 +704,7 @@ assertion.")
   (:documentation
    "Report the results of the failed assertion."))
 
-(defmethod print-failures :around ((result assert-result))
+(defmethod print-failures :around ((result failure-result))
   "Failure header and footer output."
   (format t "~& | Failed Form: ~S" (form result))
   (call-next-method)
@@ -713,7 +713,7 @@ assertion.")
   (format t "~& |~%")
   (class-name (class-of result)))
 
-(defmethod print-failures ((result assert-result))
+(defmethod print-failures ((result failure-result))
   (format t "~& | Expected ~{~S~^; ~} " (expected result))
   (format t "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))