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 How to use
  26 ----------
  27
  28 1. Read the documentation at:
  29    https://github.com/OdonataResearchLLC/lisp-unit/wiki
  30
  31 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  32 examples. If you want, start your test file with (REMOVE-TESTS :ALL)
  33 to clear any previously defined tests.
  34
  35 3. Load this file.
  36
  37 4. (use-package :lisp-unit)
  38
  39 5. Load your code file and your file of tests.
  40
  41 6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or
  42 simply (RUN-TESTS :ALL) to run all defined tests.
  43
  44 A summary of how many tests passed and failed will be printed.
  45
  46 NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining
  47 functions or even macros does not require reloading any tests.
  48
  49 |#
  50
  51 ;;; Packages
  52
  53 (in-package :cl-user)
  54
  55 (defpackage :lisp-unit
  56   (:use :common-lisp)
  57   ;; Print parameters
  58   (:export :*print-summary*
  59            :*print-failures*
  60            :*print-errors*)
  61   ;; Forms for assertions
  62   (:export :assert-eq
  63            :assert-eql
  64            :assert-equal
  65            :assert-equalp
  66            :assert-equality
  67            :assert-prints
  68            :assert-expands
  69            :assert-true
  70            :assert-false
  71            :assert-error)
  72   ;; Functions for managing tests
  73   (:export :define-test
  74            :get-tests
  75            :get-test-code
  76            :remove-tests
  77            :run-tests
  78            :use-debugger)
  79   ;; Functions for reporting test results
  80   (:export :test-names
  81            :failed-tests
  82            :error-tests
  83            :missing-tests
  84            :summarize-results)
  85   ;; Utility predicates
  86   (:export :logically-equal :set-equal))
  87
  88 (in-package :lisp-unit)
  89
  90 ;;; Global counters
  91
  92 (defparameter *pass* 0
  93   "The number of passed assertions.")
  94
  95 (defparameter *fail* 0
  96   "The number of failed assertions.")
  97
  98 ;;; Global options
  99
 100 (defparameter *print-summary* nil
 101   "Print a summary of the pass, fail, and error count if non-nil.")
 102
 103 (defparameter *print-failures* nil
 104   "Print failure messages if non-NIL.")
 105
 106 (defparameter *print-errors* nil
 107   "Print error messages if non-NIL.")
 108
 109 (defparameter *use-debugger* nil
 110   "If not NIL, enter the debugger when an error is encountered in an
 111 assertion.")
 112
 113 (defun use-debugger-p (condition)
 114   "Debug or ignore errors."
 115   (cond
 116    ((eq :ask *use-debugger*)
 117     (y-or-n-p "~A -- debug?" condition))
 118    (*use-debugger*)))
 119
 120 ;;; Failure control strings
 121
 122 (defgeneric failure-control-string (type)
 123   (:method (type)
 124    "~& | Expected ~{~S~^; ~} ~<~% | ~:;but saw ~{~S~^; ~}~>")
 125   (:documentation
 126    "Return the FORMAT control string for the failure type."))
 127
 128 (defmethod failure-control-string ((type (eql :error)))
 129   "~& | ~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
 130
 131 (defmethod failure-control-string ((type (eql :macro)))
 132   "~& | Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 133
 134 (defmethod failure-control-string ((type (eql :output)))
 135   "~& | Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
 136
 137 (defun print-failure (type form expected actual extras)
 138   "Report the details of the failure assertion."
 139   (format t " | Failed Form: ~S" form)
 140   (format t (failure-control-string type) expected actual)
 141   (when extras
 142     (format t "~{~& | ~S => ~S~}~%" (funcall extras)))
 143   (format t "~& |~%")
 144   type)
 145
 146 (defun print-error (condition)
 147   "Print the error condition."
 148   (let ((*print-escape* nil))
 149     (format t "~& | Execution error:~% | ~W" condition)
 150     (format t "~& |~%")))
 151
 152 (defun print-summary (name pass fail &optional exerr)
 153   "Print a summary of the test results."
 154   (format t "~&~A: ~S assertions passed, ~S failed"
 155           name pass fail)
 156   (format t "~@[, ~S execution errors~].~2%" exerr))
 157
 158 ;;; Global unit test database
 159
 160 (defparameter *test-db* (make-hash-table :test #'eq)
 161   "The unit test database is simply a hash table.")
 162
 163 (defun package-table (package &optional create)
 164   (cond
 165    ((gethash (find-package package) *test-db*))
 166    (create
 167     (setf (gethash package *test-db*) (make-hash-table)))
 168    (t (warn "No tests defined for package: ~S" package))))
 169
 170 (defclass unit-test ()
 171   ((doc
 172     :type string
 173     :initarg :doc
 174     :reader doc)
 175    (code
 176     :type list
 177     :initarg :code
 178     :reader code))
 179   (:default-initargs :doc "" :code ())
 180   (:documentation))
 181
 182 (defmacro define-test (name &body body)
 183   "Store the test in the test database."
 184   `(progn
 185      (setf
 186       (gethash ',name (package-table *package* t))
 187       (make-instance 'unit-test :code ',body))
 188      ;; Return the name of the test
 189      ',name))
 190
 191 ;;; Manage tests
 192
 193 (defun get-tests (&optional (package *package*))
 194   "Return a list of the tests in package."
 195   (let ((table (package-table package)))
 196     (when table
 197       (loop for test-name being each hash-key in table
 198             collect test-name))))
 199
 200 (defun get-test-code (name &optional (package *package*))
 201   "Returns the code stored for the test name."
 202   (let ((unit-test (gethash name (package-table package))))
 203     (if (null unit-test)
 204         (warn "No code defined for test ~A in package ~S."
 205               name package)
 206         (code unit-test))))
 207
 208 (defun remove-tests (names &optional (package *package*))
 209   "Remove individual tests or entire sets."
 210   (if (eq :all names)
 211       (if (null package)
 212           (clrhash *test-db*)
 213           (remhash (find-package package) *test-db*))
 214       (let ((table (package-table package)))
 215         (unless (null table)
 216           (loop for name in names
 217                 always (remhash name table)
 218                 collect name into removed
 219                 finally (return removed))))))
 220
 221 ;;; Assert macros
 222
 223 (defmacro assert-eq (expected form &rest extras)
 224   "Assert whether expected and form are EQ."
 225   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 226
 227 (defmacro assert-eql (expected form &rest extras)
 228   "Assert whether expected and form are EQL."
 229   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 230
 231 (defmacro assert-equal (expected form &rest extras)
 232   "Assert whether expected and form are EQUAL."
 233   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 234
 235 (defmacro assert-equalp (expected form &rest extras)
 236   "Assert whether expected and form are EQUALP."
 237   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 238
 239 (defmacro assert-error (condition form &rest extras)
 240   "Assert whether form signals condition."
 241   `(expand-assert :error ,form (expand-error-form ,form)
 242                   ,condition ,extras))
 243
 244 (defmacro assert-expands (expansion form &rest extras)
 245   "Assert whether form expands to expansion."
 246   `(expand-assert :macro ,form
 247                   (expand-macro-form ,form nil)
 248                   ,expansion ,extras))
 249
 250 (defmacro assert-false (form &rest extras)
 251   "Assert whether the form is false."
 252   `(expand-assert :result ,form ,form nil ,extras))
 253
 254 (defmacro assert-equality (test expected form &rest extras)
 255   "Assert whether expected and form are equal according to test."
 256   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 257
 258 (defmacro assert-prints (output form &rest extras)
 259   "Assert whether printing the form generates the output."
 260   `(expand-assert :output ,form (expand-output-form ,form)
 261                   ,output ,extras))
 262
 263 (defmacro assert-true (form &rest extras)
 264   "Assert whether the form is true."
 265   `(expand-assert :result ,form ,form t ,extras))
 266
 267 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 268   "Expand the assertion to the internal format."
 269   `(internal-assert ,type ',form
 270                     (lambda () ,body)
 271                     (lambda () ,expected)
 272                     (expand-extras ,extras)
 273                     ,test))
 274
 275 (defmacro expand-error-form (form)
 276   "Wrap the error assertion in HANDLER-CASE."
 277   `(handler-case ,form
 278      (condition (error) error)))
 279
 280 (defmacro expand-output-form (form)
 281   "Capture the output of the form in a string."
 282   (let ((out (gensym)))
 283     `(let* ((,out (make-string-output-stream))
 284             (*standard-output*
 285              (make-broadcast-stream *standard-output* ,out)))
 286        ,form
 287        (get-output-stream-string ,out))))
 288
 289 (defmacro expand-macro-form (form env)
 290   "Expand the macro form once."
 291   `(macroexpand-1 ',form ,env))
 292
 293 (defmacro expand-extras (extras)
 294   "Expand extra forms."
 295   `(lambda ()
 296      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 297
 298 (defun internal-assert
 299        (type form code-thunk expected-thunk extras test)
 300   "Perform the assertion and record the results."
 301   (let ((expected (multiple-value-list (funcall expected-thunk)))
 302         (actual (multiple-value-list (funcall code-thunk)))
 303         (passed nil))
 304     ;; Count the assertion
 305     (if (setq passed (test-passed-p type expected actual test))
 306         (incf *pass*)
 307         (incf *fail*))
 308     ;; Report the assertion
 309     (when (and (not passed) *print-failures*)
 310       (print-failure type form expected actual extras))
 311     ;; Return the result
 312     passed))
 313
 314 ;;; Test passed predicate.
 315
 316 (defgeneric test-passed-p (type expected actual test)
 317   (:documentation
 318    "Return the result of the test."))
 319
 320 (defmethod test-passed-p ((type (eql :error)) expected actual test)
 321   "Return the result of the error assertion."
 322   (or
 323    (eql (car actual) (car expected))
 324    (typep (car actual) (car expected))))
 325
 326 (defmethod test-passed-p ((type (eql :equal)) expected actual test)
 327   "Return the result of the equality assertion."
 328   (and
 329    (<= (length expected) (length actual))
 330    (every test expected actual)))
 331
 332 (defmethod test-passed-p ((type (eql :macro)) expected actual test)
 333   "Return the result of the macro expansion."
 334   (equal (car actual) (car expected)))
 335
 336 (defmethod test-passed-p ((type (eql :output)) expected actual test)
 337   "Return the result of the printed output."
 338   (string=
 339    (string-trim '(#\newline #\return #\space) (car actual))
 340    (car expected)))
 341
 342 (defmethod test-passed-p ((type (eql :result)) expected actual test)
 343   "Return the result of the assertion."
 344   (logically-equal (car actual) (car expected)))
 345
 346 ;;; Results
 347
 348 (defclass test-results ()
 349   ((test-names
 350     :type list
 351     :initarg :test-names
 352     :accessor test-names)
 353    (pass
 354     :type fixnum
 355     :initform 0
 356     :accessor pass)
 357    (fail
 358     :type fixnum
 359     :initform 0
 360     :accessor fail)
 361    (exerr
 362     :type fixnum
 363     :initform 0
 364     :accessor exerr)
 365    (failed-tests
 366     :type list
 367     :initform ()
 368     :accessor failed-tests)
 369    (error-tests
 370     :type list
 371     :initform ()
 372     :accessor error-tests)
 373    (missing-tests
 374     :type list
 375     :initform ()
 376     :accessor missing-tests))
 377   (:default-initargs :test-names ())
 378   (:documentation
 379    "Store the results of the tests for further evaluation."))
 380
 381 (defmethod print-object ((object test-results) stream)
 382   "Print the summary counts with the object."
 383   (format stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 384           (class-name (class-of object))
 385           (+ (pass object) (fail object))
 386           (pass object) (fail object) (exerr object)))
 387
 388 (defun record-result (test-name code results)
 389   "Run the test code and record the result."
 390   (multiple-value-bind (pass fail exerr)
 391       (run-test-thunk code)
 392     (push test-name (test-names results))
 393     ;; Count passed tests
 394     (when (plusp pass)
 395       (incf (pass results) pass))
 396     ;; Count failed tests and record name
 397     (when (plusp fail)
 398       (incf (fail results) fail)
 399       (push test-name (failed-tests results)))
 400     ;; Count errors and record name
 401     (when (eq :error exerr)
 402       (incf (exerr results))
 403       (push test-name (error-tests results)))
 404     ;; Print a summary of the results
 405     (when (or *print-summary* *print-failures* *print-errors*)
 406       (print-summary
 407        test-name pass fail
 408        (when (eq :error exerr) 1)))))
 409
 410 (defun summarize-results (results)
 411   "Print a summary of all results."
 412   (let ((pass (pass results))
 413         (fail (fail results)))
 414     (format t "~&Unit Test Summary~%")
 415     (format t " | ~D assertions total~%" (+ pass fail))
 416     (format t " | ~D passed~%" pass)
 417     (format t " | ~D failed~%" fail)
 418     (format t " | ~D execution errors~%" (exerr results))
 419     (format t " | ~D missing tests~2%"
 420             (length (missing-tests results)))))
 421
 422 ;;; Run the tests
 423
 424 (defun run-code (code)
 425   "Run the code to test the assertions."
 426   (funcall (coerce `(lambda () ,@code) 'function)))
 427
 428 (defun run-test-thunk (code)
 429   (let ((*pass* 0)
 430         (*fail* 0))
 431     (handler-case (run-code code)
 432       (error (condition)
 433         (when *print-errors*
 434           (print-error condition))
 435         (if (use-debugger-p condition)
 436             condition
 437             (return-from run-test-thunk
 438               (values *pass* *fail* :error)))))
 439     ;; Return the result count
 440     (values *pass* *fail* nil)))
 441
 442 (defun %run-all-thunks (&optional (package *package*))
 443   "Run all of the test thunks in the package."
 444   (loop
 445    with results = (make-instance 'test-results)
 446    for test-name being each hash-key in (package-table package)
 447    using (hash-value unit-test)
 448    if unit-test do
 449    (record-result test-name (code unit-test) results)
 450    else do
 451    (push test-name (missing-tests results))
 452    ;; Summarize and return the test results
 453    finally
 454    (summarize-results results)
 455    (return results)))
 456
 457 (defun %run-thunks (test-names &optional (package *package*))
 458   "Run the list of test thunks in the package."
 459   (loop
 460    with table = (package-table package)
 461    and results = (make-instance 'test-results)
 462    for test-name in test-names
 463    as unit-test = (gethash test-name table)
 464    if unit-test do
 465    (record-result test-name (code unit-test) results)
 466    else do
 467    (push test-name (missing-tests results))
 468    finally
 469    (summarize-results results)
 470    (return results)))
 471
 472 (defun run-tests (test-names &optional (package *package*))
 473   "Run the specified tests in package."
 474   (if (eq :all test-names)
 475       (%run-all-thunks package)
 476       (%run-thunks test-names package)))
 477
 478 ;;; Useful equality predicates for tests
 479
 480 ;;; (LOGICALLY-EQUAL x y) => true or false
 481 ;;;   Return true if x and y both false or both true
 482 (defun logically-equal (x y)
 483   (eql (not x) (not y)))
 484
 485 ;;; (SET-EQUAL l1 l2 :test) => true or false
 486 ;;;   Return true if every element of l1 is an element of l2
 487 ;;;   and vice versa.
 488 (defun set-equal (l1 l2 &key (test #'equal))
 489   (and (listp l1)
 490        (listp l2)
 491        (subsetp l1 l2 :test test)
 492        (subsetp l2 l1 :test test)))
 493
 494 (pushnew :lisp-unit common-lisp:*features*)