"The DWIM checking operator.
If TEST returns a true value a test-passed result is generated,
-otherwise a test-failure result is generated and the reason,
-unless REASON-ARGS is provided, is generated based on the form of
-TEST:
+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
(predicate value) - Means that we want to ensure that VALUE
satisfies PREDICATE.
-Wrapping the TEST form in a NOT simply preducse a negated reason string."
+ Wrapping the TEST form in a NOT simply preducse 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-unique-names (e a v)
- (list-match-case test
- ((not (?predicate ?expected ?actual))
- (setf bindings (list (list e ?expected)
- (list a ?actual))
- effective-test `(not (,?predicate ,e ,a))
- default-reason-args (list "~S was ~S to ~S" a `',?predicate e)))
- ((not (?satisfies ?value))
- (setf bindings (list (list v ?value))
- effective-test `(not (,?satisfies ,v))
- default-reason-args (list "~S satisfied ~S" v `',?satisfies)))
- ((?predicate ?expected ?actual)
- (setf bindings (list (list e ?expected)
- (list a ?actual))
- effective-test `(,?predicate ,e ,a)
- default-reason-args (list "~S was not ~S to ~S" a `',?predicate e)))
- ((?satisfies ?value)
- (setf bindings (list (list v ?value))
- effective-test `(,?satisfies ,v)
- default-reason-args (list "~S did not satisfy ~S" v `',?satisfies)))
- (?_
- (setf bindings '()
- effective-test test
- default-reason-args (list "No reason supplied"))))
+ (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.")
+ (let ((tmp expected))
+ (setf expected actual
+ actual tmp)))
+ (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)
(format *test-dribble* "s")
(add-result 'test-skipped :reason (format nil ,@reason))))
-(defmacro is-equal (&rest args)
- "Generates (is (equal (multiple-value-list ,expr) (multiple-value-list ,value))) for each pair of elements.
-If the value is a (values a b * d *) form then the elements at * are not compared."
- (with-unique-names (expr-result)
- `(progn
- ,@(loop for (expr value) on args by #'cddr
- do (assert (and expr value))
- if (and (consp value)
- (eq (car value) 'values))
- collect `(let ((,expr-result (multiple-value-list ,expr)))
- ,@(loop for cell = (rest (copy-list value)) then (cdr cell)
- for i from 0
- while cell
- when (eq (car cell) '*)
- collect `(setf (elt ,expr-result ,i) nil)
- and do (setf (car cell) nil))
- (is (equal ,expr-result (multiple-value-list ,value))))
- else collect `(is (equal ,expr ,value))))))
+(defmacro is-every (predicate &body clauses)
+ "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+ for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
+ `(progn
+ ,@(if (every #'consp clauses)
+ (loop for (expected actual . reason) in clauses
+ collect `(is (,predicate ,expected ,actual) ,@reason))
+ (progn
+ (assert (evenp (list-length clauses)))
+ (loop for (expr value) on clauses by #'cddr
+ collect `(is (,predicate ,expr ,value)))))))
(defmacro is-true (condition &rest reason-args)
"Like IS this check generates a pass if CONDITION returns true