lisp-unit.lisp

   1 ;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 #|
   4 Copyright (c) 2004-2005 Christopher K. Riesbeck
   5
   6 Permission is hereby granted, free of charge, to any person obtaining
   7 a copy of this software and associated documentation files (the "Software"),
   8 to deal in the Software without restriction, including without limitation
   9 the rights to use, copy, modify, merge, publish, distribute, sublicense,
  10 and/or sell copies of the Software, and to permit persons to whom the
  11 Software is furnished to do so, subject to the following conditions:
  12
  13 The above copyright notice and this permission notice shall be included
  14 in all copies or substantial portions of the Software.
  15
  16 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  17 OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  18 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  19 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
  20 OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
  21 ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  22 OTHER DEALINGS IN THE SOFTWARE.
  23
  24
  25 How to use
  26 ----------
  27
  28 1. Read the documentation at:
  29    https://github.com/OdonataResearchLLC/lisp-unit/wiki
  30
  31 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  32 examples. If you want, start your test file with (REMOVE-TESTS :ALL)
  33 to clear any previously defined tests.
  34
  35 3. Load this file.
  36
  37 4. (use-package :lisp-unit)
  38
  39 5. Load your code file and your file of tests.
  40
  41 6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or
  42 simply (RUN-TESTS :ALL) to run all defined tests.
  43
  44 A summary of how many tests passed and failed will be printed.
  45
  46 NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining
  47 functions or even macros does not require reloading any tests.
  48
  49 |#
  50
  51 ;;; Packages
  52
  53 (in-package :cl-user)
  54
  55 (defpackage :lisp-unit
  56   (:use :common-lisp)
  57   ;; Print parameters
  58   (:export :*print-summary*
  59            :*print-failures*
  60            :*print-errors*
  61            :*summarize-results*)
  62   ;; Forms for assertions
  63   (:export :assert-eq
  64            :assert-eql
  65            :assert-equal
  66            :assert-equalp
  67            :assert-equality
  68            :assert-prints
  69            :assert-expands
  70            :assert-true
  71            :assert-test
  72            :assert-false
  73            :assert-error)
  74   ;; Functions for managing tests
  75   (:export :define-test
  76            :list-tests
  77            :test-code
  78            :test-documentation
  79            :remove-tests
  80            :run-tests
  81            :use-debugger)
  82   ;; Functions for managing tags
  83   (:export :list-tags
  84            :tagged-tests
  85            :remove-tags
  86            :run-tags)
  87   ;; Functions for reporting test results
  88   (:export :test-names
  89            :failed-tests
  90            :error-tests
  91            :missing-tests
  92            :print-failures
  93            :print-errors
  94            :summarize-results)
  95   ;; Functions for test results
  96   (:export :reduce-test-results-dbs)
  97   ;; Functions for extensibility via signals
  98   (:export :signal-results
  99            :test-run-complete
 100            :results)
 101   ;; Utility predicates
 102   (:export :logically-equal :set-equal))
 103
 104 (in-package :lisp-unit)
 105
 106 ;;; Global counters
 107
 108 (defparameter *pass* 0
 109   "The passed assertion results.")
 110
 111 (defparameter *fail* ()
 112   "The failed assertion results.")
 113
 114 (defun reset-counters ()
 115   "Reset the counters to empty lists."
 116   (setf *pass* 0 *fail* ()))
 117
 118 ;;; Global options
 119
 120 (defparameter *print-summary* nil
 121   "Print a summary of the pass, fail, and error count if non-nil.")
 122
 123 (defparameter *print-failures* nil
 124   "Print failure messages if non-NIL.")
 125
 126 (defparameter *print-errors* nil
 127   "Print error messages if non-NIL.")
 128
 129 (defparameter *summarize-results* t
 130   "Summarize all of the unit test results.")
 131
 132 (defparameter *use-debugger* nil
 133   "If not NIL, enter the debugger when an error is encountered in an
 134 assertion.")
 135
 136 (defun use-debugger (&optional (flag t))
 137   "Use the debugger when testing, or not."
 138   (setq *use-debugger* flag))
 139
 140 (defun use-debugger-p (condition)
 141   "Debug or ignore errors."
 142   (cond
 143    ((eq :ask *use-debugger*)
 144     (y-or-n-p "~A -- debug?" condition))
 145    (*use-debugger*)))
 146
 147 (defparameter *signal-results* nil
 148   "Signal the result if non NIL.")
 149
 150 (defun signal-results (&optional (flag t))
 151   "Signal the results for extensibility."
 152   (setq *signal-results* flag))
 153
 154 ;;; Global unit test database
 155
 156 (defparameter *test-db* (make-hash-table :test #'eq)
 157   "The unit test database is simply a hash table.")
 158
 159 (defun null-tests-warning-report (null-tests-warning stream)
 160   "Write the null-tests-warning to the stream."
 161   (format stream "No tests defined for package ~A."
 162           (tests-package-name null-tests-warning)))
 163
 164 (define-condition null-tests-warning (simple-warning)
 165   ((name
 166     :type string
 167     :initarg :name
 168     :reader tests-package-name))
 169   (:report null-tests-warning-report))
 170
 171 (defun package-table (package &optional create)
 172   (let ((packobj (find-package package)))
 173     (cond
 174      ((gethash packobj *test-db*))
 175      (create
 176       (setf (gethash packobj *test-db*) (make-hash-table)))
 177      (t (warn 'null-tests-warning :name (package-name package))))))
 178
 179 (defmacro with-package-table ((table
 180                                &optional (package *package*) create)
 181                               &body body)
 182   "Execute the body only if the package table exists."
 183   (let ((gtable (gensym "TABLE-")))
 184     `(let* ((,gtable (package-table ,package ,create))
 185             (,table ,gtable))
 186        (when (hash-table-p ,gtable) ,@body))))
 187
 188 ;;; Global tags database
 189
 190 (defparameter *tag-db* (make-hash-table :test #'eq)
 191   "The tag database is simply a hash table.")
 192
 193 (defun null-tags-warning-report (null-tags-warning stream)
 194   "Write the null-tags-warning to the stream."
 195   (format stream "No tags defined for package ~A."
 196           (tags-package-name null-tags-warning)))
 197
 198 (define-condition null-tags-warning (simple-warning)
 199   ((name
 200     :type string
 201     :initarg :name
 202     :reader tags-package-name))
 203   (:report null-tags-warning-report))
 204
 205 (defun package-tags (package &optional create)
 206   "Return the tags DB for the package."
 207   (let ((packobj (find-package package)))
 208     (cond
 209      ((gethash packobj *tag-db*))
 210      (create
 211       (setf (gethash packobj *tag-db*) (make-hash-table)))
 212      (t (warn 'null-tags-warning :name (package-name package))))))
 213
 214 (defmacro with-package-tags ((table
 215                               &optional (package *package*) create)
 216                              &body body)
 217   "Execute the body only if the package tags exists."
 218   (let ((gtable (gensym "TABLE-")))
 219     `(let* ((,gtable (package-tags ,package ,create))
 220             (,table ,gtable))
 221        (when (hash-table-p ,gtable) ,@body))))
 222
 223 ;;; Unit test definition
 224
 225 (defclass unit-test ()
 226   ((doc
 227     :type string
 228     :initarg :doc
 229     :reader doc)
 230    (code
 231     :type list
 232     :initarg :code
 233     :reader code))
 234   (:default-initargs :doc "" :code ())
 235   (:documentation
 236    "Organize the unit test documentation and code."))
 237
 238 ;;; NOTE: Shamelessly taken from PG's analyze-body
 239 (defun parse-body (body &optional doc tag)
 240   "Separate the components of the body."
 241   (let ((item (first body)))
 242     (cond
 243      ((and (listp item) (eq :tag (first item)))
 244       (parse-body (rest body) doc (nconc (rest item) tag)))
 245      ((and (stringp item) (not doc) (rest body))
 246       (if tag
 247           (values doc tag (rest body))
 248           (parse-body (rest body) item tag)))
 249      (t (values doc tag body)))))
 250
 251 (defun test-name-error-report (test-name-error stream)
 252   "Write the test-name-error to the stream."
 253   (format stream "Test name ~S is not of type ~A."
 254           (type-error-datum test-name-error)
 255           (type-error-expected-type test-name-error)))
 256
 257 (define-condition test-name-error (type-error)
 258   ()
 259   (:default-initargs :expected-type 'symbol)
 260   (:report test-name-error-report)
 261   (:documentation
 262    "The test name error is a type error."))
 263
 264 (defun valid-test-name (name)
 265   "Signal a type-error if the test name is not a symbol."
 266   (if (symbolp name)
 267       name
 268       (error 'test-name-error :datum name)))
 269
 270 (defun test-package (name)
 271   "Return the package for storing the test."
 272   (multiple-value-bind (symbol status)
 273       (find-symbol (symbol-name name))
 274     (declare (ignore symbol))
 275     (ecase status
 276       ((:internal :external nil)
 277        (symbol-package name))
 278       (:inherited *package*))))
 279
 280 (defmacro define-test (name &body body)
 281   "Store the test in the test database."
 282   (let ((qname (gensym "NAME-")))
 283     (multiple-value-bind (doc tag code) (parse-body body)
 284       `(let* ((,qname (valid-test-name ',name))
 285               (doc (or ,doc (symbol-name ,qname)))
 286               (package (test-package ,qname)))
 287          (setf
 288           ;; Unit test
 289           (gethash ,qname (package-table package t))
 290           (make-instance 'unit-test :doc doc :code ',code))
 291          ;; Tags
 292          (loop
 293           for tag in ',tag do
 294           (pushnew ,qname (gethash tag (package-tags package t))))
 295          ;; Return the name of the test
 296          ,qname))))
 297
 298 ;;; Manage tests
 299
 300 (defun list-tests (&optional (package *package*))
 301   "Return a list of the tests in package."
 302   (with-package-table (table package)
 303     (loop for test-name being each hash-key in table
 304           collect test-name)))
 305
 306 (defun test-documentation (name &optional (package *package*))
 307   "Return the documentation for the test."
 308   (with-package-table (table package)
 309     (let ((unit-test (gethash name table)))
 310       (if (null unit-test)
 311           (warn "No test ~A in package ~A."
 312                 name (package-name package))
 313           (doc unit-test)))))
 314
 315 (defun test-code (name &optional (package *package*))
 316   "Returns the code stored for the test name."
 317   (with-package-table (table package)
 318     (let ((unit-test (gethash name table)))
 319       (if (null unit-test)
 320           (warn "No test ~A in package ~A."
 321                 name (package-name package))
 322           (code unit-test)))))
 323
 324 (defun remove-tests (&optional (names :all) (package *package*))
 325   "Remove individual tests or entire sets."
 326   (if (eq :all names)
 327       (if (null package)
 328           (clrhash *test-db*)
 329           (progn
 330             (remhash (find-package package) *test-db*)
 331             (remhash (find-package package) *tag-db*)))
 332       (progn
 333         ;; Remove tests
 334         (with-package-table (table package)
 335           (loop for name in names
 336                 unless (remhash name table) do
 337                 (warn "No test ~A in package ~A to remove."
 338                       name (package-name package))))
 339         ;; Remove tests from tags
 340         (with-package-tags (tags package)
 341           (loop for tag being each hash-key in tags
 342                 using (hash-value tagged-tests)
 343                 do
 344                 (setf
 345                  (gethash tag tags)
 346                  (set-difference tagged-tests names)))))))
 347
 348 ;;; Manage tags
 349
 350 (defun %tests-from-all-tags (&optional (package *package*))
 351   "Return all of the tests that have been tagged."
 352   (with-package-tags (table package)
 353     (loop for tests being each hash-value in table
 354           nconc (copy-list tests) into all-tests
 355           finally (return (delete-duplicates all-tests)))))
 356
 357 (defun %tests-from-tags (tags &optional (package *package*))
 358   "Return the tests associated with the tags."
 359   (with-package-tags (table package)
 360     (loop for tag in tags
 361           as tests = (gethash tag table)
 362           if (null tests) do (warn "No tests tagged with ~S." tag)
 363           else nconc (copy-list tests) into all-tests
 364           finally (return (delete-duplicates all-tests)))))
 365
 366 (defun list-tags (&optional (package *package*))
 367   "Return a list of the tags in package."
 368   (with-package-tags (table package)
 369     (loop for tag being each hash-key in table collect tag)))
 370
 371 (defun tagged-tests (&optional (tags :all) (package *package*))
 372   "Return a list of the tests associated with the tags."
 373   (if (eq :all tags)
 374       (%tests-from-all-tags package)
 375       (%tests-from-tags tags package)))
 376
 377 (defun remove-tags (&optional (tags :all) (package *package*))
 378   "Remove individual tags or entire sets."
 379   (if (eq :all tags)
 380       (if (null package)
 381           (clrhash *tag-db*)
 382           (remhash (find-package package) *tag-db*))
 383       (with-package-tags (tag-table package)
 384         (loop for tag in tags
 385               unless (remhash tag tag-table) do
 386               (warn "No tag ~A in package ~A to remove."
 387                     tag (package-name package))))))
 388
 389 ;;; Assert macros
 390
 391 (defmacro assert-eq (expected form &rest extras)
 392   "Assert whether expected and form are EQ."
 393   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 394
 395 (defmacro assert-eql (expected form &rest extras)
 396   "Assert whether expected and form are EQL."
 397   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 398
 399 (defmacro assert-equal (expected form &rest extras)
 400   "Assert whether expected and form are EQUAL."
 401   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 402
 403 (defmacro assert-equalp (expected form &rest extras)
 404   "Assert whether expected and form are EQUALP."
 405   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 406
 407 (defmacro assert-error (condition form &rest extras)
 408   "Assert whether form signals condition."
 409   `(expand-assert :error ,form (expand-error-form ,form)
 410                   ,condition ,extras))
 411
 412 (defmacro assert-expands (expansion form &rest extras)
 413   "Assert whether form expands to expansion."
 414   `(expand-assert :macro ,form
 415                   (expand-macro-form ,form nil)
 416                   ',expansion ,extras))
 417
 418 (defmacro assert-equality (test expected form &rest extras)
 419   "Assert whether expected and form are equal according to test."
 420   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 421
 422 (defmacro assert-prints (output form &rest extras)
 423   "Assert whether printing the form generates the output."
 424   `(expand-assert :output ,form (expand-output-form ,form)
 425                   ,output ,extras))
 426
 427 (defmacro assert-false (form &rest extras)
 428   "Assert whether the form is false."
 429   (if (atom form)
 430       `(expand-assert :result ,form ,form nil ,extras)
 431       `(expand-t-or-f nil ,form ,extras)))
 432
 433 (defmacro assert-true (form &rest extras)
 434   "Assert whether the form is true."
 435   (if (atom form)
 436       `(expand-assert :result ,form ,form t ,extras)
 437       `(expand-t-or-f t ,form ,extras)))
 438
 439 (defmacro expand-t-or-f (t-or-f form extras)
 440   "Expand the true/false assertions to report the arguments."
 441   (let ((fname (gensym))
 442         (args (gensym)))
 443     `(let ((,fname #',(car form))
 444            (,args (list ,@(cdr form))))
 445        (internal-assert
 446         :result ',form
 447         (lambda () (apply ,fname ,args)) ; Evaluate the form
 448         (lambda () ,t-or-f)
 449         ;; Concatenate the args with the extras
 450         (lambda ()
 451           (nconc
 452            (mapcan #'list ',(cdr form) ,args)
 453            (funcall (expand-extras ,extras))))
 454         #'eql))))
 455
 456 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 457   "Expand the assertion to the internal format."
 458   `(internal-assert ,type ',form
 459                     (lambda () ,body)
 460                     (lambda () ,expected)
 461                     (expand-extras ,extras)
 462                     ,test))
 463
 464 (defmacro expand-error-form (form)
 465   "Wrap the error assertion in HANDLER-CASE."
 466   `(handler-case ,form
 467      (condition (error) error)))
 468
 469 (defmacro expand-output-form (form)
 470   "Capture the output of the form in a string."
 471   (let ((out (gensym)))
 472     `(let* ((,out (make-string-output-stream))
 473             (*standard-output*
 474              (make-broadcast-stream *standard-output* ,out)))
 475        ,form
 476        (get-output-stream-string ,out))))
 477
 478 (defmacro expand-macro-form (form env)
 479   "Expand the macro form once."
 480   `(let ((*gensym-counter* 1))
 481      (macroexpand-1 ',form ,env)))
 482
 483 (defmacro expand-extras (extras)
 484   "Expand extra forms."
 485   `(lambda ()
 486      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 487
 488 (defgeneric assert-result (type test expected actual)
 489   (:documentation
 490    "Return the result of the assertion."))
 491
 492 (defgeneric record-failure (type form actual expected extras test)
 493   (:documentation
 494    "Record the details of the failure."))
 495
 496 (defclass failure-result ()
 497   ((form
 498     :initarg :form
 499     :reader form)
 500    (actual
 501     :type list
 502     :initarg :actual
 503     :reader actual)
 504    (expected
 505     :type list
 506     :initarg :expected
 507     :reader expected)
 508    (extras
 509     :type list
 510     :initarg :extras
 511     :reader extras)
 512    (test
 513     :type function
 514     :initarg :test
 515     :reader test))
 516   (:documentation
 517    "Failure details of the assertion."))
 518
 519 (defun %record-failure (class form actual expected extras test)
 520   "Return an instance of the failure result."
 521   (make-instance class
 522                  :form form
 523                  :actual actual
 524                  :expected expected
 525                  :extras extras
 526                  :test test))
 527
 528 (defclass equal-result (failure-result)
 529   ()
 530   (:documentation
 531    "Result of a failed equal assertion."))
 532
 533 (defmethod assert-result ((type (eql :equal)) test expected actual)
 534   "Return the result of an equal assertion."
 535   (and
 536    (<= (length expected) (length actual))
 537    (every test expected actual)))
 538
 539 (defmethod record-failure ((type (eql :equal))
 540                            form actual expected extras test)
 541   "Return an instance of an equal failure result."
 542   (%record-failure 'equal-result form actual expected extras test))
 543
 544 (defclass error-result (failure-result)
 545   ()
 546   (:documentation
 547    "Result of a failed error assertion."))
 548
 549 (defmethod assert-result ((type (eql :error)) test expected actual)
 550   "Return the result of an error assertion."
 551   (declare (ignore test))
 552   (or
 553    (eql (car actual) (car expected))
 554    (typep (car actual) (car expected))))
 555
 556 (defmethod record-failure ((type (eql :error))
 557                            form actual expected extras test)
 558   "Return an instance of an error failure result."
 559   (%record-failure 'error-result form actual expected extras test))
 560
 561 (defclass macro-result (failure-result)
 562   ()
 563   (:documentation
 564    "Result of a failed macro expansion assertion."))
 565
 566 (defun %expansion-equal (form1 form2)
 567   "Descend into the forms checking for equality."
 568   (let ((item1 (first form1))
 569         (item2 (first form2)))
 570     (cond
 571      ((and (null item1) (null item2)))
 572      ((and (listp item1) (listp item2))
 573       (and
 574        (%expansion-equal item1 item2)
 575        (%expansion-equal (rest form1) (rest form2))))
 576      ((and (symbolp item1) (symbolp item2))
 577       (and
 578        (string= (symbol-name item1) (symbol-name item2))
 579        (%expansion-equal (rest form1) (rest form2))))
 580      (t (and
 581          (equal item1 item2)
 582          (%expansion-equal (rest form1) (rest form2)))))))
 583
 584 (defmethod assert-result ((type (eql  :macro)) test expected actual)
 585   "Return the result of a macro assertion."
 586   (declare (ignore test))
 587   (%expansion-equal (first expected) (first actual)))
 588
 589 (defmethod record-failure ((type (eql :macro))
 590                            form actual expected extras test)
 591   "Return an instance of a macro failure result."
 592   (%record-failure 'macro-result form actual expected extras test))
 593
 594 (defclass boolean-result (failure-result)
 595   ()
 596   (:documentation
 597    "Result of a failed boolean assertion."))
 598
 599 (defmethod assert-result ((type (eql :result)) test expected actual)
 600   "Return the result of a result assertion."
 601   (declare (ignore test))
 602   (logically-equal (car actual) (car expected)))
 603
 604 (defmethod record-failure ((type (eql :result))
 605                            form actual expected extras test)
 606   "Return an instance of a boolean failure result."
 607   (%record-failure 'boolean-result form actual expected extras test))
 608
 609 (defclass output-result (failure-result)
 610   ()
 611   (:documentation
 612    "Result of a failed output assertion."))
 613
 614 (defmethod assert-result ((type (eql :output)) test expected actual)
 615   "Return the result of an output assertion."
 616   (declare (ignore test))
 617   (string=
 618    (string-trim '(#\newline #\return #\space) (car actual))
 619    (car expected)))
 620
 621 (defmethod record-failure ((type (eql :output))
 622                            form actual expected extras test)
 623   "Return an instance of an output failure result."
 624   (%record-failure 'output-result form actual expected extras test))
 625
 626 (defun internal-assert
 627        (type form code-thunk expected-thunk extras test)
 628   "Perform the assertion and record the results."
 629   (let* ((actual (multiple-value-list (funcall code-thunk)))
 630          (expected (multiple-value-list (funcall expected-thunk)))
 631          (result (assert-result type test expected actual)))
 632     (if result
 633         (incf *pass*)
 634         (push
 635          (record-failure
 636           type form actual expected
 637           (when extras (funcall extras)) test)
 638          *fail*))
 639     ;; Return the result
 640     result))
 641
 642 ;;; Unit test results
 643
 644 (defclass test-result ()
 645   ((name
 646     :type symbol
 647     :initarg :name
 648     :reader name)
 649    (pass
 650     :type fixnum
 651     :initarg :pass
 652     :reader pass)
 653    (fail
 654     :type list
 655     :initarg :fail
 656     :reader fail)
 657    (exerr
 658     :initarg :exerr
 659     :reader exerr)
 660    (run-time
 661     :initarg :run-time
 662     :reader run-time
 663     :documentation
 664     "Test run time measured in internal time units"))
 665   (:default-initargs :exerr nil)
 666   (:documentation
 667    "Store the results of the unit test."))
 668
 669 (defun print-summary (test-result &optional
 670                       (stream *standard-output*))
 671   "Print a summary of the test result."
 672   (format stream "~&~A: ~S assertions passed, ~S failed"
 673           (name test-result)
 674           (pass test-result)
 675           (length (fail test-result)))
 676   (if (exerr test-result)
 677       (format stream ", and an execution error.")
 678       (write-char #\. stream))
 679   (terpri stream)
 680   (terpri stream))
 681
 682 (defun run-code (code)
 683   "Run the code to test the assertions."
 684   (funcall (coerce `(lambda () ,@code) 'function)))
 685
 686 (defun run-test-thunk (name code)
 687   (let ((*pass* 0)
 688         (*fail* ())
 689         (start (get-internal-run-time)))
 690     (handler-bind
 691         ((error
 692           (lambda (condition)
 693             (if (use-debugger-p condition)
 694                 condition
 695                 (return-from run-test-thunk
 696                   (make-instance
 697                    'test-result
 698                    :name name
 699                    :pass *pass*
 700                    :fail *fail*
 701                    :run-time (- (get-internal-run-time) start)
 702                    :exerr condition))))))
 703       (run-code code))
 704     ;; Return the result count
 705     (make-instance
 706      'test-result
 707      :name name
 708      :pass *pass*
 709      :fail *fail*
 710      :run-time (- (get-internal-run-time) start))))
 711
 712 ;;; Test results database
 713
 714 (defclass test-results-db ()
 715   ((database
 716     :type hash-table
 717     :initform (make-hash-table :test #'eq)
 718     :reader database)
 719    (pass
 720     :type fixnum
 721     :initform 0
 722     :accessor pass)
 723    (fail
 724     :type fixnum
 725     :initform 0
 726     :accessor fail)
 727    (exerr
 728     :type fixnum
 729     :initform 0
 730     :accessor exerr)
 731    (failed-tests
 732     :type list
 733     :initform ()
 734     :accessor failed-tests)
 735    (error-tests
 736     :type list
 737     :initform ()
 738     :accessor error-tests)
 739    (missing-tests
 740     :type list
 741     :initform ()
 742     :accessor missing-tests))
 743   (:documentation
 744    "Store the results of the tests for further evaluation."))
 745
 746 (defmethod print-object ((object test-results-db) stream)
 747   "Print the summary counts with the object."
 748   (let ((pass (pass object))
 749         (fail (fail object))
 750         (exerr (exerr object)))
 751     (format
 752      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 753      (class-name (class-of object))
 754      (+ pass fail) pass fail exerr)))
 755
 756 (defun test-names (test-results-db)
 757   "Return a list of the test names in the database."
 758   (loop for name being each hash-key in (database test-results-db)
 759         collect name))
 760
 761 (defun record-result (test-name code results)
 762   "Run the test code and record the result."
 763   (let ((result (run-test-thunk test-name code)))
 764     ;; Store the result
 765     (setf (gethash test-name (database results)) result)
 766     ;; Count passed tests
 767     (when (plusp (pass result))
 768       (incf (pass results) (pass result)))
 769     ;; Count failed tests and record the name
 770     (when (fail result)
 771       (incf (fail results) (length (fail result)))
 772       (push test-name (failed-tests results)))
 773     ;; Count errors and record the name
 774     (when (exerr result)
 775       (incf (exerr results))
 776       (push test-name (error-tests results)))
 777     ;; Running output
 778     (when *print-failures* (print-failures result))
 779     (when *print-errors* (print-errors result))
 780     (when (or *print-summary* *print-failures* *print-errors*)
 781       (print-summary result))))
 782
 783 (defun summarize-results (results &optional
 784                           (stream *standard-output*))
 785   "Print a summary of all results to the stream."
 786   (let ((pass (pass results))
 787         (fail (fail results)))
 788     (format stream "~&Unit Test Summary~%")
 789     (format stream " | ~D assertions total~%" (+ pass fail))
 790     (format stream " | ~D passed~%" pass)
 791     (format stream " | ~D failed~%" fail)
 792     (format stream " | ~D execution errors~%" (exerr results))
 793     (format stream " | ~D missing tests~2%"
 794             (length (missing-tests results)))))
 795
 796 (defun default-db-merge-function (results new-results)
 797   "Signal an error by default if a merge is required."
 798   (lambda (key value1 value2)
 799     (error
 800      "Cannot merge TEST-RESULTS-DB instances ~A and ~A as key ~A has
 801 two values, ~A and ~A"
 802      results new-results key value1 value2)))
 803
 804 (defun nappend-test-results-db (results new-results &key merge)
 805   "Merge the results of NEW-RESULTS in to RESULTS. Any conflicts
 806 between RESULTS and NEW-RESULTS are handled by the function MERGE.
 807
 808 The lambda list for the MERGE functions is
 809
 810   (key results-value new-results-value)
 811
 812 where:
 813   KEY is the key which appears in RESULTS and NEW-RESULTS.
 814   RESULTS-VALUE is the value appearing RESULTS.
 815   NEW-RESULTS-VALUE is the value appearing in NEW-RESULTS.
 816
 817 If MERGE is NIL, then an error is signalled when a conflict occurs.
 818 "
 819   (check-type results test-results-db)
 820   (check-type new-results test-results-db)
 821   (check-type merge (or null function))
 822   (loop
 823    with results-db = (database results)
 824    with new-results-db = (database new-results)
 825    with merge =
 826    (or merge (default-db-merge-function results new-results))
 827    ;; Merge test databases
 828    for key being each hash-key in new-results-db
 829    using (hash-value new-results-value)
 830    do
 831    (multiple-value-bind (results-value presentp)
 832        (gethash key results-db)
 833      (setf
 834       (gethash key results-db)
 835       (if presentp
 836           (funcall merge key results-value new-results-value)
 837           new-results-value)))
 838    finally
 839    ;; Update counters
 840    (incf (pass results) (pass new-results))
 841    (incf (fail results) (fail new-results))
 842    (incf (exerr results) (exerr new-results))
 843    ;; Merge failures, errors, and missing test details
 844    (setf
 845     ;; Failures
 846     (failed-tests results)
 847     (append (failed-tests results) (failed-tests new-results))
 848     ;; Errors
 849     (error-tests results)
 850     (append (error-tests results) (error-tests new-results))
 851     ;; Missing tests
 852     (missing-tests results)
 853     (append (missing-tests results) (missing-tests new-results))))
 854    ;; Return the merged results
 855    results)
 856
 857 (defun reduce-test-results-dbs (all-results &key merge)
 858   "Return a new instance of TEST-RESULTS-DB which contains all of the
 859 results in the sequence RESULTS. Any conflicts are handled by the
 860 function MERGE.
 861
 862 The lambda list for the MERGE function is
 863
 864   (key value-1 value-2)
 865
 866 where:
 867   KEY is the key which appears at least twice in the sequence RESULTS.
 868   VALUE-1 and VALUE-2 are the conflicting values for the given KEY.
 869
 870 If MERGE is NIL, then an error is signalled when a conflict occurs."
 871   (loop
 872    with accumulated-test-results-db = (make-instance 'test-results-db)
 873    for new-results in all-results do
 874    (nappend-test-results-db
 875     accumulated-test-results-db new-results :merge merge)
 876    finally (return accumulated-test-results-db)))
 877
 878 ;;; Run the tests
 879
 880 (define-condition test-run-complete ()
 881   ((results
 882     :type 'test-results-db
 883     :initarg :results
 884     :reader results))
 885   (:documentation
 886    "Signaled when a test run is finished."))
 887
 888 (defun %run-all-thunks (&optional (package *package*))
 889   "Run all of the test thunks in the package."
 890   (with-package-table (table package)
 891     (loop
 892      with results = (make-instance 'test-results-db)
 893      for test-name being each hash-key in table
 894      using (hash-value unit-test)
 895      if unit-test do
 896      (record-result test-name (code unit-test) results)
 897      else do
 898      (push test-name (missing-tests results))
 899      ;; Summarize and return the test results
 900      finally
 901      (when *signal-results*
 902        (signal 'test-run-complete :results results))
 903      (when *summarize-results*
 904        (summarize-results results))
 905      (return results))))
 906
 907 (defun %run-thunks (test-names &optional (package *package*))
 908   "Run the list of test thunks in the package."
 909   (with-package-table (table package)
 910     (loop
 911      with results = (make-instance 'test-results-db)
 912      for test-name in test-names
 913      as unit-test = (gethash test-name table)
 914      if unit-test do
 915      (record-result test-name (code unit-test) results)
 916      else do
 917      (push test-name (missing-tests results))
 918      finally
 919      (when *signal-results*
 920        (signal 'test-run-complete :results results))
 921      (when *summarize-results*
 922        (summarize-results results))
 923      (return results))))
 924
 925 (defun run-tests (&optional (test-names :all) (package *package*))
 926   "Run the specified tests in package."
 927   (reset-counters)
 928   (if (eq :all test-names)
 929       (%run-all-thunks package)
 930       (%run-thunks test-names package)))
 931
 932 (defun run-tags (&optional (tags :all) (package *package*))
 933   "Run the tests associated with the specified tags in package."
 934   (reset-counters)
 935   (%run-thunks (tagged-tests tags package) package))
 936
 937 ;;; Print failures
 938
 939 (defgeneric print-failures (result &optional stream)
 940   (:documentation
 941    "Report the results of the failed assertion."))
 942
 943 (defmethod print-failures :around ((result failure-result) &optional
 944                                    (stream *standard-output*))
 945   "Failure header and footer output."
 946   (format stream "~& | Failed Form: ~S" (form result))
 947   (call-next-method)
 948   (when (extras result)
 949     (format stream "~{~& | ~S => ~S~}~%" (extras result)))
 950   (format stream "~& |~%"))
 951
 952 (defmethod print-failures ((result failure-result) &optional
 953                            (stream *standard-output*))
 954   (format stream "~& | Expected ~{~S~^; ~} " (expected result))
 955   (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 956
 957 (defmethod print-failures ((result error-result) &optional
 958                            (stream *standard-output*))
 959   (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 960           (expected result))
 961   (format stream " ~{~S~^; ~}" (actual result)))
 962
 963 (defmethod print-failures ((result macro-result) &optional
 964                            (stream *standard-output*))
 965   (format stream "~& | Should have expanded to ~{~S~^; ~} "
 966           (expected result))
 967   (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 968
 969 (defmethod print-failures ((result output-result) &optional
 970                            (stream *standard-output*))
 971   (format stream "~& | Should have printed ~{~S~^; ~} "
 972           (expected result))
 973   (format stream "~<~%~:;but saw ~{~S~^; ~}~>"
 974           (actual result)))
 975
 976 (defmethod print-failures ((result test-result) &optional
 977                            (stream *standard-output*))
 978   "Print the failed assertions in the unit test."
 979   (loop for fail in (fail result) do
 980         (print-failures fail stream)))
 981
 982 (defmethod print-failures ((results test-results-db) &optional
 983                            (stream *standard-output*))
 984   "Print all of the failure tests."
 985   (loop with db = (database results)
 986         for test in (failed-tests results)
 987         as result = (gethash test db)
 988         do
 989         (print-failures result stream)
 990         (print-summary result stream)))
 991
 992 ;;; Print errors
 993
 994 (defgeneric print-errors (result &optional stream)
 995   (:documentation
 996    "Print the error condition."))
 997
 998 (defmethod print-errors ((result test-result) &optional
 999                          (stream *standard-output*))
1000   "Print the error condition."
1001   (let ((exerr (exerr result))
1002         (*print-escape* nil))
1003     (when exerr
1004       (format stream "~& | Execution error:~% | ~W" exerr)
1005       (format stream "~& |~%"))))
1006
1007 (defmethod print-errors ((results test-results-db) &optional
1008                          (stream *standard-output*))
1009   "Print all of the error tests."
1010   (loop with db = (database results)
1011         for test in (error-tests results)
1012         as result = (gethash test db)
1013         do
1014         (print-errors result stream)
1015         (print-summary result stream)))
1016
1017 ;;; Useful equality predicates for tests
1018
1019 (defun logically-equal (x y)
1020   "Return true if x and y are both false or both true."
1021   (eql (not x) (not y)))
1022
1023 (defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
1024   "Return true if every element of list1 is an element of list2 and
1025 vice versa."
1026   (declare (ignore key test))
1027   (and
1028    (listp list1)
1029    (listp list2)
1030    (apply #'subsetp list1 list2 initargs)
1031    (apply #'subsetp list2 list1 initargs)))
1032
1033 (pushnew :lisp-unit common-lisp:*features*)