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   (:documentation "All checking macros will generate an object of
  38  type TEST-RESULT."))
  39
  40 (defclass test-passed (test-result)
  41   ()
  42   (:documentation "Class for successful checks."))
  43
  44 (defgeneric test-passed-p (object)
  45   (:method ((o t)) nil)
  46   (:method ((o test-passed)) t))
  47
  48 (defclass test-failure (test-result)
  49   ()
  50   (:documentation "Class for unsuccessful checks."))
  51
  52 (defgeneric test-failure-p (object)
  53   (:method ((o t)) nil)
  54   (:method ((o test-failure)) t))
  55
  56 (defclass unexpected-test-failure (test-failure)
  57   ((actual-condition :accessor actual-condition :initarg :condition))
  58   (:documentation "Represents the result of a test which neither
  59 passed nor failed, but signaled an error we couldn't deal
  60 with.
  61
  62 Note: This is very different than a SIGNALS check which instead
  63 creates a TEST-PASSED or TEST-FAILURE object."))
  64
  65 (defclass test-skipped (test-result)
  66   ()
  67   (:documentation "A test which was not run. Usually this is due
  68 to unsatisfied dependencies, but users can decide to skip test
  69 when appropiate."))
  70
  71 (defgeneric test-skipped-p (object)
  72   (:method ((o t)) nil)
  73   (:method ((o test-skipped)) t))
  74
  75 (defun add-result (result-type &rest make-instance-args)
  76   "Create a TEST-RESULT object of type RESULT-TYPE passing it the
  77   initialize args MAKE-INSTANCE-ARGS and adds the resulting
  78   object to the list of test results."
  79   (with-run-state (result-list current-test)
  80     (let ((result (apply #'make-instance result-type
  81                          (append make-instance-args (list :test-case current-test)))))
  82       (etypecase result
  83         (test-passed  (format *test-dribble* "."))
  84         (unexpected-test-failure (format *test-dribble* "X"))
  85         (test-failure (format *test-dribble* "f"))
  86         (test-skipped (format *test-dribble* "s")))
  87       (push result result-list))))
  88
  89 ;;;; ** The check operators
  90
  91 ;;;; *** The IS check
  92
  93 (defmacro is (test &rest reason-args)
  94   "The DWIM checking operator.
  95
  96 If TEST returns a true value a test-passed result is generated,
  97 otherwise a test-failure result is generated and the reason,
  98 unless REASON-ARGS is provided, is generated based on the form of
  99 TEST:
 100
 101  (predicate expected actual) - Means that we want to check
 102  whether, according to PREDICATE, the ACTUAL value is
 103  in fact what we EXPECTED.
 104
 105  (predicate value) - Means that we want to ensure that VALUE
 106  satisfies PREDICATE.
 107
 108 Wrapping the TEST form in a NOT simply preducse a negated reason string."
 109   (assert (listp test)
 110           (test)
 111           "Argument to IS must be a list, not ~S" test)
 112   `(if ,test
 113        (add-result 'test-passed)
 114        (add-result 'test-failure
 115                   :reason ,(if (null reason-args)
 116                                (list-match-case test
 117                                  ((not (?predicate ?expected ?actual))
 118                                   `(format nil "~S was ~S to ~S" ,?actual ',?predicate ,?expected))
 119                                  ((not (?satisfies ?value))
 120                                   `(format nil "~S satisfied ~S" ,?value ',?satisfies))
 121                                  ((?predicate ?expected ?actual)
 122                                   `(format nil "~S was not ~S to ~S" ,?actual ',?predicate ,?expected))
 123                                  ((?satisfies ?value)
 124                                   `(format nil "~S did not satisfy ~S" ,?value ',?satisfies))
 125                                  (t
 126                                   `(is-true ,test ,@reason-args)))
 127                              `(format nil ,@reason-args)))))
 128
 129 ;;;; *** Other checks
 130
 131 (defmacro skip (&rest reason)
 132   "Generates a TEST-SKIPPED result."
 133   `(progn
 134      (format *test-dribble* "s")
 135      (add-result 'test-skipped :reason (format nil ,@reason))))
 136
 137 (defmacro is-true (condition &rest reason-args)
 138   "Like IS this check generates a pass if CONDITION returns true
 139   and a failure if CONDITION returns false. Unlike IS this check
 140   does not inspect CONDITION to determine how to report the
 141   failure."
 142   `(if ,condition
 143        (add-result 'test-passed)
 144        (add-result 'test-failure :reason ,(if reason-args
 145                                               `(format nil ,@reason-args)
 146                                               `(format nil "~S did not return a true value" ',condition)))))
 147
 148 (defmacro is-false (condition &rest reason-args)
 149   "Generates a pass if CONDITION returns false, generates a
 150   failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
 151   not inspect CONDITION to determine what reason to give it case
 152   of test failure"
 153   `(if ,condition
 154        (add-result 'test-failure :reason ,(if reason-args
 155                                               `(format nil ,@reason-args)
 156                                               `(format nil "~S returned a true value" ',condition)))
 157        (add-result 'test-passed)))
 158
 159 (defmacro signals (condition &body body)
 160   "Generates a pass if BODY signals a condition of type
 161 CONDITION. BODY is evaluated in a block named NIL, CONDITION is
 162 not evaluated."
 163   (let ((block-name (gensym)))
 164     `(block ,block-name
 165        (handler-bind ((,condition (lambda (c)
 166                                     (declare (ignore c))
 167                                     ;; ok, body threw condition
 168                                     (add-result 'test-passed)
 169                                     (return-from ,block-name t))))
 170          (block nil
 171            ,@body
 172            (add-result 'test-failure :reason (format nil "Failed to signal a ~S" ',condition))
 173            (return-from ,block-name nil))))))
 174
 175 (defmacro finishes (&body body)
 176   "Generates a pass if BODY executes to normal completion. In
 177 other words if body does signal, return-from or throw this test
 178 fails."
 179   `(let ((ok nil))
 180      (unwind-protect
 181          (progn
 182            ,@body
 183            (setf ok t))
 184        (if ok
 185            (add-result 'test-passed)
 186            (add-result 'test-failure
 187                        :reason (format nil "Test didn't finish"))))))
 188
 189 (defmacro pass (&rest message-args)
 190   "Simply generate a PASS."
 191   `(add-result 'test-passed ,@(when message-args
 192                                 `(:reason (format nil ,@message-args)))))
 193
 194 (defmacro fail (&rest message-args)
 195   "Simply generate a FAIL."
 196   `(add-result 'test-failure ,@(when message-args
 197                                  `(:reason (format nil ,@message-args)))))
 198
 199 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 200 ;; All rights reserved.
 201 ;;
 202 ;; Redistribution and use in source and binary forms, with or without
 203 ;; modification, are permitted provided that the following conditions are
 204 ;; met:
 205 ;;
 206 ;;  - Redistributions of source code must retain the above copyright
 207 ;;    notice, this list of conditions and the following disclaimer.
 208 ;;
 209 ;;  - Redistributions in binary form must reproduce the above copyright
 210 ;;    notice, this list of conditions and the following disclaimer in the
 211 ;;    documentation and/or other materials provided with the distribution.
 212 ;;
 213 ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
 214 ;;    of its contributors may be used to endorse or promote products
 215 ;;    derived from this software without specific prior written permission.
 216 ;;
 217 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 218 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 219 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 220 ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
 221 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 222 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 223 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 224 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 225 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 226 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 227 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE