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