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 (in-package :lisp-unit)
  98
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100 ;;; Globals
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102
 103 (defparameter *test-listener* nil)
 104
 105 (defparameter *tests* (make-hash-table))
 106
 107 ;;; Used by RUN-TESTS to collect summary statistics
 108 (defvar *test-count* 0)
 109 (defvar *pass-count* 0)
 110
 111 ;;; Set by RUN-TESTS for use by SHOW-FAILURE
 112 (defvar *test-name* nil)
 113
 114 ;;; If nil, errors in tests are caught and counted.
 115 ;;; If :ask, user is given option of entering debugger or not.
 116 ;;; If true and not :ask, debugger is entered.
 117 (defparameter *use-debugger* nil)
 118
 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 120 ;;; Macros
 121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 122
 123 ;;; DEFINE-TEST
 124
 125 (defmacro define-test (name &body body)
 126   `(progn
 127      (store-test-code ',name ',body)
 128      ',name))
 129
 130 ;;; ASSERT macros
 131
 132 (defmacro assert-eq (expected form &rest extras)
 133   (expand-assert :equal form form expected extras :test #'eq))
 134
 135 (defmacro assert-eql (expected form &rest extras)
 136   (expand-assert :equal form form expected extras :test #'eql))
 137
 138 (defmacro assert-equal (expected form &rest extras)
 139   (expand-assert :equal form form expected extras :test #'equal))
 140
 141 (defmacro assert-equalp (expected form &rest extras)
 142   (expand-assert :equal form form expected extras :test #'equalp))
 143
 144 (defmacro assert-error (condition form &rest extras)
 145   (expand-assert :error form (expand-error-form form)
 146                  condition extras))
 147
 148 (defmacro assert-expands (&environment env expansion form &rest extras)
 149   (expand-assert :macro form
 150                  (expand-macro-form form #+lispworks nil #-lispworks env)
 151                  expansion extras))
 152
 153 (defmacro assert-false (form &rest extras)
 154   (expand-assert :result form form nil extras))
 155
 156 (defmacro assert-equality (test expected form &rest extras)
 157   (expand-assert :equal form form expected extras :test test))
 158
 159 (defmacro assert-prints (output form &rest extras)
 160   (expand-assert :output form (expand-output-form form)
 161                  output extras))
 162
 163 (defmacro assert-true (form &rest extras)
 164   (expand-assert :result form form t extras))
 165
 166 (defun expand-assert (type form body expected extras &key (test #'eql))
 167   `(internal-assert ,type ',form
 168                     (lambda () ,body)
 169                     (lambda () ,expected)
 170                     ,(expand-extras extras)
 171                     ,test))
 172
 173 (defun expand-error-form (form)
 174   `(handler-case ,form
 175      (condition (error) error)))
 176
 177 (defun expand-output-form (form)
 178   (let ((out (gensym)))
 179     `(let* ((,out (make-string-output-stream))
 180             (*standard-output* (make-broadcast-stream *standard-output* ,out)))
 181        ,form
 182        (get-output-stream-string ,out))))
 183
 184 (defun expand-macro-form (form env)
 185   `(macroexpand-1 ',form ,env))
 186
 187 (defun expand-extras (extras)
 188   `(lambda () (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 189
 190 ;;; RUN-TESTS
 191
 192 (defmacro run-all-tests (package &rest tests)
 193   `(let ((*package* (find-package ',package)))
 194      (run-tests
 195       ,@(mapcar (lambda (test) (find-symbol (symbol-name test) package))
 196                 tests))))
 197
 198 (defmacro run-tests (&rest names)
 199   `(run-test-thunks
 200     (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
 201
 202 (defun get-test-thunks (names &optional (package *package*))
 203   (mapcar (lambda (name) (get-test-thunk name package))
 204           names))
 205
 206 (defun get-test-thunk (name package)
 207   (assert (get-test-code name package) (name package)
 208     "No test defined for ~S in package ~S" name package)
 209   (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
 210
 211 (defun use-debugger (&optional (flag t))
 212   (setq *use-debugger* flag))
 213
 214 ;;; WITH-TEST-LISTENER
 215 (defmacro with-test-listener (listener &body body)
 216   `(let ((*test-listener* #',listener)) ,@body))
 217
 218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 219 ;;; Public functions
 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221
 222 (defun get-test-code (name &optional (package *package*))
 223   (let ((table (get-package-table package)))
 224     (unless (null table)
 225       (gethash name table))))
 226
 227 (defun get-tests (&optional (package *package*))
 228   (let ((l nil)
 229         (table (get-package-table package)))
 230     (cond ((null table) nil)
 231           (t
 232            (maphash (lambda (key val)
 233                       (declare (ignore val))
 234                       (push key l))
 235                     table)
 236            (sort l #'string< :key #'string)))))
 237
 238 (defun remove-tests (names &optional (package *package*))
 239   (let ((table (get-package-table package)))
 240     (unless (null table)
 241       (if (null names)
 242           (clrhash table)
 243           (dolist (name names)
 244             (remhash name table))))))
 245
 246 (defun remove-all-tests (&optional (package *package*))
 247   (if (null package)
 248       (clrhash *tests*)
 249       (remhash (find-package package) *tests*)))
 250
 251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 252 ;;; Private functions
 253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 254
 255 ;;; DEFINE-TEST support
 256
 257 (defun get-package-table (package &key create)
 258   (let ((table (gethash (find-package package) *tests*)))
 259     (or table
 260         (and create
 261              (setf (gethash package *tests*)
 262                    (make-hash-table))))))
 263
 264 (defun get-test-name (form)
 265   (if (atom form) form (cadr form)))
 266
 267 (defun store-test-code (name code &optional (package *package*))
 268   (setf (gethash name (get-package-table package :create t))
 269         code))
 270
 271 ;;; ASSERTION support
 272
 273 (defun internal-assert (type form code-thunk expected-thunk extras test)
 274   (let* ((expected (multiple-value-list (funcall expected-thunk)))
 275          (actual (multiple-value-list (funcall code-thunk)))
 276          (passed (test-passed-p type expected actual test)))
 277     (incf *test-count*)
 278     (when passed
 279       (incf *pass-count*))
 280     (record-result passed type form expected actual extras)
 281     passed))
 282
 283 (defun record-result (passed type form expected actual extras)
 284   (funcall (or *test-listener* 'default-listener)
 285            passed type *test-name* form expected actual
 286            (and extras (funcall extras))
 287            *test-count* *pass-count*))
 288
 289 (defun default-listener
 290        (passed type name form expected actual extras test-count pass-count)
 291   (declare (ignore test-count pass-count))
 292   (unless passed
 293     (show-failure type (get-failure-message type)
 294                   name form expected actual extras)))
 295
 296 (defun test-passed-p (type expected actual test)
 297   (ecase type
 298     (:error
 299      (or (eql (car actual) (car expected))
 300          (typep (car actual) (car expected))))
 301     (:equal
 302      (and (<= (length expected) (length actual))
 303           (every test expected actual)))
 304     (:macro
 305      (equal (car actual) (car expected)))
 306     (:output
 307      (string= (string-trim '(#\newline #\return #\space)
 308                            (car actual))
 309               (car expected)))
 310     (:result
 311      (logically-equal (car actual) (car expected)))))
 312
 313 ;;; RUN-TESTS support
 314
 315 (defun run-test-thunks (test-thunks)
 316   (unless (null test-thunks)
 317     (let ((total-test-count 0)
 318           (total-pass-count 0)
 319           (total-error-count 0))
 320       (dolist (test-thunk test-thunks)
 321         (multiple-value-bind (test-count pass-count error-count)
 322             (run-test-thunk (car test-thunk) (cadr test-thunk))
 323           (incf total-test-count test-count)
 324           (incf total-pass-count pass-count)
 325           (incf total-error-count error-count)))
 326       (unless (null (cdr test-thunks))
 327         (show-summary 'total total-test-count total-pass-count total-error-count))
 328       (values))))
 329
 330 (defun run-test-thunk (*test-name* thunk)
 331   (if (null thunk)
 332       (format t "~&    Test ~S not found" *test-name*)
 333       (prog ((*test-count* 0)
 334              (*pass-count* 0)
 335              (error-count 0))
 336         (handler-bind
 337             ((error (lambda (e)
 338                       (let ((*print-escape* nil))
 339                         (setq error-count 1)
 340                         (format t "~&    ~S: ~W" *test-name* e))
 341                       (if (use-debugger-p e) e (go exit)))))
 342           (funcall thunk)
 343           (show-summary *test-name* *test-count* *pass-count*))
 344         exit
 345         (return (values *test-count* *pass-count* error-count)))))
 346
 347 (defun use-debugger-p (e)
 348   (and *use-debugger*
 349        (or (not (eql *use-debugger* :ask))
 350            (y-or-n-p "~A -- debug?" e))))
 351
 352 ;;; OUTPUT support
 353
 354 (defun get-failure-message (type)
 355   (case type
 356     (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
 357     (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 358     (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 359     (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")))
 360
 361 (defun show-failure (type msg name form expected actual extras)
 362   (format t "~&~@[~S: ~]~S failed: " name form)
 363   (format t msg expected actual)
 364   (format t "~{~&   ~S => ~S~}~%" extras)
 365   type)
 366
 367 (defun show-summary (name test-count pass-count &optional error-count)
 368   (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
 369           name pass-count (- test-count pass-count) error-count))
 370
 371 (defun collect-form-values (form values)
 372   (mapcan (lambda (form-arg value)
 373             (if (constantp form-arg)
 374                 nil
 375                 (list form-arg value)))
 376           (cdr form)
 377           values))
 378
 379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 380 ;;; Useful equality predicates for tests
 381 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 382
 383 ;;; (LOGICALLY-EQUAL x y) => true or false
 384 ;;;   Return true if x and y both false or both true
 385 (defun logically-equal (x y)
 386   (eql (not x) (not y)))
 387
 388 ;;; (SET-EQUAL l1 l2 :test) => true or false
 389 ;;;   Return true if every element of l1 is an element of l2
 390 ;;;   and vice versa.
 391 (defun set-equal (l1 l2 &key (test #'equal))
 392   (and (listp l1)
 393        (listp l2)
 394        (subsetp l1 l2 :test test)
 395        (subsetp l2 l1 :test test)))