1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 (in-package :it.bese.fiveam)
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.
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.
18 (defvar *test-dribble* t)
20 (defmacro with-*test-dribble* (stream &body body)
21 `(let ((*test-dribble* ,stream))
22 (declare (special *test-dribble*))
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (def-special-environment run-state ()
30 ;;;; ** Types of test results
32 ;;;; Every check produces a result object.
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
39 :initform (with-run-state (current-test)
41 (:documentation "All checking macros will generate an object of
44 (defgeneric test-result-p (object)
45 (:method ((o test-result)) t)
46 (:method ((o t)) nil))
48 (defclass test-passed (test-result)
50 (:documentation "Class for successful checks."))
52 (defgeneric test-passed-p (object)
54 (:method ((o test-passed)) t))
56 ;; if a condition could inhert from a class we could avoid duplicating
57 ;; these slot definitions...
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
64 :initform (with-run-state (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))))))
72 (defun process-failure (failure-object)
73 (restartable-check-failure failure-object)
74 (add-result failure-object))
76 (defun restartable-check-failure (failure)
77 (with-simple-restart (ignore-failure "Continue the test run.")
78 (error 'check-failure :failure failure)))
80 (defclass test-failure (test-result)
82 (:documentation "Class for unsuccessful checks."))
84 (defgeneric test-failure-p (object)
86 (:method ((o test-failure)) t))
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
94 Note: This is very different than a SIGNALS check which instead
95 creates a TEST-PASSED or TEST-FAILURE object."))
97 (defclass test-skipped (test-result)
99 (:documentation "A test which was not run. Usually this is due
100 to unsatisfied dependencies, but users can decide to skip test
103 (defgeneric test-skipped-p (object)
104 (:method ((o t)) nil)
105 (:method ((o test-skipped)) t))
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.
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)
117 (apply #'make-instance result-type make-instance-args))))
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))))
125 ;;;; ** The check operators
127 ;;;; *** The IS check
129 (defun parse-dwim-is-arguments (form)
130 (destructuring-bind (test &optional reason-string &rest reason-args)
132 (let ((reason-form (if reason-string
133 `(:reason (format nil ,reason-string ,@reason-args))
135 (expected-value (gensym))
136 (actual-value (gensym)))
137 (flet ((make-failure-instance (type &key predicate expected actual condition)
138 (values `(make-instance ',type
140 :predicate ',predicate
143 `(:expected-form ',expected :expected-value ,expected-value))
145 `(:actual-form ',actual :actual-value ,actual-value)))
146 (append (when expected
147 `((,expected-value ,expected)))
149 `((,actual-value ,actual))))
151 (list-match-case test
152 ((not (?predicate ?expected ?actual))
154 (make-failure-instance 'is-negated-binary-failure
155 :predicate ?predicate
159 :condition `(not (,?predicate ,expected-value ,actual-value))))
161 ((not (?predicate ?expected))
163 (make-failure-instance 'is-negated-unary-failure
164 :predicate ?predicate
166 :condition `(not (,?predicate ,expected-value))))
168 ((?predicate ?expected ?actual)
170 (make-failure-instance 'is-binary-failure
171 :predicate ?predicate
174 :condition `(,?predicate ,expected-value ,actual-value)))
175 ((?predicate ?expected)
177 (make-failure-instance 'is-unary-failure
178 :predicate ?predicate
180 :condition `(,?predicate ,expected-value)))
182 (values `(make-instance 'test-failure ,@reason-form)
186 (defmacro is (test &rest reason-args)
187 "The DWIM checking operator.
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:
193 `(predicate expected actual)`::
195 Means that we want to check whether, according to PREDICATE, the
196 ACTUAL value is in fact what we EXPECTED.
198 `(predicate value)`::
200 Means that we want to ensure that VALUE satisfies PREDICATE.
202 Wrapping the TEST form in a NOT simply produces a negated reason
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))
211 (add-result 'test-passed :test-expr ',test)
212 (process-failure ,make-failure-form)))))
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)))
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)))
223 (defclass is-failure (test-failure)
224 ((reason :initform nil :initarg :reason)))
226 (defmethod reason :around ((result is-failure))
227 (or (slot-value result 'reason)
230 (defclass is-binary-failure (is-failure is-binary-failure-mixin)
233 (defmethod reason ((result is-binary-failure))
235 "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
237 (actual-value result)
239 (expected-value result)))
241 (defclass is-negated-binary-failure (is-failure is-binary-failure-mixin)
244 (defmethod reason ((result is-binary-failure))
246 "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2%to ~2&~S~2% (it should be)"
248 (actual-value result)
250 (expected-value result)))
252 (defclass is-unary-failure (is-failure is-failure-mixin)
255 (defmethod reason ((result is-unary-failure))
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)
262 (defclass is-negated-unary-failure (is-failure is-failure-mixin)
265 (defmethod reason ((result is-negated-unary-failure))
267 "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
268 (expected-form result)
269 (expected-value result)
272 ;;;; *** Other checks
274 (defmacro is-every (predicate &body clauses)
275 "Tests that all the elements of CLAUSES are equal, according to PREDICATE.
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.
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`)"
284 ,@(if (every #'consp clauses)
285 (loop for (expected actual . reason) in clauses
286 collect `(is (,predicate ,expected ,actual) ,@reason))
288 (assert (evenp (list-length clauses)))
289 (loop for (expr value) on clauses by #'cddr
290 collect `(is (,predicate ,expr ,value)))))))
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
298 (add-result 'test-passed :test-expr ',condition)
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))))
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
312 (with-gensyms (value)
313 `(let ((,value ,condition))
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)))))
323 (defmacro signals (condition-spec
325 "Generates a pass if `BODY` signals a condition of type
326 `CONDITION`. `BODY` is evaluated in a block named `NIL`, `CONDITION`
328 (let ((block-name (gensym)))
329 (destructuring-bind (condition &optional reason-control reason-args)
330 (ensure-list condition-spec)
332 (handler-bind ((,condition (lambda (c)
334 ;; ok, body threw condition
335 (add-result 'test-passed
336 :test-expr ',condition)
337 (return-from ,block-name t))))
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)))))
348 (defmacro finishes (&body body)
349 "Generates a pass if BODY executes to normal completion.
351 In other words if body signals a condition (which is then handled),
352 return-froms or throws this test fails."
359 (add-result 'test-passed :test-expr ',body)
361 (make-instance 'test-failure
362 :reason (format nil "Test didn't finish")
363 :test-expr ',body))))))
365 (defmacro pass (&rest message-args)
367 `(add-result 'test-passed
368 :test-expr ',message-args
370 `(:reason (format nil ,@message-args)))))
372 (defmacro fail (&rest message-args)
375 (make-instance 'test-failure
376 :test-expr ',message-args
378 `(:reason (format nil ,@message-args))))))
380 (defmacro skip (&rest message-args)
381 "Generates a SKIP result."
383 (format *test-dribble* "s")
384 (add-result 'test-skipped :reason (format nil ,@message-args))))
386 ;; Copyright (c) 2002-2003, Edward Marco Baringer
387 ;; All rights reserved.
389 ;; Redistribution and use in source and binary forms, with or without
390 ;; modification, are permitted provided that the following conditions are
393 ;; - Redistributions of source code must retain the above copyright
394 ;; notice, this list of conditions and the following disclaimer.
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.
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.
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