- (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 "~S evaluated to ~S, which is ~S to ~S (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 "~S evaluated to ~S, which satisfies ~S (it should not)"
- `',?value v `',?satisfies)))
- ((?predicate ?expected ?actual)
- (process-entry ?predicate ?expected ?actual)
- (setf default-reason-args
- (list "~S evaluated to ~S, which is not ~S to ~S."
- `',?actual a `',?predicate e)))
- ((?satisfies ?value)
- (setf bindings (list (list v ?value))
- effective-test `(,?satisfies ,v)
- default-reason-args
- (list "~S evaluated to ~S, which does not satisfy ~S"
- `',?value v `',?satisfies)))
- (?_
- (setf bindings '()
- effective-test test
- default-reason-args (list "~S 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)))