src/check.lisp

   1 ;; -*- lisp -*-
   2
   3 (in-package :it.bese.FiveAM)
   4
   5 ;;;; * Checks
   6
   7 ;;;; At the lowest level testing the system requires that certain
   8 ;;;; forms be evaluated and that certain post conditions are met: the
   9 ;;;; value returned must satisfy a certain predicate, the form must
  10 ;;;; (or must not) signal a certain condition, etc. In FiveAM these
  11 ;;;; low level operations are called 'checks' and are defined using
  12 ;;;; the various checking macros.
  13
  14 ;;;; Checks are the basic operators for collecting results. Tests and
  15 ;;;; test suites on the other hand allow grouping multiple checks into
  16 ;;;; logic collections.
  17
  18 (defvar *test-dribble* t)
  19
  20 (defmacro with-*test-dribble* (stream &body body)
  21   `(let ((*test-dribble* ,stream))
  22      (declare (special *test-dribble*))
  23      ,@body))
  24
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   (def-special-environment run-state ()
  27     result-list
  28     current-test))
  29
  30 ;;;; ** Types of test results
  31
  32 ;;;; Every check produces a result object.
  33
  34 (defclass test-result ()
  35   ((reason :accessor reason :initarg :reason :initform "no reason given")
  36    (test-case :accessor test-case :initarg :test-case)
  37    (test-expr :accessor test-expr :initarg :test-expr))
  38   (:documentation "All checking macros will generate an object of
  39  type TEST-RESULT."))
  40
  41 (defclass test-passed (test-result)
  42   ()
  43   (:documentation "Class for successful checks."))
  44
  45 (defgeneric test-passed-p (object)
  46   (:method ((o t)) nil)
  47   (:method ((o test-passed)) t))
  48
  49 (defclass test-failure (test-result)
  50   ()
  51   (:documentation "Class for unsuccessful checks."))
  52
  53 (defgeneric test-failure-p (object)
  54   (:method ((o t)) nil)
  55   (:method ((o test-failure)) t))
  56
  57 (defclass unexpected-test-failure (test-failure)
  58   ((actual-condition :accessor actual-condition :initarg :condition))
  59   (:documentation "Represents the result of a test which neither
  60 passed nor failed, but signaled an error we couldn't deal
  61 with.
  62
  63 Note: This is very different than a SIGNALS check which instead
  64 creates a TEST-PASSED or TEST-FAILURE object."))
  65
  66 (defclass test-skipped (test-result)
  67   ()
  68   (:documentation "A test which was not run. Usually this is due
  69 to unsatisfied dependencies, but users can decide to skip test
  70 when appropiate."))
  71
  72 (defgeneric test-skipped-p (object)
  73   (:method ((o t)) nil)
  74   (:method ((o test-skipped)) t))
  75
  76 (defparameter *debug-on-failure* nil
  77   "If non-NIL then we drop into a debugger at each test failure.")
  78
  79 (define-condition debug-test-failure (error)
  80   ((failed-result :initarg :failed-result :accessor failed-result)
  81    (failed-test :initarg :failed-test :accessor failed-test))
  82   (:report (lambda (condition stream)
  83              (format stream "Test ~S failed with ~S."
  84                      (failed-test condition)
  85                      (failed-result condition)))))
  86
  87 (defun add-result (result-type &rest make-instance-args)
  88   "Create a TEST-RESULT object of type RESULT-TYPE passing it the
  89   initialize args MAKE-INSTANCE-ARGS and adds the resulting
  90   object to the list of test results."
  91   (with-run-state (result-list current-test)
  92     (let ((result (apply #'make-instance result-type
  93                          (append make-instance-args (list :test-case current-test)))))
  94       (etypecase result
  95         (test-passed  (format *test-dribble* "."))
  96         (unexpected-test-failure (format *test-dribble* "X"))
  97         (test-failure
  98          (when *debug-on-failure*
  99            (restart-case
 100                (invoke-debugger (make-instance 'debug-test-failure
 101                                                :failed-test current-test
 102                                                :failed-result result))
 103              (fail ()
 104                :report "Report a test failure and continue.")))
 105          (format *test-dribble* "f"))
 106         (test-skipped (format *test-dribble* "s")))
 107       (push result result-list))))
 108
 109 ;;;; ** The check operators
 110
 111 ;;;; *** The IS check
 112
 113 (defmacro is (test &rest reason-args)
 114   "The DWIM checking operator.
 115
 116 If TEST returns a true value a test-passed result is generated,
 117 otherwise a test-failure result is generated and the reason,
 118 unless REASON-ARGS is provided, is generated based on the form of
 119 TEST:
 120
 121  (predicate expected actual) - Means that we want to check
 122  whether, according to PREDICATE, the ACTUAL value is
 123  in fact what we EXPECTED.
 124
 125  (predicate value) - Means that we want to ensure that VALUE
 126  satisfies PREDICATE.
 127
 128 Wrapping the TEST form in a NOT simply preducse a negated reason string."
 129   (assert (listp test)
 130           (test)
 131           "Argument to IS must be a list, not ~S" test)
 132   (let (bindings effective-test default-reason-args)
 133     (with-unique-names (e a v)
 134       (list-match-case test
 135         ((not (?predicate ?expected ?actual))
 136          (setf bindings (list (list e ?expected)
 137                               (list a ?actual))
 138                effective-test `(not (,?predicate ,e ,a))
 139                default-reason-args (list "~S was ~S to ~S" a `',?predicate e)))
 140         ((not (?satisfies ?value))
 141          (setf bindings (list (list v ?value))
 142                effective-test `(not (,?satisfies ,v))
 143                default-reason-args (list  "~S satisfied ~S" v `',?satisfies)))
 144         ((?predicate ?expected ?actual)
 145          (setf bindings (list (list e ?expected)
 146                               (list a ?actual))
 147                effective-test `(,?predicate ,e ,a)
 148                default-reason-args (list "~S was not ~S to ~S" a `',?predicate e)))
 149         ((?satisfies ?value)
 150          (setf bindings (list (list v ?value))
 151                effective-test `(,?satisfies ,v)
 152                default-reason-args (list "~S did not satisfy ~S" v `',?satisfies)))
 153         (t
 154          (setf bindings '()
 155                effective-test test
 156                default-reason-args "No reason supplied.")))
 157       `(let ,bindings
 158          (if ,effective-test
 159              (add-result 'test-passed :test-expr ',test)
 160              (add-result 'test-failure
 161                          :reason ,(if (null reason-args)
 162                                       `(format nil ,@default-reason-args)
 163                                       `(format nil ,@reason-args))
 164                          :test-expr ',test))))))
 165
 166 ;;;; *** Other checks
 167
 168 (defmacro skip (&rest reason)
 169   "Generates a TEST-SKIPPED result."
 170   `(progn
 171      (format *test-dribble* "s")
 172      (add-result 'test-skipped :reason (format nil ,@reason))))
 173
 174 (defmacro is-true (condition &rest reason-args)
 175   "Like IS this check generates a pass if CONDITION returns true
 176   and a failure if CONDITION returns false. Unlike IS this check
 177   does not inspect CONDITION to determine how to report the
 178   failure."
 179   `(if ,condition
 180        (add-result 'test-passed :test-expr ',condition)
 181        (add-result 'test-failure :reason ,(if reason-args
 182                                               `(format nil ,@reason-args)
 183                                               `(format nil "~S did not return a true value" ',condition))
 184                    :test-expr ',condition)))
 185
 186 (defmacro is-false (condition &rest reason-args)
 187   "Generates a pass if CONDITION returns false, generates a
 188   failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
 189   not inspect CONDITION to determine what reason to give it case
 190   of test failure"
 191   `(if ,condition
 192        (add-result 'test-failure :reason ,(if reason-args
 193                                               `(format nil ,@reason-args)
 194                                               `(format nil "~S returned a true value" ',condition))
 195                    :test-expr ',condition)
 196        (add-result 'test-passed :test-expr ',condition)))
 197
 198 (defmacro signals (condition &body body)
 199   "Generates a pass if BODY signals a condition of type
 200 CONDITION. BODY is evaluated in a block named NIL, CONDITION is
 201 not evaluated."
 202   (let ((block-name (gensym)))
 203     `(block ,block-name
 204        (handler-bind ((,condition (lambda (c)
 205                                     (declare (ignore c))
 206                                     ;; ok, body threw condition
 207                                     (add-result 'test-passed
 208                                                 :test-expr ',condition)
 209                                     (return-from ,block-name t))))
 210          (block nil
 211            ,@body
 212            (add-result 'test-failure
 213                        :reason (format nil "Failed to signal a ~S" ',condition)
 214                        :test-expr ',condition)
 215            (return-from ,block-name nil))))))
 216
 217 (defmacro finishes (&body body)
 218   "Generates a pass if BODY executes to normal completion. In
 219 other words if body does signal, return-from or throw this test
 220 fails."
 221   `(let ((ok nil))
 222      (unwind-protect
 223          (progn
 224            ,@body
 225            (setf ok t))
 226        (if ok
 227            (add-result 'test-passed :test-expr ',body)
 228            (add-result 'test-failure
 229                        :reason (format nil "Test didn't finish")
 230                        :test-expr ',body)))))
 231
 232 (defmacro pass (&rest message-args)
 233   "Simply generate a PASS."
 234   `(add-result 'test-passed
 235                :test-expr ',message-args
 236                ,@(when message-args
 237                        `(:reason (format nil ,@message-args)))))
 238
 239 (defmacro fail (&rest message-args)
 240   "Simply generate a FAIL."
 241   `(add-result 'test-failure
 242                :test-expr ',message-args
 243                ,@(when message-args
 244                        `(:reason (format nil ,@message-args)))))
 245
 246 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 247 ;; All rights reserved.
 248 ;;
 249 ;; Redistribution and use in source and binary forms, with or without
 250 ;; modification, are permitted provided that the following conditions are
 251 ;; met:
 252 ;;
 253 ;;  - Redistributions of source code must retain the above copyright
 254 ;;    notice, this list of conditions and the following disclaimer.
 255 ;;
 256 ;;  - Redistributions in binary form must reproduce the above copyright
 257 ;;    notice, this list of conditions and the following disclaimer in the
 258 ;;    documentation and/or other materials provided with the distribution.
 259 ;;
 260 ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
 261 ;;    of its contributors may be used to endorse or promote products
 262 ;;    derived from this software without specific prior written permission.
 263 ;;
 264 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 265 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 266 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 267 ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
 268 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 269 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 270 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 271 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 272 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 273 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 274 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE