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        (internal-assert
 454         :result ',form
 455         (lambda () (apply ,fname ,args)) ; Evaluate the form
 456         (lambda () ,t-or-f)
 457         ;; Concatenate the args with the extras
 458         (lambda ()
 459           (nconc
 460            (mapcan #'list ',(cdr form) ,args)
 461            (funcall (expand-extras ,extras))))
 462         #'eql))))
 463
 464 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 465   "Expand the assertion to the internal format."
 466   `(internal-assert ,type ',form
 467                     (lambda () ,body)
 468                     (lambda () ,expected)
 469                     (expand-extras ,extras)
 470                     ,test))
 471
 472 (defmacro expand-error-form (form)
 473   "Wrap the error assertion in HANDLER-CASE."
 474   `(handler-case ,form
 475      (condition (error) error)))
 476
 477 (defmacro expand-output-form (form)
 478   "Capture the output of the form in a string."
 479   (let ((out (gensym)))
 480     `(let* ((,out (make-string-output-stream))
 481             (*standard-output*
 482              (make-broadcast-stream *standard-output* ,out)))
 483        ,form
 484        (get-output-stream-string ,out))))
 485
 486 (defmacro expand-macro-form (form env)
 487   "Expand the macro form once."
 488   `(let ((*gensym-counter* 1))
 489      (macroexpand-1 ',form ,env)))
 490
 491 (defmacro expand-extras (extras)
 492   "Expand extra forms."
 493   `(lambda ()
 494      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 495
 496 (defgeneric assert-result (type test expected actual)
 497   (:documentation
 498    "Return the result of the assertion."))
 499
 500 (defgeneric record-failure (type form actual expected extras test)
 501   (:documentation
 502    "Record the details of the failure."))
 503
 504 (defclass failure-result ()
 505   ((form
 506     :initarg :form
 507     :reader form)
 508    (actual
 509     :type list
 510     :initarg :actual
 511     :reader actual)
 512    (expected
 513     :type list
 514     :initarg :expected
 515     :reader expected)
 516    (extras
 517     :type list
 518     :initarg :extras
 519     :reader extras)
 520    (test
 521     :type function
 522     :initarg :test
 523     :reader test))
 524   (:documentation
 525    "Failure details of the assertion."))
 526
 527 (defun %record-failure (class form actual expected extras test)
 528   "Return an instance of the failure result."
 529   (make-instance class
 530                  :form form
 531                  :actual actual
 532                  :expected expected
 533                  :extras extras
 534                  :test test))
 535
 536 (defclass equal-result (failure-result)
 537   ()
 538   (:documentation
 539    "Result of a failed equal assertion."))
 540
 541 (defmethod assert-result ((type (eql :equal)) test expected actual)
 542   "Return the result of an equal assertion."
 543   (and
 544    (<= (length expected) (length actual))
 545    (every test expected actual)))
 546
 547 (defmethod record-failure ((type (eql :equal))
 548                            form actual expected extras test)
 549   "Return an instance of an equal failure result."
 550   (%record-failure 'equal-result form actual expected extras test))
 551
 552 (defclass error-result (failure-result)
 553   ()
 554   (:documentation
 555    "Result of a failed error assertion."))
 556
 557 (defmethod assert-result ((type (eql :error)) test expected actual)
 558   "Return the result of an error assertion."
 559   (declare (ignore test))
 560   (or
 561    (eql (car actual) (car expected))
 562    (typep (car actual) (car expected))))
 563
 564 (defmethod record-failure ((type (eql :error))
 565                            form actual expected extras test)
 566   "Return an instance of an error failure result."
 567   (%record-failure 'error-result form actual expected extras test))
 568
 569 (defclass macro-result (failure-result)
 570   ()
 571   (:documentation
 572    "Result of a failed macro expansion assertion."))
 573
 574 (defun %expansion-equal (form1 form2)
 575   "Descend into the forms checking for equality."
 576   (let ((item1 (first form1))
 577         (item2 (first form2)))
 578     (cond
 579      ((and (null item1) (null item2)))
 580      ((and (listp item1) (listp item2))
 581       (and
 582        (%expansion-equal item1 item2)
 583        (%expansion-equal (rest form1) (rest form2))))
 584      ((and (symbolp item1) (symbolp item2))
 585       (and
 586        (string= (symbol-name item1) (symbol-name item2))
 587        (%expansion-equal (rest form1) (rest form2))))
 588      (t (and
 589          (equal item1 item2)
 590          (%expansion-equal (rest form1) (rest form2)))))))
 591
 592 (defmethod assert-result ((type (eql  :macro)) test expected actual)
 593   "Return the result of a macro assertion."
 594   (declare (ignore test))
 595   (%expansion-equal (first expected) (first actual)))
 596
 597 (defmethod record-failure ((type (eql :macro))
 598                            form actual expected extras test)
 599   "Return an instance of a macro failure result."
 600   (%record-failure 'macro-result form actual expected extras test))
 601
 602 (defclass boolean-result (failure-result)
 603   ()
 604   (:documentation
 605    "Result of a failed boolean assertion."))
 606
 607 (defmethod assert-result ((type (eql :result)) test expected actual)
 608   "Return the result of a result assertion."
 609   (declare (ignore test))
 610   (logically-equal (car actual) (car expected)))
 611
 612 (defmethod record-failure ((type (eql :result))
 613                            form actual expected extras test)
 614   "Return an instance of a boolean failure result."
 615   (%record-failure 'boolean-result form actual expected extras test))
 616
 617 (defclass output-result (failure-result)
 618   ()
 619   (:documentation
 620    "Result of a failed output assertion."))
 621
 622 (defmethod assert-result ((type (eql :output)) test expected actual)
 623   "Return the result of an output assertion."
 624   (declare (ignore test))
 625   (string=
 626    (string-trim '(#\newline #\return #\space) (car actual))
 627    (car expected)))
 628
 629 (defmethod record-failure ((type (eql :output))
 630                            form actual expected extras test)
 631   "Return an instance of an output failure result."
 632   (%record-failure 'output-result form actual expected extras test))
 633
 634 (defun internal-assert
 635        (type form code-thunk expected-thunk extras test)
 636   "Perform the assertion and record the results."
 637   (let* ((actual (multiple-value-list (funcall code-thunk)))
 638          (expected (multiple-value-list (funcall expected-thunk)))
 639          (result (assert-result type test expected actual)))
 640     (if result
 641         (incf *pass*)
 642         (push
 643          (record-failure
 644           type form actual expected
 645           (when extras (funcall extras)) test)
 646          *fail*))
 647     ;; Return the result
 648     result))
 649
 650 ;;; Unit test results
 651
 652 (defclass test-result ()
 653   ((name
 654     :type symbol
 655     :initarg :name
 656     :reader name)
 657    (pass
 658     :type fixnum
 659     :initarg :pass
 660     :reader pass)
 661    (fail
 662     :type list
 663     :initarg :fail
 664     :reader fail)
 665    (exerr
 666     :initarg :exerr
 667     :reader exerr)
 668    (run-time
 669     :initarg :run-time
 670     :reader run-time
 671     :documentation
 672     "Test run time measured in internal time units"))
 673   (:default-initargs :exerr nil)
 674   (:documentation
 675    "Store the results of the unit test."))
 676
 677 (defun print-summary (test-result &optional
 678                       (stream *standard-output*))
 679   "Print a summary of the test result."
 680   (format stream "~&~A: ~S assertions passed, ~S failed"
 681           (name test-result)
 682           (pass test-result)
 683           (length (fail test-result)))
 684   (if (exerr test-result)
 685       (format stream ", and an execution error.")
 686       (write-char #\. stream))
 687   (terpri stream)
 688   (terpri stream))
 689
 690 (defun run-code (code)
 691   "Run the code to test the assertions."
 692   (funcall (coerce `(lambda () ,@code) 'function)))
 693
 694 (defun run-test-thunk (name code)
 695   (let ((*pass* 0)
 696         (*fail* ())
 697         (start (get-internal-run-time)))
 698     (handler-bind
 699         ((error
 700           (lambda (condition)
 701             (if (use-debugger-p condition)
 702                 condition
 703                 (return-from run-test-thunk
 704                   (make-instance
 705                    'test-result
 706                    :name name
 707                    :pass *pass*
 708                    :fail *fail*
 709                    :run-time (- (get-internal-run-time) start)
 710                    :exerr condition))))))
 711       (run-code code))
 712     ;; Return the result count
 713     (make-instance
 714      'test-result
 715      :name name
 716      :pass *pass*
 717      :fail *fail*
 718      :run-time (- (get-internal-run-time) start))))
 719
 720 ;;; Test results database
 721
 722 (defclass test-results-db ()
 723   ((database
 724     :type hash-table
 725     :initform (make-hash-table :test #'eq)
 726     :reader database)
 727    (pass
 728     :type fixnum
 729     :initform 0
 730     :accessor pass)
 731    (fail
 732     :type fixnum
 733     :initform 0
 734     :accessor fail)
 735    (exerr
 736     :type fixnum
 737     :initform 0
 738     :accessor exerr)
 739    (failed-tests
 740     :type list
 741     :initform ()
 742     :accessor failed-tests)
 743    (error-tests
 744     :type list
 745     :initform ()
 746     :accessor error-tests)
 747    (missing-tests
 748     :type list
 749     :initform ()
 750     :accessor missing-tests))
 751   (:documentation
 752    "Store the results of the tests for further evaluation."))
 753
 754 (defmethod print-object ((object test-results-db) stream)
 755   "Print the summary counts with the object."
 756   (let ((pass (pass object))
 757         (fail (fail object))
 758         (exerr (exerr object)))
 759     (format
 760      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 761      (class-name (class-of object))
 762      (+ pass fail) pass fail exerr)))
 763
 764 (defun test-names (test-results-db)
 765   "Return a list of the test names in the database."
 766   (loop for name being each hash-key in (database test-results-db)
 767         collect name))
 768
 769 (defun record-result (test-name code results)
 770   "Run the test code and record the result."
 771   (let ((result (run-test-thunk test-name code)))
 772     ;; Store the result
 773     (setf (gethash test-name (database results)) result)
 774     ;; Count passed tests
 775     (when (plusp (pass result))
 776       (incf (pass results) (pass result)))
 777     ;; Count failed tests and record the name
 778     (when (fail result)
 779       (incf (fail results) (length (fail result)))
 780       (push test-name (failed-tests results)))
 781     ;; Count errors and record the name
 782     (when (exerr result)
 783       (incf (exerr results))
 784       (push test-name (error-tests results)))
 785     ;; Running output
 786     (when *print-failures* (print-failures result))
 787     (when *print-errors* (print-errors result))
 788     (when (or *print-summary* *print-failures* *print-errors*)
 789       (print-summary result))))
 790
 791 (defun summarize-results (results &optional
 792                           (stream *standard-output*))
 793   "Print a summary of all results to the stream."
 794   (let ((pass (pass results))
 795         (fail (fail results)))
 796     (format stream "~&Unit Test Summary~%")
 797     (format stream " | ~D assertions total~%" (+ pass fail))
 798     (format stream " | ~D passed~%" pass)
 799     (format stream " | ~D failed~%" fail)
 800     (format stream " | ~D execution errors~%" (exerr results))
 801     (format stream " | ~D missing tests~2%"
 802             (length (missing-tests results)))))
 803
 804 (defun default-db-merge-function (results new-results)
 805   "Signal an error by default if a merge is required."
 806   (lambda (key value1 value2)
 807     (error
 808      "Cannot merge TEST-RESULTS-DB instances ~A and ~A as key ~A has
 809 two values, ~A and ~A"
 810      results new-results key value1 value2)))
 811
 812 (defun nappend-test-results-db (results new-results &key merge)
 813   "Merge the results of NEW-RESULTS in to RESULTS. Any conflicts
 814 between RESULTS and NEW-RESULTS are handled by the function MERGE.
 815
 816 The lambda list for the MERGE functions is
 817
 818   (key results-value new-results-value)
 819
 820 where:
 821   KEY is the key which appears in RESULTS and NEW-RESULTS.
 822   RESULTS-VALUE is the value appearing RESULTS.
 823   NEW-RESULTS-VALUE is the value appearing in NEW-RESULTS.
 824
 825 If MERGE is NIL, then an error is signalled when a conflict occurs.
 826 "
 827   (check-type results test-results-db)
 828   (check-type new-results test-results-db)
 829   (check-type merge (or null function))
 830   (loop
 831    with results-db = (database results)
 832    with new-results-db = (database new-results)
 833    with merge =
 834    (or merge (default-db-merge-function results new-results))
 835    ;; Merge test databases
 836    for key being each hash-key in new-results-db
 837    using (hash-value new-results-value)
 838    do
 839    (multiple-value-bind (results-value presentp)
 840        (gethash key results-db)
 841      (setf
 842       (gethash key results-db)
 843       (if presentp
 844           (funcall merge key results-value new-results-value)
 845           new-results-value)))
 846    finally
 847    ;; Update counters
 848    (incf (pass results) (pass new-results))
 849    (incf (fail results) (fail new-results))
 850    (incf (exerr results) (exerr new-results))
 851    ;; Merge failures, errors, and missing test details
 852    (setf
 853     ;; Failures
 854     (failed-tests results)
 855     (append (failed-tests results) (failed-tests new-results))
 856     ;; Errors
 857     (error-tests results)
 858     (append (error-tests results) (error-tests new-results))
 859     ;; Missing tests
 860     (missing-tests results)
 861     (append (missing-tests results) (missing-tests new-results))))
 862    ;; Return the merged results
 863    results)
 864
 865 (defun reduce-test-results-dbs (all-results &key merge)
 866   "Return a new instance of TEST-RESULTS-DB which contains all of the
 867 results in the sequence RESULTS. Any conflicts are handled by the
 868 function MERGE.
 869
 870 The lambda list for the MERGE function is
 871
 872   (key value-1 value-2)
 873
 874 where:
 875   KEY is the key which appears at least twice in the sequence RESULTS.
 876   VALUE-1 and VALUE-2 are the conflicting values for the given KEY.
 877
 878 If MERGE is NIL, then an error is signalled when a conflict occurs."
 879   (loop
 880    with accumulated-test-results-db = (make-instance 'test-results-db)
 881    for new-results in all-results do
 882    (nappend-test-results-db
 883     accumulated-test-results-db new-results :merge merge)
 884    finally (return accumulated-test-results-db)))
 885
 886 ;;; Run the tests
 887
 888 (define-condition test-run-complete ()
 889   ((results
 890     :type 'test-results-db
 891     :initarg :results
 892     :reader results))
 893   (:documentation
 894    "Signaled when a test run is finished."))
 895
 896 (defun %run-all-thunks (&optional (package *package*))
 897   "Run all of the test thunks in the package."
 898   (with-package-table (table package)
 899     (loop
 900      with results = (make-instance 'test-results-db)
 901      for test-name being each hash-key in table
 902      using (hash-value unit-test)
 903      if unit-test do
 904      (record-result test-name (code unit-test) results)
 905      else do
 906      (push test-name (missing-tests results))
 907      ;; Summarize and return the test results
 908      finally
 909      (when *signal-results*
 910        (signal 'test-run-complete :results results))
 911      (when *summarize-results*
 912        (summarize-results results))
 913      (return results))))
 914
 915 (defun %run-thunks (test-names &optional (package *package*))
 916   "Run the list of test thunks in the package."
 917   (with-package-table (table package)
 918     (loop
 919      with results = (make-instance 'test-results-db)
 920      for test-name in test-names
 921      as unit-test = (gethash test-name table)
 922      if unit-test do
 923      (record-result test-name (code unit-test) results)
 924      else do
 925      (push test-name (missing-tests results))
 926      finally
 927      (when *signal-results*
 928        (signal 'test-run-complete :results results))
 929      (when *summarize-results*
 930        (summarize-results results))
 931      (return results))))
 932
 933 (defun run-tests (&optional (test-names :all) (package *package*))
 934   "Run the specified tests in package."
 935   (reset-counters)
 936   (if (eq :all test-names)
 937       (%run-all-thunks package)
 938       (%run-thunks test-names package)))
 939
 940 (defun run-tags (&optional (tags :all) (package *package*))
 941   "Run the tests associated with the specified tags in package."
 942   (reset-counters)
 943   (%run-thunks (tagged-tests tags package) package))
 944
 945 ;;; Print failures
 946
 947 (defgeneric print-failures (result &optional stream)
 948   (:documentation
 949    "Report the results of the failed assertion."))
 950
 951 (defmethod print-failures :around ((result failure-result) &optional
 952                                    (stream *standard-output*))
 953   "Failure header and footer output."
 954   (format stream "~& | Failed Form: ~S" (form result))
 955   (call-next-method)
 956   (when (extras result)
 957     (format stream "~{~& | ~S => ~S~}~%" (extras result)))
 958   (format stream "~& |~%"))
 959
 960 (defmethod print-failures ((result failure-result) &optional
 961                            (stream *standard-output*))
 962   (format stream "~& | Expected ~{~S~^; ~} " (expected result))
 963   (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 964
 965 (defmethod print-failures ((result error-result) &optional
 966                            (stream *standard-output*))
 967   (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 968           (expected result))
 969   (format stream " ~{~S~^; ~}" (actual result)))
 970
 971 (defmethod print-failures ((result macro-result) &optional
 972                            (stream *standard-output*))
 973   (format stream "~& | Should have expanded to ~{~S~^; ~} "
 974           (expected result))
 975   (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 976
 977 (defmethod print-failures ((result output-result) &optional
 978                            (stream *standard-output*))
 979   (format stream "~& | Should have printed ~{~S~^; ~} "
 980           (expected result))
 981   (format stream "~<~%~:;but saw ~{~S~^; ~}~>"
 982           (actual result)))
 983
 984 (defmethod print-failures ((result test-result) &optional
 985                            (stream *standard-output*))
 986   "Print the failed assertions in the unit test."
 987   (loop for fail in (fail result) do
 988         (print-failures fail stream)))
 989
 990 (defmethod print-failures ((results test-results-db) &optional
 991                            (stream *standard-output*))
 992   "Print all of the failure tests."
 993   (loop with db = (database results)
 994         for test in (failed-tests results)
 995         as result = (gethash test db)
 996         do
 997         (print-failures result stream)
 998         (print-summary result stream)))
 999
1000 ;;; Print errors
1001
1002 (defgeneric print-errors (result &optional stream)
1003   (:documentation
1004    "Print the error condition."))
1005
1006 (defmethod print-errors ((result test-result) &optional
1007                          (stream *standard-output*))
1008   "Print the error condition."
1009   (let ((exerr (exerr result))
1010         (*print-escape* nil))
1011     (when exerr
1012       (format stream "~& | Execution error:~% | ~W" exerr)
1013       (format stream "~& |~%"))))
1014
1015 (defmethod print-errors ((results test-results-db) &optional
1016                          (stream *standard-output*))
1017   "Print all of the error tests."
1018   (loop with db = (database results)
1019         for test in (error-tests results)
1020         as result = (gethash test db)
1021         do
1022         (print-errors result stream)
1023         (print-summary result stream)))
1024
1025 ;;; Useful equality predicates for tests
1026
1027 (defun logically-equal (x y)
1028   "Return true if x and y are both false or both true."
1029   (eql (not x) (not y)))
1030
1031 (defun set-equal (list1 list2 &rest initargs &key key (test #'equal))
1032   "Return true if every element of list1 is an element of list2 and
1033 vice versa."
1034   (declare (ignore key test))
1035   (and
1036    (listp list1)
1037    (listp list2)
1038    (apply #'subsetp list1 list2 initargs)
1039    (apply #'subsetp list2 list1 initargs)))