diff --git a/lisp-unit.lisp b/lisp-unit.lisp index d4a7157..84e997c 100644 --- a/lisp-unit.lisp +++ b/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."