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