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