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   ;; Forms for assertions
  62   (:export :assert-eq
  63            :assert-eql
  64            :assert-equal
  65            :assert-equalp
  66            :assert-equality
  67            :assert-prints
  68            :assert-expands
  69            :assert-true
  70            :assert-false
  71            :assert-error)
  72   ;; Functions for managing tests
  73   (:export :define-test
  74            :list-tests
  75            :test-code
  76            :test-documentation
  77            :remove-tests
  78            :run-tests
  79            :use-debugger)
  80   ;; Functions for managing tags
  81   (:export :list-tags
  82            :tagged-tests
  83            :remove-tags
  84            :run-tags)
  85   ;; Functions for reporting test results
  86   (:export :test-names
  87            :failed-tests
  88            :error-tests
  89            :missing-tests
  90            :summarize-results)
  91   ;; Utility predicates
  92   (:export :logically-equal :set-equal))
  93
  94 (in-package :lisp-unit)
  95
  96 ;;; Global counters
  97
  98 (defparameter *pass* 0
  99   "The number of passed assertions.")
 100
 101 (defparameter *fail* 0
 102   "The number of failed assertions.")
 103
 104 ;;; Global options
 105
 106 (defparameter *print-summary* nil
 107   "Print a summary of the pass, fail, and error count if non-nil.")
 108
 109 (defparameter *print-failures* nil
 110   "Print failure messages if non-NIL.")
 111
 112 (defparameter *print-errors* nil
 113   "Print error messages if non-NIL.")
 114
 115 (defparameter *use-debugger* nil
 116   "If not NIL, enter the debugger when an error is encountered in an
 117 assertion.")
 118
 119 (defun use-debugger-p (condition)
 120   "Debug or ignore errors."
 121   (cond
 122    ((eq :ask *use-debugger*)
 123     (y-or-n-p "~A -- debug?" condition))
 124    (*use-debugger*)))
 125
 126 ;;; Failure control strings
 127
 128 (defgeneric print-failure (type form expected actual extras)
 129   (:documentation
 130    "Report the details of the failure assertion."))
 131
 132 (defmethod print-failure :around (type form expected actual extras)
 133   "Failure header and footer output."
 134   (format t " | Failed Form: ~S" form)
 135   (call-next-method)
 136   (when extras
 137     (format t "~{~& | ~S => ~S~}~%" (funcall extras)))
 138   (format t "~& |~%")
 139   type)
 140
 141 (defmethod print-failure (type form expected actual extras)
 142   (format t "~& | Expected ~{~S~^; ~} " expected)
 143   (format t "~<~% | ~:;but saw ~{~S~^; ~}~>" actual))
 144
 145 (defmethod print-failure ((type (eql :error))
 146                           form expected actual extras)
 147   (format t "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 148           expected)
 149   (format t " ~{~S~^; ~}" actual))
 150
 151 (defmethod print-failure ((type (eql :macro))
 152                           form expected actual extras)
 153   (format t "~& | Should have expanded to ~{~S~^; ~} " expected)
 154   (format t "~<~%~:;but saw ~{~S~^; ~}~>" actual))
 155
 156 (defmethod print-failure ((type (eql :output))
 157                           form expected actual extras)
 158   (format t "~& | Should have printed ~{~S~^; ~} " expected)
 159   (format t "~<~%~:;but saw ~{~S~^; ~}~>" actual))
 160
 161 (defun print-error (condition)
 162   "Print the error condition."
 163   (let ((*print-escape* nil))
 164     (format t "~& | Execution error:~% | ~W" condition)
 165     (format t "~& |~%")))
 166
 167 (defun print-summary (name pass fail &optional exerr)
 168   "Print a summary of the test results."
 169   (format t "~&~A: ~S assertions passed, ~S failed"
 170           name pass fail)
 171   (format t "~@[, ~S execution errors~].~2%" exerr))
 172
 173 ;;; Global unit test database
 174
 175 (defparameter *test-db* (make-hash-table :test #'eq)
 176   "The unit test database is simply a hash table.")
 177
 178 (defun package-table (package &optional create)
 179   (cond
 180    ((gethash (find-package package) *test-db*))
 181    (create
 182     (setf (gethash package *test-db*) (make-hash-table)))
 183    (t (warn "No tests defined for package: ~S" package))))
 184
 185 ;;; Global tags database
 186
 187 (defparameter *tag-db* (make-hash-table :test #'eq)
 188   "The tag database is simply a hash table.")
 189
 190 (defun package-tags (package &optional create)
 191   "Return the tags DB for the package."
 192   (cond
 193    ((gethash (find-package package) *tag-db*))
 194    (create
 195     (setf (gethash package *tag-db*) (make-hash-table)))
 196    (t (warn "No tags defined for package: ~S" package))))
 197
 198 (defclass unit-test ()
 199   ((doc
 200     :type string
 201     :initarg :doc
 202     :reader doc)
 203    (code
 204     :type list
 205     :initarg :code
 206     :reader code))
 207   (:default-initargs :doc "" :code ())
 208   (:documentation
 209    "Organize the unit test documentation and code."))
 210
 211 ;;; NOTE: Shamelessly taken from PG's analyze-body
 212 (defun parse-body (body &optional doc tag)
 213   "Separate the components of the body."
 214   (let ((item (first body)))
 215     (cond
 216      ((and (listp item) (eq :tag (first item)))
 217       (parse-body (rest body) doc (nconc (rest item) tag)))
 218      ((and (stringp item) (not doc) (rest body))
 219       (if tag
 220           (values doc tag (rest body))
 221           (parse-body (rest body) doc tag)))
 222      (t (values doc tag body)))))
 223
 224 (defmacro define-test (name &body body)
 225   "Store the test in the test database."
 226   (multiple-value-bind (doc tag code) (parse-body body)
 227     `(let ((doc (or ,doc (string ',name))))
 228        (setf
 229         ;; Unit test
 230         (gethash ',name (package-table *package* t))
 231         (make-instance 'unit-test :doc doc :code ',code))
 232        ;; Tags
 233        (loop for tag in ',tag do
 234              (pushnew
 235               ',name (gethash tag (package-tags *package* t))))
 236        ;; Return the name of the test
 237        ',name)))
 238
 239 ;;; Manage tests
 240
 241 (defun list-tests (&optional (package *package*))
 242   "Return a list of the tests in package."
 243   (let ((table (package-table package)))
 244     (when table
 245       (loop for test-name being each hash-key in table
 246             collect test-name))))
 247
 248 (defun test-documentation (name &optional (package *package*))
 249   "Return the documentation for the test."
 250   (let ((unit-test (gethash name (package-table package))))
 251     (if (null unit-test)
 252         (warn "No code defined for test ~A in package ~S."
 253               name package)
 254         (doc unit-test))))
 255
 256 (defun test-code (name &optional (package *package*))
 257   "Returns the code stored for the test name."
 258   (let ((unit-test (gethash name (package-table package))))
 259     (if (null unit-test)
 260         (warn "No code defined for test ~A in package ~S."
 261               name package)
 262         (code unit-test))))
 263
 264 ;;; 0.8.1 Compatibility revision for Quicklisp
 265 (defun remove-all-tests (&optional (package *package*))
 266   (remove-tests :all package))
 267
 268 (defun remove-tests (names &optional (package *package*))
 269   "Remove individual tests or entire sets."
 270   (if (eq :all names)
 271       (if (null package)
 272           (clrhash *test-db*)
 273           (progn
 274             (remhash (find-package package) *test-db*)
 275             (remhash (find-package package) *tag-db*)))
 276       (let ((table (package-table package)))
 277         (unless (null table)
 278           ;; Remove tests
 279           (loop for name in names
 280                 always (remhash name table)
 281                 collect name into removed
 282                 finally (return removed))
 283           ;; Remove tests from tags
 284           (loop with tags = (package-tags package)
 285                 for tag being each hash-key in tags
 286                 using (hash-value tagged-tests)
 287                 do
 288                 (setf
 289                  (gethash tag tags)
 290                  (set-difference tagged-tests names)))))))
 291
 292 ;;; Manage tags
 293
 294 (defun %tests-from-all-tags (&optional (package *package*))
 295   "Return all of the tests that have been tagged."
 296   (loop for tests being each hash-value in (package-tags package)
 297         nconc (copy-list tests) into all-tests
 298         finally (return (delete-duplicates all-tests))))
 299
 300 (defun %tests-from-tags (tags &optional (package *package*))
 301   "Return the tests associated with the tags."
 302   (loop with table = (package-tags package)
 303         for tag in tags
 304         as tests = (gethash tag table)
 305         nconc (copy-list tests) into all-tests
 306         finally (return (delete-duplicates all-tests))))
 307
 308 (defun list-tags (&optional (package *package*))
 309   "Return a list of the tags in package."
 310   (let ((tags (package-tags package)))
 311     (when tags
 312       (loop for tag being each hash-key in tags
 313             collect tag))))
 314
 315 (defun tagged-tests (tags &optional (package *package*))
 316   "Run the tests associated with the specified tags in package."
 317   (if (eq :all tags)
 318       (%tests-from-all-tags package)
 319       (%tests-from-tags tags package)))
 320
 321 (defun remove-tags (tags &optional (package *package*))
 322   "Remove individual tags or entire sets."
 323   (if (eq :all tags)
 324       (if (null package)
 325           (clrhash *tag-db*)
 326           (remhash (find-package package) *tag-db*))
 327       (let ((table (package-tags package)))
 328         (unless (null table)
 329           (loop for tag in tags
 330                 always (remhash tag table)
 331                 collect tag into removed
 332                 finally (return removed))))))
 333
 334 ;;; Assert macros
 335
 336 (defmacro assert-eq (expected form &rest extras)
 337   "Assert whether expected and form are EQ."
 338   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 339
 340 (defmacro assert-eql (expected form &rest extras)
 341   "Assert whether expected and form are EQL."
 342   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 343
 344 (defmacro assert-equal (expected form &rest extras)
 345   "Assert whether expected and form are EQUAL."
 346   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 347
 348 (defmacro assert-equalp (expected form &rest extras)
 349   "Assert whether expected and form are EQUALP."
 350   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 351
 352 (defmacro assert-error (condition form &rest extras)
 353   "Assert whether form signals condition."
 354   `(expand-assert :error ,form (expand-error-form ,form)
 355                   ,condition ,extras))
 356
 357 (defmacro assert-expands (expansion form &rest extras)
 358   "Assert whether form expands to expansion."
 359   `(expand-assert :macro ,form
 360                   (expand-macro-form ,form nil)
 361                   ,expansion ,extras))
 362
 363 (defmacro assert-false (form &rest extras)
 364   "Assert whether the form is false."
 365   `(expand-assert :result ,form ,form nil ,extras))
 366
 367 (defmacro assert-equality (test expected form &rest extras)
 368   "Assert whether expected and form are equal according to test."
 369   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 370
 371 (defmacro assert-prints (output form &rest extras)
 372   "Assert whether printing the form generates the output."
 373   `(expand-assert :output ,form (expand-output-form ,form)
 374                   ,output ,extras))
 375
 376 (defmacro assert-true (form &rest extras)
 377   "Assert whether the form is true."
 378   `(expand-assert :result ,form ,form t ,extras))
 379
 380 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 381   "Expand the assertion to the internal format."
 382   `(internal-assert ,type ',form
 383                     (lambda () ,body)
 384                     (lambda () ,expected)
 385                     (expand-extras ,extras)
 386                     ,test))
 387
 388 (defmacro expand-error-form (form)
 389   "Wrap the error assertion in HANDLER-CASE."
 390   `(handler-case ,form
 391      (condition (error) error)))
 392
 393 (defmacro expand-output-form (form)
 394   "Capture the output of the form in a string."
 395   (let ((out (gensym)))
 396     `(let* ((,out (make-string-output-stream))
 397             (*standard-output*
 398              (make-broadcast-stream *standard-output* ,out)))
 399        ,form
 400        (get-output-stream-string ,out))))
 401
 402 (defmacro expand-macro-form (form env)
 403   "Expand the macro form once."
 404   `(macroexpand-1 ',form ,env))
 405
 406 (defmacro expand-extras (extras)
 407   "Expand extra forms."
 408   `(lambda ()
 409      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 410
 411 (defun internal-assert
 412        (type form code-thunk expected-thunk extras test)
 413   "Perform the assertion and record the results."
 414   (let ((expected (multiple-value-list (funcall expected-thunk)))
 415         (actual (multiple-value-list (funcall code-thunk)))
 416         (passed nil))
 417     ;; Count the assertion
 418     (if (setq passed (test-passed-p type expected actual test))
 419         (incf *pass*)
 420         (incf *fail*))
 421     ;; Report the assertion
 422     (when (and (not passed) *print-failures*)
 423       (print-failure type form expected actual extras))
 424     ;; Return the result
 425     passed))
 426
 427 ;;; Test passed predicate.
 428
 429 (defgeneric test-passed-p (type expected actual test)
 430   (:documentation
 431    "Return the result of the test."))
 432
 433 (defmethod test-passed-p ((type (eql :error)) expected actual test)
 434   "Return the result of the error assertion."
 435   (or
 436    (eql (car actual) (car expected))
 437    (typep (car actual) (car expected))))
 438
 439 (defmethod test-passed-p ((type (eql :equal)) expected actual test)
 440   "Return the result of the equality assertion."
 441   (and
 442    (<= (length expected) (length actual))
 443    (every test expected actual)))
 444
 445 (defmethod test-passed-p ((type (eql :macro)) expected actual test)
 446   "Return the result of the macro expansion."
 447   (equal (car actual) (car expected)))
 448
 449 (defmethod test-passed-p ((type (eql :output)) expected actual test)
 450   "Return the result of the printed output."
 451   (string=
 452    (string-trim '(#\newline #\return #\space) (car actual))
 453    (car expected)))
 454
 455 (defmethod test-passed-p ((type (eql :result)) expected actual test)
 456   "Return the result of the assertion."
 457   (logically-equal (car actual) (car expected)))
 458
 459 ;;; Results
 460
 461 (defclass test-results ()
 462   ((test-names
 463     :type list
 464     :initarg :test-names
 465     :accessor test-names)
 466    (pass
 467     :type fixnum
 468     :initform 0
 469     :accessor pass)
 470    (fail
 471     :type fixnum
 472     :initform 0
 473     :accessor fail)
 474    (exerr
 475     :type fixnum
 476     :initform 0
 477     :accessor exerr)
 478    (failed-tests
 479     :type list
 480     :initform ()
 481     :accessor failed-tests)
 482    (error-tests
 483     :type list
 484     :initform ()
 485     :accessor error-tests)
 486    (missing-tests
 487     :type list
 488     :initform ()
 489     :accessor missing-tests))
 490   (:default-initargs :test-names ())
 491   (:documentation
 492    "Store the results of the tests for further evaluation."))
 493
 494 (defmethod print-object ((object test-results) stream)
 495   "Print the summary counts with the object."
 496   (format stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 497           (class-name (class-of object))
 498           (+ (pass object) (fail object))
 499           (pass object) (fail object) (exerr object)))
 500
 501 (defun record-result (test-name code results)
 502   "Run the test code and record the result."
 503   (multiple-value-bind (pass fail exerr)
 504       (run-test-thunk code)
 505     (push test-name (test-names results))
 506     ;; Count passed tests
 507     (when (plusp pass)
 508       (incf (pass results) pass))
 509     ;; Count failed tests and record name
 510     (when (plusp fail)
 511       (incf (fail results) fail)
 512       (push test-name (failed-tests results)))
 513     ;; Count errors and record name
 514     (when (eq :error exerr)
 515       (incf (exerr results))
 516       (push test-name (error-tests results)))
 517     ;; Print a summary of the results
 518     (when (or *print-summary* *print-failures* *print-errors*)
 519       (print-summary
 520        test-name pass fail
 521        (when (eq :error exerr) 1)))))
 522
 523 (defun summarize-results (results)
 524   "Print a summary of all results."
 525   (let ((pass (pass results))
 526         (fail (fail results)))
 527     (format t "~&Unit Test Summary~%")
 528     (format t " | ~D assertions total~%" (+ pass fail))
 529     (format t " | ~D passed~%" pass)
 530     (format t " | ~D failed~%" fail)
 531     (format t " | ~D execution errors~%" (exerr results))
 532     (format t " | ~D missing tests~2%"
 533             (length (missing-tests results)))))
 534
 535 ;;; Run the tests
 536
 537 (defun run-code (code)
 538   "Run the code to test the assertions."
 539   (funcall (coerce `(lambda () ,@code) 'function)))
 540
 541 (defun run-test-thunk (code)
 542   (let ((*pass* 0)
 543         (*fail* 0))
 544     (handler-case (run-code code)
 545       (error (condition)
 546         (when *print-errors*
 547           (print-error condition))
 548         (if (use-debugger-p condition)
 549             condition
 550             (return-from run-test-thunk
 551               (values *pass* *fail* :error)))))
 552     ;; Return the result count
 553     (values *pass* *fail* nil)))
 554
 555 (defun %run-all-thunks (&optional (package *package*))
 556   "Run all of the test thunks in the package."
 557   (loop
 558    with results = (make-instance 'test-results)
 559    for test-name being each hash-key in (package-table package)
 560    using (hash-value unit-test)
 561    if unit-test do
 562    (record-result test-name (code unit-test) results)
 563    else do
 564    (push test-name (missing-tests results))
 565    ;; Summarize and return the test results
 566    finally
 567    (summarize-results results)
 568    (return results)))
 569
 570 (defun %run-thunks (test-names &optional (package *package*))
 571   "Run the list of test thunks in the package."
 572   (loop
 573    with table = (package-table package)
 574    and results = (make-instance 'test-results)
 575    for test-name in test-names
 576    as unit-test = (gethash test-name table)
 577    if unit-test do
 578    (record-result test-name (code unit-test) results)
 579    else do
 580    (push test-name (missing-tests results))
 581    finally
 582    (summarize-results results)
 583    (return results)))
 584
 585 (defun run-tests (test-names &optional (package *package*))
 586   "Run the specified tests in package."
 587   (if (eq :all test-names)
 588       (%run-all-thunks package)
 589       (%run-thunks test-names package)))
 590
 591 (defun run-tags (tags &optional (package *package*))
 592   "Run the tests associated with the specified tags in package."
 593   (%run-thunks (get-tagged-tests tags package) package))
 594
 595 ;;; Useful equality predicates for tests
 596
 597 ;;; (LOGICALLY-EQUAL x y) => true or false
 598 ;;;   Return true if x and y both false or both true
 599 (defun logically-equal (x y)
 600   (eql (not x) (not y)))
 601
 602 ;;; (SET-EQUAL l1 l2 :test) => true or false
 603 ;;;   Return true if every element of l1 is an element of l2
 604 ;;;   and vice versa.
 605 (defun set-equal (l1 l2 &key (test #'equal))
 606   (and (listp l1)
 607        (listp l2)
 608        (subsetp l1 l2 :test test)
 609        (subsetp l2 l1 :test test)))
 610
 611 (pushnew :lisp-unit common-lisp:*features*)