X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=cdf57fdd8d003daf4c8e607b268f16d7671eabb9;hb=325262d82eb9620b042e4c2bad38eb5dd47c03ef;hp=8d5f99fa971e2cc6b02f1cbbbc6328b63afdf63a;hpb=7f0c63da7fc25ef601cf03c430c3f8d735e7ef29;p=fiveam.git diff --git a/src/check.lisp b/src/check.lisp index 8d5f99f..cdf57fd 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -111,9 +111,8 @@ when appropiate.")) "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 @@ -122,35 +121,70 @@ TEST: (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) @@ -165,24 +199,17 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." (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 @@ -202,13 +229,16 @@ If the value is a (values a b * d *) form then the elements at * are not compare failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does not inspect CONDITION to determine what reason to give it case of test failure" - `(if ,condition - (process-failure - :reason ,(if reason-args - `(format nil ,@reason-args) - `(format nil "~S returned a true value" ',condition)) - :test-expr ',condition) - (add-result 'test-passed :test-expr ',condition))) + + (with-unique-names (value) + `(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) + (add-result 'test-passed :test-expr ',condition))))) (defmacro signals (condition-spec &body body)