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