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 (define-condition check-failure (error)
  50   ((reason :accessor reason :initarg :reason :initform "no reason given")
  51    (test-case :accessor test-case :initarg :test-case)
  52    (test-expr :accessor test-expr :initarg :test-expr))
  53   (:documentation "Signaled when a check fails.")
  54   (:report  (lambda (c stream)
  55               (format stream "The following check failed: ~S~%~A."
  56                       (test-expr c)
  57                       (reason c)))))
  58
  59 (defmacro process-failure (&rest args)
  60   `(progn
  61     (with-simple-restart (ignore-failure "Continue the test run.")
  62       (error 'check-failure ,@args))
  63     (add-result 'test-failure ,@args)))
  64
  65 (defclass test-failure (test-result)
  66   ()
  67   (:documentation "Class for unsuccessful checks."))
  68
  69 (defgeneric test-failure-p (object)
  70   (:method ((o t)) nil)
  71   (:method ((o test-failure)) t))
  72
  73 (defclass unexpected-test-failure (test-failure)
  74   ((actual-condition :accessor actual-condition :initarg :condition))
  75   (:documentation "Represents the result of a test which neither
  76 passed nor failed, but signaled an error we couldn't deal
  77 with.
  78
  79 Note: This is very different than a SIGNALS check which instead
  80 creates a TEST-PASSED or TEST-FAILURE object."))
  81
  82 (defclass test-skipped (test-result)
  83   ()
  84   (:documentation "A test which was not run. Usually this is due
  85 to unsatisfied dependencies, but users can decide to skip test
  86 when appropiate."))
  87
  88 (defgeneric test-skipped-p (object)
  89   (:method ((o t)) nil)
  90   (:method ((o test-skipped)) t))
  91
  92 (defun add-result (result-type &rest make-instance-args)
  93   "Create a TEST-RESULT object of type RESULT-TYPE passing it the
  94   initialize args MAKE-INSTANCE-ARGS and adds the resulting
  95   object to the list of test results."
  96   (with-run-state (result-list current-test)
  97     (let ((result (apply #'make-instance result-type
  98                          (append make-instance-args (list :test-case current-test)))))
  99       (etypecase result
 100         (test-passed  (format *test-dribble* "."))
 101         (unexpected-test-failure (format *test-dribble* "X"))
 102         (test-failure (format *test-dribble* "f"))
 103         (test-skipped (format *test-dribble* "s")))
 104       (push result result-list))))
 105
 106 ;;;; ** The check operators
 107
 108 ;;;; *** The IS check
 109
 110 (defmacro is (test &rest reason-args)
 111   "The DWIM checking operator.
 112
 113 If TEST returns a true value a test-passed result is generated,
 114 otherwise a test-failure result is generated and the reason,
 115 unless REASON-ARGS is provided, is generated based on the form of
 116 TEST:
 117
 118  (predicate expected actual) - Means that we want to check
 119  whether, according to PREDICATE, the ACTUAL value is
 120  in fact what we EXPECTED.
 121
 122  (predicate value) - Means that we want to ensure that VALUE
 123  satisfies PREDICATE.
 124
 125 Wrapping the TEST form in a NOT simply preducse a negated reason string."
 126   (assert (listp test)
 127           (test)
 128           "Argument to IS must be a list, not ~S" test)
 129   (let (bindings effective-test default-reason-args)
 130     (with-unique-names (e a v)
 131       (list-match-case test
 132         ((not (?predicate ?expected ?actual))
 133          (setf bindings (list (list e ?expected)
 134                               (list a ?actual))
 135                effective-test `(not (,?predicate ,e ,a))
 136                default-reason-args (list "~S was ~S to ~S" a `',?predicate e)))
 137         ((not (?satisfies ?value))
 138          (setf bindings (list (list v ?value))
 139                effective-test `(not (,?satisfies ,v))
 140                default-reason-args (list  "~S satisfied ~S" v `',?satisfies)))
 141         ((?predicate ?expected ?actual)
 142          (setf bindings (list (list e ?expected)
 143                               (list a ?actual))
 144                effective-test `(,?predicate ,e ,a)
 145                default-reason-args (list "~S was not ~S to ~S" a `',?predicate e)))
 146         ((?satisfies ?value)
 147          (setf bindings (list (list v ?value))
 148                effective-test `(,?satisfies ,v)
 149                default-reason-args (list "~S did not satisfy ~S" v `',?satisfies)))
 150         (?_
 151          (setf bindings '()
 152                effective-test test
 153                default-reason-args (list "No reason supplied"))))
 154       `(let ,bindings
 155          (if ,effective-test
 156              (add-result 'test-passed :test-expr ',test)
 157              (process-failure :reason (format nil ,@(or reason-args default-reason-args))
 158                               :test-expr ',test))))))
 159
 160 ;;;; *** Other checks
 161
 162 (defmacro skip (&rest reason)
 163   "Generates a TEST-SKIPPED result."
 164   `(progn
 165      (format *test-dribble* "s")
 166      (add-result 'test-skipped :reason (format nil ,@reason))))
 167
 168 (defmacro is-equal (&rest args)
 169   "Generates (is (equal (multiple-value-list ,expr) (multiple-value-list ,value))) for each pair of elements.
 170 If the value is a (values a b * d *) form then the elements at * are not compared."
 171   (with-unique-names (expr-result)
 172     `(progn
 173       ,@(loop for (expr value) on args by #'cddr
 174               do (assert (and expr value))
 175               if (and (consp value)
 176                       (eq (car value) 'values))
 177               collect `(let ((,expr-result (multiple-value-list ,expr)))
 178                         ,@(loop for cell = (rest (copy-list value)) then (cdr cell)
 179                                 for i from 0
 180                                 while cell
 181                                 when (eq (car cell) '*)
 182                                 collect `(setf (elt ,expr-result ,i) nil)
 183                                 and do (setf (car cell) nil))
 184                         (is (equal ,expr-result (multiple-value-list ,value))))
 185               else collect `(is (equal ,expr ,value))))))
 186
 187 (defmacro is-string= (&rest args)
 188   "Generates (is (string= ,expr ,value)) for each pair of elements."
 189   `(progn
 190     ,@(loop for (expr value) on args by #'cddr
 191             do (assert (and expr value))
 192             collect `(is (string= ,expr ,value)))))
 193
 194 (defmacro is-true (condition &rest reason-args)
 195   "Like IS this check generates a pass if CONDITION returns true
 196   and a failure if CONDITION returns false. Unlike IS this check
 197   does not inspect CONDITION to determine how to report the
 198   failure."
 199   `(if ,condition
 200     (add-result 'test-passed :test-expr ',condition)
 201     (process-failure
 202      :reason ,(if reason-args
 203                   `(format nil ,@reason-args)
 204                   `(format nil "~S did not return a true value" ',condition))
 205      :test-expr ',condition)))
 206
 207 (defmacro is-false (condition &rest reason-args)
 208   "Generates a pass if CONDITION returns false, generates a
 209   failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
 210   not inspect CONDITION to determine what reason to give it case
 211   of test failure"
 212   `(if ,condition
 213     (process-failure
 214      :reason ,(if reason-args
 215                   `(format nil ,@reason-args)
 216                   `(format nil "~S returned a true value" ',condition))
 217      :test-expr ',condition)
 218     (add-result 'test-passed :test-expr ',condition)))
 219
 220 (defmacro signals (condition-spec
 221                    &body body)
 222   "Generates a pass if BODY signals a condition of type
 223 CONDITION. BODY is evaluated in a block named NIL, CONDITION is
 224 not evaluated."
 225   (let ((block-name (gensym)))
 226     (destructuring-bind (condition &optional reason-control reason-args)
 227         (ensure-list condition-spec)
 228       `(block ,block-name
 229          (handler-bind ((,condition (lambda (c)
 230                                       (declare (ignore c))
 231                                       ;; ok, body threw condition
 232                                       (add-result 'test-passed
 233                                                   :test-expr ',condition)
 234                                       (return-from ,block-name t))))
 235            (block nil
 236              ,@body))
 237          (process-failure
 238           :reason ,(if reason-control
 239                        `(format nil ,reason-control ,@reason-args)
 240                        `(format nil "Failed to signal a ~S" ',condition))
 241           :test-expr ',condition)
 242          (return-from ,block-name nil)))))
 243
 244 (defmacro finishes (&body body)
 245   "Generates a pass if BODY executes to normal completion. In
 246 other words if body does signal, return-from or throw this test
 247 fails."
 248   `(let ((ok nil))
 249      (unwind-protect
 250          (progn
 251            ,@body
 252            (setf ok t))
 253        (if ok
 254            (add-result 'test-passed :test-expr ',body)
 255            (process-failure
 256             :reason (format nil "Test didn't finish")
 257             :test-expr ',body)))))
 258
 259 (defmacro pass (&rest message-args)
 260   "Simply generate a PASS."
 261   `(add-result 'test-passed
 262                :test-expr ',message-args
 263                ,@(when message-args
 264                        `(:reason (format nil ,@message-args)))))
 265
 266 (defmacro fail (&rest message-args)
 267   "Simply generate a FAIL."
 268   `(process-failure
 269     :test-expr ',message-args
 270     ,@(when message-args
 271             `(:reason (format nil ,@message-args)))))
 272
 273 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 274 ;; All rights reserved.
 275 ;;
 276 ;; Redistribution and use in source and binary forms, with or without
 277 ;; modification, are permitted provided that the following conditions are
 278 ;; met:
 279 ;;
 280 ;;  - Redistributions of source code must retain the above copyright
 281 ;;    notice, this list of conditions and the following disclaimer.
 282 ;;
 283 ;;  - Redistributions in binary form must reproduce the above copyright
 284 ;;    notice, this list of conditions and the following disclaimer in the
 285 ;;    documentation and/or other materials provided with the distribution.
 286 ;;
 287 ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
 288 ;;    of its contributors may be used to endorse or promote products
 289 ;;    derived from this software without specific prior written permission.
 290 ;;
 291 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 292 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 293 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 294 ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
 295 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 296 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 297 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 298 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 299 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 300 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 301 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE