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 (cl:defpackage #:lisp-unit
 102   (:use #:common-lisp)
 103   (:export #:define-test #:run-all-tests #:run-tests
 104            #:assert-eq #:assert-eql #:assert-equal #:assert-equalp
 105            #:assert-error #:assert-expands #:assert-false
 106            #:assert-equality #:assert-prints #:assert-true
 107            #:get-test-code #:get-tests
 108            #:remove-all-tests #:remove-tests
 109            #:logically-equal #:set-equal
 110            #:float-equal #:complex-equal #:number-equal
 111            #:array-equal
 112            #:use-debugger
 113            #:with-test-listener)
 114   )
 115
 116 (in-package #:lisp-unit)
 117
 118 (pushnew :lisp-unit *features*)
 119
 120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 121 ;;; Globals
 122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 123
 124 (defparameter *test-listener* nil)
 125
 126 (defparameter *tests* (make-hash-table))
 127
 128 ;;; Used by RUN-TESTS to collect summary statistics
 129 (defvar *test-count* 0)
 130 (defvar *pass-count* 0)
 131
 132 ;;; Set by RUN-TESTS for use by SHOW-FAILURE
 133 (defvar *test-name* nil)
 134
 135 ;;; If nil, errors in tests are caught and counted.
 136 ;;; If :ask, user is given option of entering debugger or not.
 137 ;;; If true and not :ask, debugger is entered.
 138 (defparameter *use-debugger* nil)
 139
 140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141 ;;; Macros
 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 143
 144 ;;; DEFINE-TEST
 145
 146 (defmacro define-test (name &body body)
 147   `(progn
 148      (store-test-code ',name ',body)
 149      ',name))
 150
 151 ;;; ASSERT macros
 152
 153 (defmacro assert-eq (expected form &rest extras)
 154  (expand-assert :equal form form expected extras :test #'eq))
 155
 156 (defmacro assert-eql (expected form &rest extras)
 157  (expand-assert :equal form form expected extras :test #'eql))
 158
 159 (defmacro assert-equal (expected form &rest extras)
 160  (expand-assert :equal form form expected extras :test #'equal))
 161
 162 (defmacro assert-equalp (expected form &rest extras)
 163  (expand-assert :equal form form expected extras :test #'equalp))
 164
 165 (defmacro assert-error (condition form &rest extras)
 166  (expand-assert :error form (expand-error-form form)
 167                 condition extras))
 168
 169 (defmacro assert-expands (&environment env expansion form &rest extras)
 170   (expand-assert :macro form
 171                  (expand-macro-form form #+lispworks nil #-lispworks env)
 172                  expansion extras))
 173
 174 (defmacro assert-false (form &rest extras)
 175   (expand-assert :result form form nil extras))
 176
 177 (defmacro assert-equality (test expected form &rest extras)
 178  (expand-assert :equal form form expected extras :test test))
 179
 180 (defmacro assert-prints (output form &rest extras)
 181   (expand-assert :output form (expand-output-form form)
 182                  output extras))
 183
 184 (defmacro assert-true (form &rest extras)
 185   (expand-assert :result form form t extras))
 186
 187
 188 (defun expand-assert (type form body expected extras &key (test #'eql))
 189   `(internal-assert
 190     ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test))
 191
 192 (defun expand-error-form (form)
 193   `(handler-case ,form
 194      (condition (error) error)))
 195
 196 (defun expand-output-form (form)
 197   (let ((out (gensym)))
 198     `(let* ((,out (make-string-output-stream))
 199             (*standard-output* (make-broadcast-stream *standard-output* ,out)))
 200        ,form
 201        (get-output-stream-string ,out))))
 202
 203 (defun expand-macro-form (form env)
 204   `(macroexpand-1 ',form ,env))
 205
 206 (defun expand-extras (extras)
 207   `#'(lambda ()
 208        (list ,@(mapcan #'(lambda (form) (list `',form form)) extras))))
 209
 210
 211 ;;; RUN-TESTS
 212
 213 (defmacro run-all-tests (package &rest tests)
 214   `(let ((*package* (find-package ',package)))
 215      (run-tests
 216       ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package))
 217           tests))))
 218
 219 (defmacro run-tests (&rest names)
 220   `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
 221
 222 (defun get-test-thunks (names &optional (package *package*))
 223   (mapcar #'(lambda (name) (get-test-thunk name package))
 224     names))
 225
 226 (defun get-test-thunk (name package)
 227   (assert (get-test-code name package) (name package)
 228           "No test defined for ~S in package ~S" name package)
 229   (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
 230
 231 (defun use-debugger (&optional (flag t))
 232   (setq *use-debugger* flag))
 233
 234 ;;; WITH-TEST-LISTENER
 235 (defmacro with-test-listener (listener &body body)
 236   `(let ((*test-listener* #',listener)) ,@body))
 237
 238 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 239 ;;; Public functions
 240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 241
 242 (defun get-test-code (name &optional (package *package*))
 243   (let ((table (get-package-table package)))
 244     (unless (null table)
 245       (gethash name table))))
 246
 247 (defun get-tests (&optional (package *package*))
 248   (let ((l nil)
 249         (table (get-package-table package)))
 250     (cond ((null table) nil)
 251           (t
 252            (maphash #'(lambda (key val)
 253                         (declare (ignore val))
 254                         (push key l))
 255                     table)
 256            (sort l #'string< :key #'string)))))
 257
 258
 259 (defun remove-tests (names &optional (package *package*))
 260   (let ((table (get-package-table package)))
 261     (unless (null table)
 262       (if (null names)
 263           (clrhash table)
 264         (dolist (name names)
 265           (remhash name table))))))
 266
 267 (defun remove-all-tests (&optional (package *package*))
 268   (if (null package)
 269       (clrhash *tests*)
 270     (remhash (find-package package) *tests*)))
 271
 272
 273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 274 ;;; Private functions
 275 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 276
 277
 278 ;;; DEFINE-TEST support
 279
 280 (defun get-package-table (package &key create)
 281   (let ((table (gethash (find-package package) *tests*)))
 282     (or table
 283         (and create
 284              (setf (gethash package *tests*)
 285                    (make-hash-table))))))
 286
 287 (defun get-test-name (form)
 288   (if (atom form) form (cadr form)))
 289
 290 (defun store-test-code (name code &optional (package *package*))
 291   (setf (gethash name
 292                  (get-package-table package :create t))
 293         code))
 294
 295
 296 ;;; ASSERTION support
 297
 298 (defun internal-assert (type form code-thunk expected-thunk extras test)
 299   (let* ((expected (multiple-value-list (funcall expected-thunk)))
 300          (actual (multiple-value-list (funcall code-thunk)))
 301          (passed (test-passed-p type expected actual test)))
 302
 303     (incf *test-count*)
 304     (when passed
 305       (incf *pass-count*))
 306
 307     (record-result passed type form expected actual extras)
 308
 309     passed))
 310
 311 (defun record-result (passed type form expected actual extras)
 312   (funcall (or *test-listener* 'default-listener)
 313            passed type *test-name* form expected actual
 314            (and extras (funcall extras))
 315            *test-count* *pass-count*))
 316
 317 (defun default-listener
 318     (passed type name form expected actual extras test-count pass-count)
 319   (declare (ignore test-count pass-count))
 320   (unless passed
 321     (show-failure type (get-failure-message type)
 322                   name form expected actual extras)))
 323
 324 (defun test-passed-p (type expected actual test)
 325   (ecase type
 326     (:error
 327      (or (eql (car actual) (car expected))
 328          (typep (car actual) (car expected))))
 329     (:equal
 330      (and (<= (length expected) (length actual))
 331           (every test expected actual)))
 332     (:macro
 333      (equal (car actual) (car expected)))
 334     (:output
 335      (string= (string-trim '(#\newline #\return #\space)
 336                            (car actual))
 337               (car expected)))
 338     (:result
 339      (logically-equal (car actual) (car expected)))
 340     ))
 341
 342
 343 ;;; RUN-TESTS support
 344
 345 (defun run-test-thunks (test-thunks)
 346   (unless (null test-thunks)
 347     (let ((total-test-count 0)
 348           (total-pass-count 0)
 349           (total-error-count 0))
 350       (dolist (test-thunk test-thunks)
 351         (multiple-value-bind (test-count pass-count error-count)
 352             (run-test-thunk (car test-thunk) (cadr test-thunk))
 353           (incf total-test-count test-count)
 354           (incf total-pass-count pass-count)
 355           (incf total-error-count error-count)))
 356       (unless (null (cdr test-thunks))
 357         (show-summary 'total total-test-count total-pass-count total-error-count))
 358       (values))))
 359
 360 (defun run-test-thunk (*test-name* thunk)
 361   (if (null thunk)
 362       (format t "~&    Test ~S not found" *test-name*)
 363     (prog ((*test-count* 0)
 364            (*pass-count* 0)
 365            (error-count 0))
 366       (handler-bind
 367           ((error #'(lambda (e)
 368                       (let ((*print-escape* nil))
 369                         (setq error-count 1)
 370                         (format t "~&    ~S: ~W" *test-name* e))
 371                       (if (use-debugger-p e) e (go exit)))))
 372         (funcall thunk)
 373         (show-summary *test-name* *test-count* *pass-count*))
 374       exit
 375       (return (values *test-count* *pass-count* error-count)))))
 376
 377 (defun use-debugger-p (e)
 378   (and *use-debugger*
 379        (or (not (eql *use-debugger* :ask))
 380            (y-or-n-p "~A -- debug?" e))))
 381
 382 ;;; OUTPUT support
 383
 384 (defun get-failure-message (type)
 385   (case type
 386     (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
 387     (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 388     (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 389     (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 390     ))
 391
 392 (defun show-failure (type msg name form expected actual extras)
 393   (format t "~&~@[~S: ~]~S failed: " name form)
 394   (format t msg expected actual)
 395   (format t "~{~&   ~S => ~S~}~%" extras)
 396   type)
 397
 398 (defun show-summary (name test-count pass-count &optional error-count)
 399   (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
 400           name pass-count (- test-count pass-count) error-count))
 401
 402 (defun collect-form-values (form values)
 403   (mapcan #'(lambda (form-arg value)
 404               (if (constantp form-arg)
 405                   nil
 406                 (list form-arg value)))
 407           (cdr form)
 408           values))
 409
 410
 411 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 412 ;;; Useful equality predicates for tests
 413 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 414
 415 ;;; (LOGICALLY-EQUAL x y) => true or false
 416 ;;;   Return true if x and y both false or both true
 417
 418 (defun logically-equal (x y)
 419   (eql (not x) (not y)))
 420
 421 ;;; (SET-EQUAL l1 l2 :test) => true or false
 422 ;;;   Return true if every element of l1 is an element of l2
 423 ;;;   and vice versa.
 424
 425 (defun set-equal (l1 l2 &key (test #'equal))
 426   (and (listp l1)
 427        (listp l2)
 428        (subsetp l1 l2 :test test)
 429        (subsetp l2 l1 :test test)))
 430
 431 ;;; (ROUNDOFF-ERROR x y) => number
 432 ;;; Return the error delta between the exact and approximate floating
 433 ;;; point value
 434 (defun roundoff-error (exact approximate)
 435   "Returned the error delta between the exact and approximate floating
 436 point value."
 437   (abs (if (or (= 0.0 exact) (= 0.0 approximate))
 438            (+ exact approximate)
 439            (- (/ approximate exact) 1.0))))
 440
 441 ;;; (FLOAT-EQUAL float1 float2 &optional epsilon) => true or false
 442 ;;; Return true if the absolute difference between float1 and float2
 443 ;;; is less than epsilon. If an epsilon is not specified and either
 444 ;;; float1 or float2 is single precision, the single-float-epsilon is
 445 ;;; used.
 446 (defun float-equal (float1 float2 &optional epsilon)
 447   "Return true if the absolute difference between float1 and float2 is
 448 less than some epsilon."
 449   (and
 450    (floatp float1)
 451    (floatp float2)
 452    (cond
 453      ((and (zerop float1) (zerop float2)))
 454      (epsilon
 455       (> epsilon (roundoff-error float1 float2)))
 456      ((and (typep float1 'double-float) (typep float2 'double-float))
 457       (> (* 2.0 double-float-epsilon) (roundoff-error float1 float2)))
 458      ((or (typep float1 'single-float) (typep float2 'single-float))
 459       (> (* 2.0 single-float-epsilon) (roundoff-error float1 float2)))
 460      (t nil))))
 461
 462 ;;; (COMPLEX-EQUAL complex1 complex2 &optional epsilon) => true or false
 463 ;;; Return true if the absolute difference of the real components and
 464 ;;; the absolute difference of the imaginary components is less then
 465 ;;; epsilon. If an epsilon is not specified and either complex1 or
 466 ;;; complex2 is (complex single-float), the single-float-epsilon is
 467 ;;; used.
 468 (defun complex-equal (complex1 complex2 &optional epsilon)
 469   "Return true if the absolute difference between Re(complex1),
 470 Re(complex2) and the absolute difference between Im(complex1),
 471 Im(complex2) is less than epsilon."
 472   (and
 473    (typep complex1 '(complex float))
 474    (typep complex2 '(complex float))
 475    (float-equal (realpart complex1) (realpart complex2) epsilon)
 476    (float-equal (imagpart complex1) (imagpart complex2) epsilon)))
 477
 478 ;;; (NUMBER-EQUAL number1 number2) => true or false
 479 ;;; Return true if the numbers are equal using the appropriate
 480 ;;; comparison.
 481 (defun number-equal (number1 number2 &optional epsilon)
 482   "Return true if the numbers are equal using the appropriate
 483 comparison."
 484   (cond
 485     ((and (floatp number1) (floatp number2))
 486      (float-equal number1 number2 epsilon))
 487     ((and (typep number1 '(complex float)) (typep number2 '(complex float)))
 488      (complex-equal number1 number2 epsilon))
 489     ((and (numberp number1) (numberp number2))
 490      (= number1 number2))
 491     (t (error "~A and ~A are not numbers." number1 number2))))
 492
 493 ;;; (ELEMENT-EQUAL array1 array2 indice dimensions) => true or false
 494 ;;; A utility function for ARRAY-EQUAL.
 495 (defun element-equal (array1 array2 indices dimensions &optional epsilon)
 496   "Return true if the index of array1 equals array2."
 497   (let* ((rank (first dimensions))
 498          (remaining (rest dimensions))
 499          (update-result
 500           (if remaining
 501               (lambda (index)
 502                 (element-equal array1 array2
 503                                (cons index indices) remaining epsilon))
 504               (lambda (index)
 505                 (number-equal (apply #'aref array1 index (reverse indices))
 506                               (apply #'aref array2 index (reverse indices))
 507                               epsilon)))))
 508     (do ((index 0 (1+ index))
 509          (result t (funcall update-result index)))
 510         ((or (not result) (>= index rank)) result))))
 511
 512 ;;; (DIMENSIONS-EQUAL array1 array2) => true or false
 513 ;;; A utility function for ARRAY-EQUAL
 514 (defun dimensions-equal (array1 array2)
 515   "Return trun if ARRAY1 and ARRAY2 are equal dimensions."
 516   (and
 517    (= (array-rank array1) (array-rank array2))
 518    (equal (array-dimensions array1) (array-dimensions array2))))
 519
 520 ;;; (ARRAY-EQUAL array1 array2) => true or false
 521 ;;; Return true of the elements of the array are equal.
 522 (defun array-equal (array1 array2 &optional epsilon)
 523   "Return true if the elements of the array are equal."
 524   (when (dimensions-equal array1 array2)
 525     (element-equal array1 array2 nil (array-dimensions array1) epsilon)))
 526
 527 (provide "lisp-unit")