src/check.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   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-expr :accessor test-expr :initarg :test-expr)
  37    (test-case :accessor test-case
  38               :initarg :test-case
  39               :initform (with-run-state (current-test)
  40                           current-test)))
  41   (:documentation "All checking macros will generate an object of
  42 type TEST-RESULT."))
  43
  44 (defgeneric test-result-p (object)
  45   (:method ((o test-result)) t)
  46   (:method ((o t)) nil))
  47
  48 (defclass test-passed (test-result)
  49   ()
  50   (:documentation "Class for successful checks."))
  51
  52 (defgeneric test-passed-p (object)
  53   (:method ((o t)) nil)
  54   (:method ((o test-passed)) t))
  55
  56 ;; if a condition could inhert from a class we could avoid duplicating
  57 ;; these slot definitions...
  58
  59 (define-condition check-failure (error)
  60   ((failure :accessor failure :initarg :failure)
  61    (test-expr :accessor test-expr :initarg :test-expr)
  62    (test-case :accessor test-case
  63               :initarg :test-case
  64               :initform (with-run-state (current-test)
  65                           current-test)))
  66   (:documentation "Signaled when a check fails.")
  67   (:report  (lambda (c stream)
  68               (format stream "The following check failed: ~S~%~A."
  69                       (test-expr (failure c))
  70                       (reason (failure c))))))
  71
  72 (defun process-failure (failure-object)
  73   (restartable-check-failure failure-object)
  74   (add-result failure-object))
  75
  76 (defun restartable-check-failure (failure)
  77   (with-simple-restart (ignore-failure "Continue the test run.")
  78     (error 'check-failure :failure failure)))
  79
  80 (defclass test-failure (test-result)
  81   ()
  82   (:documentation "Class for unsuccessful checks."))
  83
  84 (defgeneric test-failure-p (object)
  85   (:method ((o t)) nil)
  86   (:method ((o test-failure)) t))
  87
  88 (defclass unexpected-test-failure (test-failure)
  89   ((actual-condition :accessor actual-condition :initarg :condition))
  90   (:documentation "Represents the result of a test which neither
  91 passed nor failed, but signaled an error we couldn't deal
  92 with.
  93
  94 Note: This is very different than a SIGNALS check which instead
  95 creates a TEST-PASSED or TEST-FAILURE object."))
  96
  97 (defclass test-skipped (test-result)
  98   ()
  99   (:documentation "A test which was not run. Usually this is due
 100 to unsatisfied dependencies, but users can decide to skip test
 101 when appropiate."))
 102
 103 (defgeneric test-skipped-p (object)
 104   (:method ((o t)) nil)
 105   (:method ((o test-skipped)) t))
 106
 107 (defun add-result (result-type &rest make-instance-args)
 108   "Create a TEST-RESULT object of type RESULT-TYPE passing it the
 109 initialize args MAKE-INSTANCE-ARGS and adds the resulting object to
 110 the list of test results.
 111
 112 If RESULT-TYPE is already a TEST-RESULT object it is used as is and
 113 the MAKE-INSTANCE-ARGS are ignored."
 114   (with-run-state (result-list)
 115     (let ((result (if (test-result-p result-type)
 116                       result-type
 117                       (apply #'make-instance result-type make-instance-args))))
 118       (etypecase result
 119         (test-passed  (format *test-dribble* "."))
 120         (unexpected-test-failure (format *test-dribble* "X"))
 121         (test-failure (format *test-dribble* "f"))
 122         (test-skipped (format *test-dribble* "s")))
 123       (push result result-list))))
 124
 125 ;;;; ** The check operators
 126
 127 ;;;; *** The IS check
 128
 129 (defun parse-dwim-is-arguments (form)
 130   (destructuring-bind (test &optional reason-string &rest reason-args)
 131       form
 132     (let ((reason-form (if reason-string
 133                            `(:reason (format nil ,reason-string ,@reason-args))
 134                            nil))
 135           (expected-value (gensym))
 136           (actual-value (gensym)))
 137       (flet ((make-failure-instance (type &key predicate expected actual condition)
 138                (values `(make-instance ',type
 139                                        ,@reason-form
 140                                        :predicate ',predicate
 141                                        :test-expr ',test
 142                                        ,@(when expected
 143                                            `(:expected-form ',expected :expected-value ,expected-value))
 144                                        ,@(when actual
 145                                            `(:actual-form ',actual :actual-value ,actual-value)))
 146                        (append (when expected
 147                                  `((,expected-value ,expected)))
 148                                (when actual
 149                                  `((,actual-value ,actual))))
 150                        condition)))
 151         (list-match-case test
 152           ((not (?predicate ?expected ?actual))
 153
 154            (make-failure-instance 'is-negated-binary-failure
 155                                   :predicate ?predicate
 156                                   :expected ?expected
 157                                   :actual ?actual
 158
 159                                   :condition `(not (,?predicate ,expected-value ,actual-value))))
 160
 161           ((not (?predicate ?expected))
 162
 163            (make-failure-instance 'is-negated-unary-failure
 164                                   :predicate ?predicate
 165                                   :expected ?expected
 166                                   :condition `(not (,?predicate ,expected-value))))
 167
 168           ((?predicate ?expected ?actual)
 169
 170            (make-failure-instance 'is-binary-failure
 171                                   :predicate ?predicate
 172                                   :expected ?expected
 173                                   :actual ?actual
 174                                   :condition `(,?predicate ,expected-value ,actual-value)))
 175           ((?predicate ?expected)
 176
 177            (make-failure-instance 'is-unary-failure
 178                                   :predicate ?predicate
 179                                   :expected ?expected
 180                                   :condition `(,?predicate ,expected-value)))
 181           (_
 182            (values `(make-instance 'test-failure ,@reason-form)
 183                    '()
 184                    test)))))))
 185
 186 (defmacro is (test &rest reason-args)
 187   "The DWIM checking operator.
 188
 189 If TEST returns a true value a test-passed result is generated,
 190 otherwise a test-failure result is generated. The reason, unless
 191 REASON-ARGS is provided, is generated based on the form of TEST:
 192
 193 `(predicate expected actual)`::
 194
 195 Means that we want to check whether, according to PREDICATE, the
 196 ACTUAL value is in fact what we EXPECTED.
 197
 198 `(predicate value)`::
 199
 200 Means that we want to ensure that VALUE satisfies PREDICATE.
 201
 202 Wrapping the TEST form in a NOT simply produces a negated reason
 203 string."
 204   (assert (listp test)
 205           (test)
 206           "Argument to IS must be a list, not ~S" test)
 207   (multiple-value-bind (make-failure-form bindings predicate)
 208       (parse-dwim-is-arguments (list* test reason-args))
 209     `(let ,bindings
 210        (if ,predicate
 211            (add-result 'test-passed :test-expr ',test)
 212            (process-failure ,make-failure-form)))))
 213
 214 (defclass is-failure-mixin ()
 215   ((predicate :initarg :predicate :accessor predicate)
 216    (expected-value :initarg :expected-value :accessor expected-value)
 217    (expected-form  :initarg :expected-form  :accessor expected-form)))
 218
 219 (defclass is-binary-failure-mixin (is-failure-mixin)
 220   ((actual-form :initarg :actual-form :accessor actual-form)
 221    (actual-value :initarg :actual-value :accessor actual-value)))
 222
 223 (defclass is-failure (test-failure)
 224   ((reason :initform nil :initarg :reason)))
 225
 226 (defmethod reason :around ((result is-failure))
 227   (or (slot-value result 'reason)
 228       (call-next-method)))
 229
 230 (defclass is-binary-failure (is-failure is-binary-failure-mixin)
 231   ())
 232
 233 (defmethod reason ((result is-binary-failure))
 234   (format nil
 235           "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
 236           (actual-form result)
 237           (actual-value result)
 238           (predicate result)
 239           (expected-value result)))
 240
 241 (defclass is-negated-binary-failure (is-failure is-binary-failure-mixin)
 242   ())
 243
 244 (defmethod reason ((result is-binary-failure))
 245   (format nil
 246           "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2%to ~2&~S~2% (it should be)"
 247           (actual-form result)
 248           (actual-value result)
 249           (predicate result)
 250           (expected-value result)))
 251
 252 (defclass is-unary-failure (is-failure is-failure-mixin)
 253   ())
 254
 255 (defmethod reason ((result is-unary-failure))
 256   (format nil
 257           "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
 258           (expected-form result)
 259           (expected-value result)
 260           (predicate result)))
 261
 262 (defclass is-negated-unary-failure (is-failure is-failure-mixin)
 263   ())
 264
 265 (defmethod reason ((result is-negated-unary-failure))
 266   (format nil
 267           "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
 268           (expected-form result)
 269           (expected-value result)
 270           (predicate result)))
 271
 272 ;;;; *** Other checks
 273
 274 (defmacro is-every (predicate &body clauses)
 275   "Tests that all the elements of CLAUSES are equal, according to PREDICATE.
 276
 277 If every element of CLAUSES is a cons we assume the `first` of each
 278 element is the expected value, and the `second` of each element is the
 279 actual value and generate a call to `IS` accordingly.
 280
 281 If not every element of CLAUSES is a cons then we assume that each
 282 element is a value to pass to predicate (the 1 argument form of `IS`)"
 283   `(progn
 284      ,@(if (every #'consp clauses)
 285            (loop for (expected actual . reason) in clauses
 286                  collect `(is (,predicate ,expected ,actual) ,@reason))
 287            (progn
 288              (assert (evenp (list-length clauses)))
 289              (loop for (expr value) on clauses by #'cddr
 290                    collect `(is (,predicate ,expr ,value)))))))
 291
 292 (defmacro is-true (condition &rest reason-args)
 293   "Like IS this check generates a pass if CONDITION returns true
 294   and a failure if CONDITION returns false. Unlike IS this check
 295   does not inspect CONDITION to determine how to report the
 296   failure."
 297   `(if ,condition
 298        (add-result 'test-passed :test-expr ',condition)
 299        (process-failure
 300         (make-instance 'test-failure
 301                        :reason ,(if reason-args
 302                                     `(format nil ,@reason-args)
 303                                     `(format nil "~S did not return a true value" ',condition))
 304                        :test-expr ',condition))))
 305
 306 (defmacro is-false (condition &rest reason-args)
 307   "Generates a pass if CONDITION returns false, generates a
 308   failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
 309   not inspect CONDITION to determine what reason to give it case
 310   of test failure"
 311
 312   (with-gensyms (value)
 313     `(let ((,value ,condition))
 314        (if ,value
 315            (process-failure
 316             (make-instance 'test-failure
 317                            :reason ,(if reason-args
 318                                         `(format nil ,@reason-args)
 319                                         `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
 320                            :test-expr ',condition))
 321            (add-result 'test-passed :test-expr ',condition)))))
 322
 323 (defmacro signals (condition-spec
 324                    &body body)
 325   "Generates a pass if `BODY` signals a condition of type
 326 `CONDITION`. `BODY` is evaluated in a block named `NIL`, `CONDITION`
 327 is not evaluated."
 328   (let ((block-name (gensym)))
 329     (destructuring-bind (condition &optional reason-control reason-args)
 330         (ensure-list condition-spec)
 331       `(block ,block-name
 332          (handler-bind ((,condition (lambda (c)
 333                                       (declare (ignore c))
 334                                       ;; ok, body threw condition
 335                                       (add-result 'test-passed
 336                                                   :test-expr ',condition)
 337                                       (return-from ,block-name t))))
 338            (block nil
 339              ,@body))
 340          (process-failure
 341           (make-instance 'test-failure
 342                          :reason ,(if reason-control
 343                                       `(format nil ,reason-control ,@reason-args)
 344                                       `(format nil "Failed to signal a ~S" ',condition))
 345                          :test-expr ',condition))
 346          (return-from ,block-name nil)))))
 347
 348 (defmacro finishes (&body body)
 349   "Generates a pass if BODY executes to normal completion.
 350
 351 In other words if body signals a condition (which is then handled),
 352 return-froms or throws this test fails."
 353   `(let ((ok nil))
 354      (unwind-protect
 355           (progn
 356             ,@body
 357             (setf ok t))
 358        (if ok
 359            (add-result 'test-passed :test-expr ',body)
 360            (process-failure
 361             (make-instance 'test-failure
 362                            :reason (format nil "Test didn't finish")
 363                            :test-expr ',body))))))
 364
 365 (defmacro pass (&rest message-args)
 366   "Generate a PASS."
 367   `(add-result 'test-passed
 368                :test-expr ',message-args
 369                ,@(when message-args
 370                        `(:reason (format nil ,@message-args)))))
 371
 372 (defmacro fail (&rest message-args)
 373   "Generate a FAIL."
 374   `(process-failure
 375     (make-instance 'test-failure
 376                    :test-expr ',message-args
 377                    ,@(when message-args
 378                        `(:reason (format nil ,@message-args))))))
 379
 380 (defmacro skip (&rest message-args)
 381   "Generates a SKIP result."
 382   `(progn
 383      (format *test-dribble* "s")
 384      (add-result 'test-skipped :reason (format nil ,@message-args))))
 385
 386 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 387 ;; All rights reserved.
 388 ;;
 389 ;; Redistribution and use in source and binary forms, with or without
 390 ;; modification, are permitted provided that the following conditions are
 391 ;; met:
 392 ;;
 393 ;;  - Redistributions of source code must retain the above copyright
 394 ;;    notice, this list of conditions and the following disclaimer.
 395 ;;
 396 ;;  - Redistributions in binary form must reproduce the above copyright
 397 ;;    notice, this list of conditions and the following disclaimer in the
 398 ;;    documentation and/or other materials provided with the distribution.
 399 ;;
 400 ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
 401 ;;    of its contributors may be used to endorse or promote products
 402 ;;    derived from this software without specific prior written permission.
 403 ;;
 404 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 405 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 406 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 407 ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
 408 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 409 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 410 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 411 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 412 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 413 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 414 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE