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