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