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