Skip to content

Test multiple packages #34

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 8 commits into
base: master
Choose a base branch
from
Open

Test multiple packages #34

Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
6e7b22d
New parameter, *summarize-results*, to suppress the unit test summary.
May 12, 2014
189df5b
Merge unit test results from multiple packages into a single results DB.
May 12, 2014
b91ad8b
Correctly RETURN from FINALLY in LOOP.
Oct 2, 2014
aeb6329
Merge remote-tracking branch 'jimka2001/assert-test' into feature/ass…
Sep 21, 2015
bbf2157
Add the arguments of the test form to extras in assert-true and asser…
Sep 21, 2015
cc351fd
Define an expand-t-or-f macro to properly handle arguments in assert-…
Sep 27, 2015
3af51ef
fix so that assert-true and assert-false work with local functions
jimka2001 Oct 2, 2015
d80d2e3
%run-all-thunks and $run-thunks updated to accept multiple packages
jimka2001 Jan 8, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
198 changes: 155 additions & 43 deletions lisp-unit.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.")
Expand Down Expand Up @@ -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))
Expand All @@ -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."
Expand Down Expand Up @@ -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 ()
Expand All @@ -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."
Expand Down