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
  26 ;;; A test suite package, modelled after JUnit.
  27 ;;; Author: Chris Riesbeck
  28 ;;;
  29 ;;; Update history:
  30 ;;;
  31
  32 #|
  33
  34 How to use
  35 ----------
  36
  37 1. Read the documentation in lisp-unit.html.
  38
  39 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  40 examples. If you want, start your test file with (REMOVE-TESTS) to
  41 clear any previously defined tests.
  42
  43 2. Load this file.
  44
  45 2. (use-package :lisp-unit)
  46
  47 3. Load your code file and your file of tests.
  48
  49 4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
  50 or simply (RUN-TESTS) to run all defined tests.
  51
  52 A summary of how many tests passed and failed will be printed,
  53 with details on the failures.
  54
  55 Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
  56 functions or even macros does not require reloading any tests.
  57
  58 For more information, see lisp-unit.html.
  59
  60 |#
  61
  62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63 ;;; Packages
  64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65
  66 (in-package :cl-user)
  67
  68 (defpackage :lisp-unit
  69   (:use :common-lisp)
  70   ;; Print parameters
  71   (:export :*print-summary*
  72            :*print-failures*
  73            :*print-errors*)
  74   ;; Forms for assertions
  75   (:export :assert-eq
  76            :assert-eql
  77            :assert-equal
  78            :assert-equalp
  79            :assert-equality
  80            :assert-prints
  81            :assert-expands
  82            :assert-true
  83            :assert-false
  84            :assert-error)
  85   ;; Functions for managing tests
  86   (:export :define-test
  87            :run-tests
  88            :remove-tests
  89            :use-debugger)
  90   ;; Utility predicates
  91   (:export :logically-equal :set-equal))
  92
  93 (in-package :lisp-unit)
  94
  95 ;;; Global counters
  96
  97 (defparameter *pass* 0
  98   "The number of passed assertions.")
  99
 100 (defparameter *fail* 0
 101   "The number of failed assertions.")
 102
 103 ;;; Global options
 104
 105 (defparameter *print-summary* nil
 106   "Print a summary of the pass, fail, and error count if non-nil.")
 107
 108 (defparameter *print-failures* nil
 109   "Print failure messages if non-NIL.")
 110
 111 (defparameter *print-errors* nil
 112   "Print error messages if non-NIL.")
 113
 114 (defparameter *use-debugger* nil
 115   "If not NIL, enter the debugger when an error is encountered in an
 116 assertion.")
 117
 118 (defun use-debugger-p (condition)
 119   "Debug or ignore errors."
 120   (cond
 121    ((eq :ask *use-debugger*)
 122     (y-or-n-p "~A -- debug?" condition))
 123    (*use-debugger*)))
 124
 125 ;;; Failure control strings
 126
 127 (defgeneric failure-control-string (type)
 128   (:method (type)
 129    "~& | Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 130   (:documentation
 131    "Return the FORMAT control string for the failure type."))
 132
 133 (defmethod failure-control-string ((type (eql :error)))
 134   "~& | ~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
 135
 136 (defmethod failure-control-string ((type (eql :macro)))
 137   "~& | Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 138
 139 (defmethod failure-control-string ((type (eql :output)))
 140   "~& | Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 141
 142 (defun print-failure (type form expected actual extras)
 143   "Report the details of the failure assertion."
 144   (format t " | Failed Form: ~S" form)
 145   (format t (failure-control-string type) expected actual)
 146   (when extras
 147     (format t "~{~& | ~S => ~S~}~%" (funcall extras)))
 148   (format t "~& |~%")
 149   type)
 150
 151 (defun print-error (condition)
 152   "Print the error condition."
 153   (let ((*print-escape* nil))
 154     (format t "~& | Execution error:~% | ~W" condition)
 155     (format t "~& |~%")))
 156
 157 (defun print-summary (name pass fail &optional exerr)
 158   "Print a summary of the test results."
 159   (format t "~&~A: ~S assertions passed, ~S failed"
 160           name pass fail)
 161   (format t "~@[, ~S execution errors~].~2%" exerr))
 162
 163 ;;; Global unit test database
 164
 165 (defparameter *test-db* (make-hash-table :test #'eq)
 166   "The unit test database is simply a hash table.")
 167
 168 (defun package-table (package &optional create)
 169   (cond
 170    ((gethash (find-package package) *test-db*))
 171    (create
 172     (setf (gethash package *test-db*) (make-hash-table)))))
 173
 174 (defmacro define-test (name &body body)
 175   "Store the test in the test database."
 176   `(progn
 177      (setf
 178       (gethash ',name (package-table *package* t))
 179       ',body)
 180      ;; Return the name of the test
 181      ',name))
 182
 183 ;;; Remove tests from the test DB
 184
 185 (defun remove-tests (names &optional (package *package*))
 186   "Remove individual tests or entire sets."
 187   (if (eq :all names)
 188       (if (null package)
 189           (clrhash *test-db*)
 190           (remhash (find-package package) *test-db*))
 191       (let ((table (package-table package)))
 192         (unless (null table)
 193           (loop for name in names
 194                 always (remhash name table)
 195                 collect name into removed
 196                 finally (return removed))))))
 197
 198 ;;; Assert macros
 199
 200 (defmacro assert-eq (expected form &rest extras)
 201   "Assert whether expected and form are EQ."
 202   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 203
 204 (defmacro assert-eql (expected form &rest extras)
 205   "Assert whether expected and form are EQL."
 206   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 207
 208 (defmacro assert-equal (expected form &rest extras)
 209   "Assert whether expected and form are EQUAL."
 210   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 211
 212 (defmacro assert-equalp (expected form &rest extras)
 213   "Assert whether expected and form are EQUALP."
 214   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 215
 216 (defmacro assert-error (condition form &rest extras)
 217   "Assert whether form signals condition."
 218   `(expand-assert :error ,form (expand-error-form ,form)
 219                   ,condition ,extras))
 220
 221 (defmacro assert-expands (expansion form &rest extras)
 222   "Assert whether form expands to expansion."
 223   `(expand-assert :macro ,form
 224                   (expand-macro-form ,form nil)
 225                   ,expansion ,extras))
 226
 227 (defmacro assert-false (form &rest extras)
 228   "Assert whether the form is false."
 229   `(expand-assert :result ,form ,form nil ,extras))
 230
 231 (defmacro assert-equality (test expected form &rest extras)
 232   "Assert whether expected and form are equal according to test."
 233   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 234
 235 (defmacro assert-prints (output form &rest extras)
 236   "Assert whether printing the form generates the output."
 237   `(expand-assert :output ,form (expand-output-form ,form)
 238                   ,output ,extras))
 239
 240 (defmacro assert-true (form &rest extras)
 241   "Assert whether the form is true."
 242   `(expand-assert :result ,form ,form t ,extras))
 243
 244 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 245   "Expand the assertion to the internal format."
 246   `(internal-assert ,type ',form
 247                     (lambda () ,body)
 248                     (lambda () ,expected)
 249                     (expand-extras ,extras)
 250                     ,test))
 251
 252 (defmacro expand-error-form (form)
 253   "Wrap the error assertion in HANDLER-CASE."
 254   `(handler-case ,form
 255      (condition (error) error)))
 256
 257 (defmacro expand-output-form (form)
 258   "Capture the output of the form in a string."
 259   (let ((out (gensym)))
 260     `(let* ((,out (make-string-output-stream))
 261             (*standard-output*
 262              (make-broadcast-stream *standard-output* ,out)))
 263        ,form
 264        (get-output-stream-string ,out))))
 265
 266 (defmacro expand-macro-form (form env)
 267   "Expand the macro form once."
 268   `(macroexpand-1 ',form ,env))
 269
 270 (defmacro expand-extras (extras)
 271   "Expand extra forms."
 272   `(lambda ()
 273      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 274
 275 (defun internal-assert
 276        (type form code-thunk expected-thunk extras test)
 277   "Perform the assertion and record the results."
 278   (let ((expected (multiple-value-list (funcall expected-thunk)))
 279         (actual (multiple-value-list (funcall code-thunk)))
 280         (passed nil))
 281     ;; Count the assertion
 282     (if (setq passed (test-passed-p type expected actual test))
 283         (incf *pass*)
 284         (incf *fail*))
 285     ;; Report the assertion
 286     (when (and (not passed) *print-failures*)
 287       (print-failure type form expected actual extras))
 288     ;; Return the result
 289     passed))
 290
 291 ;;; Test passed predicate.
 292
 293 (defgeneric test-passed-p (type expected actual test)
 294   (:documentation
 295    "Return the result of the test."))
 296
 297 (defmethod test-passed-p ((type (eql :error)) expected actual test)
 298   "Return the result of the error assertion."
 299   (or
 300    (eql (car actual) (car expected))
 301    (typep (car actual) (car expected))))
 302
 303 (defmethod test-passed-p ((type (eql :equal)) expected actual test)
 304   "Return the result of the equality assertion."
 305   (and
 306    (<= (length expected) (length actual))
 307    (every test expected actual)))
 308
 309 (defmethod test-passed-p ((type (eql :macro)) expected actual test)
 310   "Return the result of the macro expansion."
 311   (equal (car actual) (car expected)))
 312
 313 (defmethod test-passed-p ((type (eql :output)) expected actual test)
 314   "Return the result of the printed output."
 315   (string=
 316    (string-trim '(#\newline #\return #\space) (car actual))
 317    (car expected)))
 318
 319 (defmethod test-passed-p ((type (eql :result)) expected actual test)
 320   "Return the result of the assertion."
 321   (logically-equal (car actual) (car expected)))
 322
 323 ;;; Results
 324
 325 (defclass test-results ()
 326   ((test-names
 327     :type list
 328     :initarg :test-names
 329     :accessor test-names)
 330    (pass
 331     :type fixnum
 332     :initform 0
 333     :accessor pass)
 334    (fail
 335     :type fixnum
 336     :initform 0
 337     :accessor fail)
 338    (exerr
 339     :type fixnum
 340     :initform 0
 341     :accessor exerr)
 342    (failed-tests
 343     :type list
 344     :initform ()
 345     :accessor failed-tests)
 346    (error-tests
 347     :type list
 348     :initform ()
 349     :accessor error-tests)
 350    (missing-tests
 351     :type list
 352     :initform ()
 353     :accessor missing-tests))
 354   (:default-initargs :test-names ())
 355   (:documentation
 356    "Store the results of the tests for further evaluation."))
 357
 358 (defmethod print-object ((object test-results) stream)
 359   "Print the summary counts with the object."
 360   (format stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 361           (class-name (class-of object))
 362           (+ (pass object) (fail object))
 363           (pass object) (fail object) (exerr object)))
 364
 365 (defun record-result (test-name code results)
 366   "Run the test code and record the result."
 367   (multiple-value-bind (pass fail exerr)
 368       (run-test-thunk code)
 369     (push test-name (test-names results))
 370     ;; Count passed tests
 371     (when (plusp pass)
 372       (incf (pass results) pass))
 373     ;; Count failed tests and record name
 374     (when (plusp fail)
 375       (incf (fail results) fail)
 376       (push test-name (failed-tests results)))
 377     ;; Count errors and record name
 378     (when (eq :error exerr)
 379       (incf (exerr results))
 380       (push test-name (error-tests results)))
 381     ;; Print a summary of the results
 382     (when *print-summary*
 383       (print-summary
 384        test-name pass fail
 385        (when (eq :error exerr) 1)))))
 386
 387 (defun print-results (results)
 388   "Print a summary of all results."
 389   (let ((pass (pass results))
 390         (fail (fail results)))
 391     (format t "Unit Test Summary~%")
 392     (format t " | ~D assertions total~%" (+ pass fail))
 393     (format t " | ~D passed~%" pass)
 394     (format t " | ~D failed~%" fail)
 395     (format t " | ~D execution errors~2%" (exerr results))))
 396
 397 ;;; Run the tests
 398
 399 (defun run-code (code)
 400   "Run the code to test the assertions."
 401   (funcall (coerce `(lambda () ,@code) 'function)))
 402
 403 (defun run-test-thunk (code)
 404   (let ((*pass* 0)
 405         (*fail* 0))
 406     (handler-case (run-code code)
 407       (error (condition)
 408         (when *print-errors*
 409           (print-error condition))
 410         (if (use-debugger-p condition)
 411             condition
 412             (return-from run-test-thunk
 413               (values *pass* *fail* :error)))))
 414     ;; Return the result count
 415     (values *pass* *fail* nil)))
 416
 417 (defun %run-all-thunks (&optional (package *package*))
 418   "Run all of the test thunks in the package."
 419   (loop
 420    with results = (make-instance 'test-results)
 421    for test-name being each hash-key in (package-table package)
 422    using (hash-value code)
 423    if code do
 424    (record-result test-name code results)
 425    else do
 426    (push test-name (missing-tests results))
 427    ;; Summarize and return the test results
 428    finally
 429    (when *print-summary*
 430      (print-results results))
 431    (return results)))
 432
 433 (defun %run-thunks (test-names &optional (package *package*))
 434   "Run the list of test thunks in the package."
 435   (loop
 436    with table = (package-table package)
 437    and results = (make-instance 'test-results)
 438    for test-name in test-names
 439    as code = (gethash test-name table)
 440    if code do
 441    (record-result test-name code results)
 442    else do
 443    (push test-name (missing-tests results))
 444    finally
 445    (when *print-summary*
 446      (print-results results))
 447    (return results)))
 448
 449 (defun run-tests (test-names &optional (package *package*))
 450   "Run the specified tests in package."
 451   (if (eq :all test-names)
 452       (%run-all-thunks package)
 453       (%run-thunks test-names package)))
 454
 455 ;;; Useful equality predicates for tests
 456
 457 ;;; (LOGICALLY-EQUAL x y) => true or false
 458 ;;;   Return true if x and y both false or both true
 459 (defun logically-equal (x y)
 460   (eql (not x) (not y)))
 461
 462 ;;; (SET-EQUAL l1 l2 :test) => true or false
 463 ;;;   Return true if every element of l1 is an element of l2
 464 ;;;   and vice versa.
 465 (defun set-equal (l1 l2 &key (test #'equal))
 466   (and (listp l1)
 467        (listp l2)
 468        (subsetp l1 l2 :test test)
 469        (subsetp l2 l1 :test test)))
 470
 471 (pushnew :lisp-unit common-lisp:*features*)