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 ;;; 04/07/06 added ~<...~> to remaining error output forms [CKR]
  32 ;;; 04/06/06 added ~<...~> to compact error output better [CKR]
  33 ;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported
  34 ;;;          by Daniel Edward Burke) [CKR]
  35 ;;; 02/08/06 added newlines to error output [CKR]
  36 ;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR]
  37 ;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR]
  38 ;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger,
  39 ;;; 11/07/05 added *use-debugger* and assert-predicate [DFB]
  40 ;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR]
  41 ;;; 08/30/05 added license notice [CKR]
  42 ;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR]
  43 ;;; 02/21/05 removed length check from SET-EQUAL [CKR]
  44 ;;; 02/17/05 added RUN-ALL-TESTS [CKR]
  45 ;;; 01/18/05 added ASSERT-EQUAL back in [CKR]
  46 ;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR]
  47 ;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR]
  48 ;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR]
  49 ;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR]
  50 ;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR]
  51 ;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR]
  52 ;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR]
  53 ;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR]
  54 ;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR]
  55 ;;; 12/02/04 changed to group tests under packages [CKR]
  56 ;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR]
  57 ;;; 11/30/04 improved error handling and summarization [CKR]
  58 ;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR]
  59 ;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR]
  60 ;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR]
  61 ;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR]
  62 ;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR]
  63 ;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR]
  64 ;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR]
  65 ;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR]
  66
  67
  68 #|
  69 How to use
  70 ----------
  71
  72 1. Read the documentation in lisp-unit.html.
  73
  74 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  75 examples. If you want, start your test file with (REMOVE-TESTS) to
  76 clear any previously defined tests.
  77
  78 2. Load this file.
  79
  80 2. (use-package :lisp-unit)
  81
  82 3. Load your code file and your file of tests.
  83
  84 4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
  85 or simply (RUN-TESTS) to run all defined tests.
  86
  87 A summary of how many tests passed and failed will be printed,
  88 with details on the failures.
  89
  90 Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
  91 functions or even macros does not require reloading any tests.
  92
  93 For more information, see lisp-unit.html.
  94
  95 |#
  96
  97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98 ;;; Packages
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100
 101 (in-package :cl-user)
 102
 103 (defpackage :lisp-unit
 104   (:use :common-lisp)
 105   ;; Functions for managing tests
 106   (:export
 107    :define-test
 108    :get-tests :get-test-code
 109    :remove-tests :remove-all-tests
 110    :run-tests :run-all-tests
 111    :use-debugger
 112    :with-test-listener)
 113   ;; Forms for assertions
 114   (:export
 115    :assert-eq :assert-eql :assert-equal :assert-equalp
 116    :assert-equality :assert-prints :assert-expands
 117    :assert-true :assert-false :assert-error)
 118   ;; Utility predicates
 119   (:export
 120    :logically-equal :set-equal))
 121
 122 (in-package :lisp-unit)
 123
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;;; Globals
 126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 127
 128 (defparameter *test-listener* nil)
 129
 130 (defparameter *tests* (make-hash-table))
 131
 132 ;;; Used by RUN-TESTS to collect summary statistics
 133 (defvar *test-count* 0)
 134 (defvar *pass-count* 0)
 135
 136 ;;; Set by RUN-TESTS for use by SHOW-FAILURE
 137 (defvar *test-name* nil)
 138
 139 ;;; If nil, errors in tests are caught and counted.
 140 ;;; If :ask, user is given option of entering debugger or not.
 141 ;;; If true and not :ask, debugger is entered.
 142 (defparameter *use-debugger* nil)
 143
 144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 145 ;;; Macros
 146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 147
 148 ;;; DEFINE-TEST
 149
 150 (defmacro define-test (name &body body)
 151   `(progn
 152      (store-test-code ',name ',body)
 153      ',name))
 154
 155 ;;; ASSERT macros
 156
 157 (defmacro assert-eq (expected form &rest extras)
 158   "Assert whether expected and form are EQ."
 159   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 160
 161 (defmacro assert-eql (expected form &rest extras)
 162   "Assert whether expected and form are EQL."
 163   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 164
 165 (defmacro assert-equal (expected form &rest extras)
 166   "Assert whether expected and form are EQUAL."
 167   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 168
 169 (defmacro assert-equalp (expected form &rest extras)
 170   "Assert whether expected and form are EQUALP."
 171   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 172
 173 (defmacro assert-error (condition form &rest extras)
 174   "Assert whether form signals condition."
 175   `(expand-assert :error ,form (expand-error-form ,form)
 176                   ,condition ,extras))
 177
 178 (defmacro assert-expands (expansion form &rest extras)
 179   "Assert whether form expands to expansion."
 180   `(expand-assert :macro ,form
 181                   (expand-macro-form ,form nil)
 182                   ,expansion ,extras))
 183
 184 (defmacro assert-false (form &rest extras)
 185   "Assert whether the form is false."
 186   `(expand-assert :result ,form ,form nil ,extras))
 187
 188 (defmacro assert-equality (test expected form &rest extras)
 189   "Assert whether expected and form are equal according to test."
 190   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 191
 192 (defmacro assert-prints (output form &rest extras)
 193   "Assert whether printing the form generates the output."
 194   `(expand-assert :output ,form (expand-output-form ,form)
 195                   ,output ,extras))
 196
 197 (defmacro assert-true (form &rest extras)
 198   "Assert whether the form is true."
 199   `(expand-assert :result ,form ,form t ,extras))
 200
 201 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 202   "Expand the assertion to the internal format."
 203   `(internal-assert ,type ',form
 204                     (lambda () ,body)
 205                     (lambda () ,expected)
 206                     (expand-extras ,extras)
 207                     ,test))
 208
 209 (defmacro expand-error-form (form)
 210   "Wrap the error assertion in HANDLER-CASE."
 211   `(handler-case ,form
 212      (condition (error) error)))
 213
 214 (defmacro expand-output-form (form)
 215   "Capture the output of the form in a string."
 216   (let ((out (gensym)))
 217     `(let* ((,out (make-string-output-stream))
 218             (*standard-output*
 219              (make-broadcast-stream *standard-output* ,out)))
 220        ,form
 221        (get-output-stream-string ,out))))
 222
 223 (defmacro expand-macro-form (form env)
 224   "Expand the macro form once."
 225   `(macroexpand-1 ',form ,env))
 226
 227 (defmacro expand-extras (extras)
 228   "Expand extra forms."
 229   `(lambda ()
 230      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 231
 232 ;;; RUN-TESTS
 233
 234 (defun run-all-tests (&optional (package *package*))
 235   "Run all of the tests in package."
 236   (run-tests :all package))
 237
 238 (defun run-tests (names &optional (package *package*))
 239   "Run the specified tests in package."
 240   (run-test-thunks
 241    (if (eq :all names)
 242        (get-test-thunks (get-tests package) package)
 243        (get-test-thunks names package))))
 244
 245 (defun get-test-thunks (names &optional (package *package*))
 246   (loop for name in names collect
 247         (get-test-thunk name package)))
 248
 249 (defun get-test-thunk (name package)
 250   (assert (get-test-code name package) (name package)
 251     "No test defined for ~S in package ~S" name package)
 252   (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
 253
 254 (defun use-debugger (&optional (flag t))
 255   (setq *use-debugger* flag))
 256
 257 ;;; WITH-TEST-LISTENER
 258 (defmacro with-test-listener (listener &body body)
 259   `(let ((*test-listener* #',listener)) ,@body))
 260
 261 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 262 ;;; Public functions
 263 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 264
 265 (defun get-test-code (name &optional (package *package*))
 266   (let ((table (get-package-table package)))
 267     (unless (null table)
 268       (gethash name table))))
 269
 270 (defun get-tests (&optional (package *package*))
 271   (let ((l nil)
 272         (table (get-package-table package)))
 273     (cond ((null table) nil)
 274           (t
 275            (maphash (lambda (key val)
 276                       (declare (ignore val))
 277                       (push key l))
 278                     table)
 279            (sort l #'string< :key #'string)))))
 280
 281 (defun remove-tests (names &optional (package *package*))
 282   (let ((table (get-package-table package)))
 283     (unless (null table)
 284       (if (eq :all names)
 285           (clrhash table)
 286           (loop for name in names always
 287                 (remhash name table))))))
 288
 289 (defun remove-all-tests (&optional (package *package*))
 290   (if (null package)
 291       (clrhash *tests*)
 292       (remhash (find-package package) *tests*)))
 293
 294 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 295 ;;; Private functions
 296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 297
 298 ;;; DEFINE-TEST support
 299
 300 (defun get-package-table (package &key create)
 301   (let ((table (gethash (find-package package) *tests*)))
 302     (or table
 303         (and create
 304              (setf (gethash package *tests*)
 305                    (make-hash-table))))))
 306
 307 (defun get-test-name (form)
 308   (if (atom form) form (cadr form)))
 309
 310 (defun store-test-code (name code &optional (package *package*))
 311   (setf (gethash name (get-package-table package :create t))
 312         code))
 313
 314 ;;; ASSERTION support
 315
 316 (defun internal-assert (type form code-thunk expected-thunk extras test)
 317   (let* ((expected (multiple-value-list (funcall expected-thunk)))
 318          (actual (multiple-value-list (funcall code-thunk)))
 319          (passed (test-passed-p type expected actual test)))
 320     (incf *test-count*)
 321     (when passed
 322       (incf *pass-count*))
 323     (record-result passed type form expected actual extras)
 324     passed))
 325
 326 (defun record-result (passed type form expected actual extras)
 327   (funcall (or *test-listener* 'default-listener)
 328            passed type *test-name* form expected actual
 329            (and extras (funcall extras))
 330            *test-count* *pass-count*))
 331
 332 (defun default-listener
 333        (passed type name form expected actual extras test-count pass-count)
 334   (declare (ignore test-count pass-count))
 335   (unless passed
 336     (show-failure type (get-failure-message type)
 337                   name form expected actual extras)))
 338
 339 (defun test-passed-p (type expected actual test)
 340   (ecase type
 341     (:error
 342      (or (eql (car actual) (car expected))
 343          (typep (car actual) (car expected))))
 344     (:equal
 345      (and (<= (length expected) (length actual))
 346           (every test expected actual)))
 347     (:macro
 348      (equal (car actual) (car expected)))
 349     (:output
 350      (string= (string-trim '(#\newline #\return #\space)
 351                            (car actual))
 352               (car expected)))
 353     (:result
 354      (logically-equal (car actual) (car expected)))))
 355
 356 ;;; RUN-TESTS support
 357
 358 (defun run-test-thunks (test-thunks)
 359   (unless (null test-thunks)
 360     (let ((total-test-count 0)
 361           (total-pass-count 0)
 362           (total-error-count 0))
 363       (dolist (test-thunk test-thunks)
 364         (multiple-value-bind (test-count pass-count error-count)
 365             (run-test-thunk (car test-thunk) (cadr test-thunk))
 366           (incf total-test-count test-count)
 367           (incf total-pass-count pass-count)
 368           (incf total-error-count error-count)))
 369       (unless (null (cdr test-thunks))
 370         (show-summary 'total total-test-count total-pass-count total-error-count))
 371       (values))))
 372
 373 (defun run-test-thunk (*test-name* thunk)
 374   (if (null thunk)
 375       (format t "~&    Test ~S not found" *test-name*)
 376       (prog ((*test-count* 0)
 377              (*pass-count* 0)
 378              (error-count 0))
 379         (handler-bind
 380             ((error (lambda (e)
 381                       (let ((*print-escape* nil))
 382                         (setq error-count 1)
 383                         (format t "~&    ~S: ~W" *test-name* e))
 384                       (if (use-debugger-p e) e (go exit)))))
 385           (funcall thunk)
 386           (show-summary *test-name* *test-count* *pass-count*))
 387         exit
 388         (return (values *test-count* *pass-count* error-count)))))
 389
 390 (defun use-debugger-p (e)
 391   (and *use-debugger*
 392        (or (not (eql *use-debugger* :ask))
 393            (y-or-n-p "~A -- debug?" e))))
 394
 395 ;;; OUTPUT support
 396
 397 (defun get-failure-message (type)
 398   (case type
 399     (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
 400     (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 401     (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 402     (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")))
 403
 404 (defun show-failure (type msg name form expected actual extras)
 405   (format t "~&~@[~S: ~]~S failed: " name form)
 406   (format t msg expected actual)
 407   (format t "~{~&   ~S => ~S~}~%" extras)
 408   type)
 409
 410 (defun show-summary (name test-count pass-count &optional error-count)
 411   (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
 412           name pass-count (- test-count pass-count) error-count))
 413
 414 (defun collect-form-values (form values)
 415   (mapcan (lambda (form-arg value)
 416             (if (constantp form-arg)
 417                 nil
 418                 (list form-arg value)))
 419           (cdr form)
 420           values))
 421
 422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 423 ;;; Useful equality predicates for tests
 424 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 425
 426 ;;; (LOGICALLY-EQUAL x y) => true or false
 427 ;;;   Return true if x and y both false or both true
 428 (defun logically-equal (x y)
 429   (eql (not x) (not y)))
 430
 431 ;;; (SET-EQUAL l1 l2 :test) => true or false
 432 ;;;   Return true if every element of l1 is an element of l2
 433 ;;;   and vice versa.
 434 (defun set-equal (l1 l2 &key (test #'equal))
 435   (and (listp l1)
 436        (listp l2)
 437        (subsetp l1 l2 :test test)
 438        (subsetp l2 l1 :test test)))
 439
 440 (pushnew :lisp-unit common-lisp:*features*)