lisp-unit.lisp

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