(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."