| (xref:OP_IS[`is`] (`PREDICATE` `EXPECTED` `ACTUAL`)) | check that, according to `PREDICATE` our `ACTUAL` is the same as our `EXPECTED`
| (xref:OP_IS[`is-true`] VALUE) | check that a value is non-NIL
| (xref:OP_RUN![`run!`] TEST-NAME) | run one (or more) tests and print the results
-| (xref:OP_RUN![`!`]) | rerun the most recently run test.
|================================
See the xref:API_REFERENCE[api] for details.
Lather, rinse, repeat:
--------------------------------
-CL-USER> (!)
+CL-USER> (run!)
..
Did 2 checks.
Pass: 2 (100%)
=== Creating Suites ===
-Suites are created in one of two ways: Either explicitly via the
-xref:OP_DEF-SUITE[`def-suite`] macro, or implicity via the
-xref:OP_DEF-SUITE-STAR-[`def-suite*`] and/or
-xref:OP_IN-SUITE-STAR-[`in-suite*`] macros:
-
Suites, very much like tests, have a name (which is globally unique)
which can be used to retrieve the suite (so that you can run it), and,
most of the time, suites are part of a suite (the exception being the
--------------------------------
(def-suite :my-project)
-(in-suite* :my-db-layer :in :my-project)
+(def-suite :my-db-layer :in :my-project)
+
+(in-suite :my-db-layer)
--------------------------------
[[THE_CURRENT_SUITE]]
FiveAM also has the concept of a current suite and everytime a test is
created it adds itself to the current suite's set of tests. The
-`IN-SUITE` and `IN-SUITE*` macros, in a similar fashion to
-`IN-PACKAGE`, change the current suite.
-
-Unless changed via `IN-SUITE` and `IN-SUITE*` the current suite is the
+`IN-SUITE` macro, in a similar fashion to `IN-PACKAGE`, changes the
+current suite. Unless changed via `IN-SUITE` the current suite is the
`T` suite.
Having a default current suite allows developers to ignore suites
Where `TEST-NAME` is either a test object (as returned by `get-test`)
or a symbol naming a single test or a test suite.
-=== Re-running Tests ===
-
-The `run!` function stores its arguments in a set of variables and,
-via the functions `!`, `!!` and `!!!` will rerun those named
-tests. Note that we're deliberatly talking about names, and not test
-objects, `!` will take the last argument passed to `run!` and call
-`run!` with that again, looking up the test again if the argument was
-a symbol.
-
-This ensures that `!` will always run the current definition of a
-test, even if the test has been redefined since the last time `run!`
-was called.
-
=== Running Tests at Test Definition Time ===
Often enough, especially when fixing regression bugs, we'll always
reasons you have to set this variable manually after having loaded
your test suite.
-[NOTE]
-Setting `*run-test-when-defined*` will cause `run!` to get called far
-more often than normal. `!` and `!!` and `!!!` don't know that they're
-getting called semi-automatically and will therefore tend to all
-reduce to the same test (which still isn't totally useless behaviour).
-
=== Debugging failures and errors ===
`*debug-on-error*`::
== Random Testing (QuickCheck) ==
-TODO.
+Sometimes it's hard to come up with edge cases for tests, or sometimes
+there are so many that it's hard to list them all one by one. Random
+testing is a way to tell the test suite how to generate input and how
+to test that certain conditions always hold. One issue when writing
+random tests is that you can't, usually, test for specific results,
+you have to test that certain relationships hold.
+
+For example, if we had a function which reverses a list, we could
+define a relationship like this:
+
+--------------------------------
+(equalp the-list (reverse (reverse the-list)))
+--------------------------------
+
+or
+
+--------------------------------
+(equalp (length the-list) (length (reverse the-list)))
+--------------------------------
-Every FiveAM test can be a random test, just use the for-all macro.
+Random tests are defined via `def-test`, but the random part is then
+wrapped in a xref:OP_FOR-ALL[`for-all`] macro which runs its body
+`*num-trials*` times with different inputs:
+
+--------------------------------
+(for-all ((the-list (gen-list :length (gen-integer :min 0 :max 37)
+ :elements (gen-integer :min -10 :max 10))))
+ (is (equalp a (reverse (reverse the-list))))
+ (is (= (length the-list) (length (reverse the-list)))))
+--------------------------------
== Fixtures ==
[[OP_IN-SUITE]]
[[OP_IN-SUITE-STAR-]]
-=== IN-SUITE / IN-SUITE* ===
+=== IN-SUITE ===
================================
----
include::docstrings/OP_IN-SUITE.txt[]
================================
-================================
-----
-(in-suite* NAME &key IN)
-----
-
-include::docstrings/OP_IN-SUITE-STAR-.txt[]
-================================
-
[[OP_IS]]
=== IS ===
include::docstrings/OP_RUN.txt[]
================================
-=== ! / !! / !!! ===
-
-================================
-----
-(!)
-----
-
-include::docstrings/OP_-EPOINT-.txt[]
-================================
-
-================================
-----
-(!!)
-----
-
-include::docstrings/OP_-EPOINT--EPOINT-.txt[]
-================================
-
-================================
-----
-(!!!)
-----
-
-include::docstrings/OP_-EPOINT--EPOINT--EPOINT-.txt[]
-================================
-
[[OP_DEF-FIXTURE]]
=== DEF-FIXTURE ===
(defclass test-result ()
((reason :accessor reason :initarg :reason :initform "no reason given")
- (test-case :accessor test-case :initarg :test-case)
- (test-expr :accessor test-expr :initarg :test-expr))
+ (test-expr :accessor test-expr :initarg :test-expr)
+ (test-case :accessor test-case
+ :initarg :test-case
+ :initform (with-run-state (current-test)
+ current-test)))
(:documentation "All checking macros will generate an object of
type TEST-RESULT."))
+(defgeneric test-result-p (object)
+ (:method ((o test-result)) t)
+ (:method ((o t)) nil))
+
(defclass test-passed (test-result)
()
(:documentation "Class for successful checks."))
(:method ((o t)) nil)
(:method ((o test-passed)) t))
+;; if a condition could inhert from a class we could avoid duplicating
+;; these slot definitions...
+
(define-condition check-failure (error)
- ((reason :accessor reason :initarg :reason :initform "no reason given")
- (test-case :accessor test-case :initarg :test-case)
- (test-expr :accessor test-expr :initarg :test-expr))
+ ((failure :accessor failure :initarg :failure)
+ (test-expr :accessor test-expr :initarg :test-expr)
+ (test-case :accessor test-case
+ :initarg :test-case
+ :initform (with-run-state (current-test)
+ current-test)))
(:documentation "Signaled when a check fails.")
(:report (lambda (c stream)
(format stream "The following check failed: ~S~%~A."
- (test-expr c)
- (reason c)))))
+ (test-expr (failure c))
+ (reason (failure c))))))
-(defmacro process-failure (&rest args)
- `(progn
- (with-simple-restart (ignore-failure "Continue the test run.")
- (error 'check-failure ,@args))
- (add-result 'test-failure ,@args)))
+(defun process-failure (failure-object)
+ (restartable-check-failure failure-object)
+ (add-result failure-object))
+
+(defun restartable-check-failure (failure)
+ (with-simple-restart (ignore-failure "Continue the test run.")
+ (error 'check-failure :failure failure)))
(defclass test-failure (test-result)
()
(defun add-result (result-type &rest make-instance-args)
"Create a TEST-RESULT object of type RESULT-TYPE passing it the
initialize args MAKE-INSTANCE-ARGS and adds the resulting object to
-the list of test results."
- (with-run-state (result-list current-test)
- (let ((result (apply #'make-instance result-type
- (append make-instance-args (list :test-case current-test)))))
+the list of test results.
+
+If RESULT-TYPE is already a TEST-RESULT object it is used as is and
+the MAKE-INSTANCE-ARGS are ignored."
+ (with-run-state (result-list)
+ (let ((result (if (test-result-p result-type)
+ result-type
+ (apply #'make-instance result-type make-instance-args))))
(etypecase result
(test-passed (format *test-dribble* "."))
(unexpected-test-failure (format *test-dribble* "X"))
;;;; *** The IS check
+(defun parse-dwim-is-arguments (form)
+ (destructuring-bind (test &optional reason-string &rest reason-args)
+ form
+ (let ((reason-form (if reason-string
+ `(:reason (format nil ,reason-string ,@reason-args))
+ nil))
+ (expected-value (gensym))
+ (actual-value (gensym)))
+ (flet ((make-failure-instance (type &key predicate expected actual condition)
+ (values `(make-instance ',type
+ ,@reason-form
+ :predicate ',predicate
+ :test-expr ',test
+ ,@(when expected
+ `(:expected-form ',expected :expected-value ,expected-value))
+ ,@(when actual
+ `(:actual-form ',actual :actual-value ,actual-value)))
+ (append (when expected
+ `((,expected-value ,expected)))
+ (when actual
+ `((,actual-value ,actual))))
+ condition)))
+ (list-match-case test
+ ((not (?predicate ?expected ?actual))
+
+ (make-failure-instance 'is-negated-binary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :actual ?actual
+
+ :condition `(not (,?predicate ,expected-value ,actual-value))))
+
+ ((not (?predicate ?expected))
+
+ (make-failure-instance 'is-negated-unary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :condition `(not (,?predicate ,expected-value))))
+
+ ((?predicate ?expected ?actual)
+
+ (make-failure-instance 'is-binary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :actual ?actual
+ :condition `(,?predicate ,expected-value ,actual-value)))
+ ((?predicate ?expected)
+
+ (make-failure-instance 'is-unary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :condition `(,?predicate ,expected-value)))
+ (_
+ (values `(make-instance 'test-failure ,@reason-form)
+ '()
+ test)))))))
+
(defmacro is (test &rest reason-args)
"The DWIM checking operator.
otherwise a test-failure result is generated. The reason, unless
REASON-ARGS is provided, is generated based on the form of TEST:
-\(predicate expected actual) - Means that we want to check whether,
-according to PREDICATE, the ACTUAL value is in fact what we EXPECTED.
+`(predicate expected actual)`::
+
+Means that we want to check whether, according to PREDICATE, the
+ACTUAL value is in fact what we EXPECTED.
+
+`(predicate value)`::
-\(predicate value) - Means that we want to ensure that VALUE satisfies
-PREDICATE.
+Means that we want to ensure that VALUE satisfies PREDICATE.
Wrapping the TEST form in a NOT simply produces a negated reason
string."
(assert (listp test)
(test)
"Argument to IS must be a list, not ~S" test)
- (let (bindings effective-test default-reason-args)
- (with-gensyms (e a v)
- (flet ((process-entry (predicate expected actual &optional negatedp)
- ;; make sure EXPECTED is holding the entry that starts with 'values
- (when (and (consp actual)
- (eq (car actual) 'values))
- (assert (not (and (consp expected)
- (eq (car expected) 'values))) ()
- "Both the expected and actual part is a values expression.")
- (rotatef expected actual))
- (let ((setf-forms))
- (if (and (consp expected)
- (eq (car expected) 'values))
- (progn
- (setf expected (copy-list expected))
- (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
- for i from 0
- while cell
- when (eq (car cell) '*)
- collect `(setf (elt ,a ,i) nil)
- and do (setf (car cell) nil)))
- (setf bindings (list (list e `(list ,@(rest expected)))
- (list a `(multiple-value-list ,actual)))))
- (setf bindings (list (list e expected)
- (list a actual))))
- (setf effective-test `(progn
- ,@setf-forms
- ,(if negatedp
- `(not (,predicate ,e ,a))
- `(,predicate ,e ,a)))))))
- (list-match-case test
- ((not (?predicate ?expected ?actual))
- (process-entry ?predicate ?expected ?actual t)
- (setf default-reason-args
- (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
- `',?actual a `',?predicate e)))
- ((not (?satisfies ?value))
- (setf bindings (list (list v ?value))
- effective-test `(not (,?satisfies ,v))
- default-reason-args
- (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
- `',?value v `',?satisfies)))
- ((?predicate ?expected ?actual)
- (process-entry ?predicate ?expected ?actual)
- (setf default-reason-args
- (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%."
- `',?actual a `',?predicate e)))
- ((?satisfies ?value)
- (setf bindings (list (list v ?value))
- effective-test `(,?satisfies ,v)
- default-reason-args
- (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
- `',?value v `',?satisfies)))
- (?_
- (setf bindings '()
- effective-test test
- default-reason-args (list "~2&~S~2% was NIL." `',test)))))
- `(let ,bindings
- (if ,effective-test
- (add-result 'test-passed :test-expr ',test)
- (process-failure :reason (format nil ,@(or reason-args default-reason-args))
- :test-expr ',test))))))
+ (multiple-value-bind (make-failure-form bindings predicate)
+ (parse-dwim-is-arguments (list* test reason-args))
+ `(let ,bindings
+ (if ,predicate
+ (add-result 'test-passed :test-expr ',test)
+ (process-failure ,make-failure-form)))))
+
+(defclass is-failure-mixin ()
+ ((predicate :initarg :predicate :accessor predicate)
+ (expected-value :initarg :expected-value :accessor expected-value)
+ (expected-form :initarg :expected-form :accessor expected-form)))
+
+(defclass is-binary-failure-mixin (is-failure-mixin)
+ ((actual-form :initarg :actual-form :accessor actual-form)
+ (actual-value :initarg :actual-value :accessor actual-value)))
+
+(defclass is-failure (test-failure)
+ ((reason :initform nil :initarg :reason)))
+
+(defmethod reason :around ((result is-failure))
+ (or (slot-value result 'reason)
+ (call-next-method)))
+
+(defclass is-binary-failure (is-failure is-binary-failure-mixin)
+ ())
+
+(defmethod reason ((result is-binary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
+ (actual-form result)
+ (actual-value result)
+ (predicate result)
+ (expected-value result)))
+
+(defclass is-negated-binary-failure (is-failure is-binary-failure-mixin)
+ ())
+
+(defmethod reason ((result is-binary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2%to ~2&~S~2% (it should be)"
+ (actual-form result)
+ (actual-value result)
+ (predicate result)
+ (expected-value result)))
+
+(defclass is-unary-failure (is-failure is-failure-mixin)
+ ())
+
+(defmethod reason ((result is-unary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
+ (expected-form result)
+ (expected-value result)
+ (predicate result)))
+
+(defclass is-negated-unary-failure (is-failure is-failure-mixin)
+ ())
+
+(defmethod reason ((result is-negated-unary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
+ (expected-form result)
+ (expected-value result)
+ (predicate result)))
;;;; *** Other checks
`(if ,condition
(add-result 'test-passed :test-expr ',condition)
(process-failure
- :reason ,(if reason-args
- `(format nil ,@reason-args)
- `(format nil "~S did not return a true value" ',condition))
- :test-expr ',condition)))
+ (make-instance 'test-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S did not return a true value" ',condition))
+ :test-expr ',condition))))
(defmacro is-false (condition &rest reason-args)
"Generates a pass if CONDITION returns false, generates a
`(let ((,value ,condition))
(if ,value
(process-failure
- :reason ,(if reason-args
- `(format nil ,@reason-args)
- `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
- :test-expr ',condition)
+ (make-instance 'test-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
+ :test-expr ',condition))
(add-result 'test-passed :test-expr ',condition)))))
(defmacro signals (condition-spec
(block nil
,@body))
(process-failure
- :reason ,(if reason-control
- `(format nil ,reason-control ,@reason-args)
- `(format nil "Failed to signal a ~S" ',condition))
- :test-expr ',condition)
+ (make-instance 'test-failure
+ :reason ,(if reason-control
+ `(format nil ,reason-control ,@reason-args)
+ `(format nil "Failed to signal a ~S" ',condition))
+ :test-expr ',condition))
(return-from ,block-name nil)))))
(defmacro finishes (&body body)
(if ok
(add-result 'test-passed :test-expr ',body)
(process-failure
- :reason (format nil "Test didn't finish")
- :test-expr ',body)))))
+ (make-instance 'test-failure
+ :reason (format nil "Test didn't finish")
+ :test-expr ',body))))))
(defmacro pass (&rest message-args)
"Generate a PASS."
(defmacro fail (&rest message-args)
"Generate a FAIL."
`(process-failure
- :test-expr ',message-args
- ,@(when message-args
- `(:reason (format nil ,@message-args)))))
+ (make-instance 'test-failure
+ :test-expr ',message-args
+ ,@(when message-args
+ `(:reason (format nil ,@message-args))))))
(defmacro skip (&rest message-args)
"Generates a SKIP result."
projects / fiveam.git / commitdiff