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