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