X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=cecc267ec5befec4c210e66ef0f9724646fe9e6e;hb=8a32d7c6d3c1b7a43127731585f8a4bf9518b171;hp=cac6d0a8fbdb169abb6fcf423e696f88b8c230cc;hpb=e460c9c5ac4842a5b02be37557767774bcbf27fe;p=fiveam.git diff --git a/src/check.lisp b/src/check.lisp index cac6d0a..cecc267 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -33,10 +33,17 @@ (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.")) +type TEST-RESULT.")) + +(defgeneric test-result-p (object) + (:method ((o test-result)) t) + (:method ((o t)) nil)) (defclass test-passed (test-result) () @@ -46,21 +53,29 @@ (: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) () @@ -91,11 +106,15 @@ when appropiate.")) (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))))) +initialize args MAKE-INSTANCE-ARGS and adds the resulting object to +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")) @@ -107,6 +126,63 @@ when appropiate.")) ;;;; *** 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. @@ -114,92 +190,96 @@ If TEST returns a true value a test-passed result is generated, 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." +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 -(defmacro skip (&rest reason) - "Generates a TEST-SKIPPED result." - `(progn - (format *test-dribble* "s") - (add-result 'test-skipped :reason (format nil ,@reason)))) - (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." + "Tests that all the elements of CLAUSES are equal, according to PREDICATE. + +If every element of CLAUSES is a cons we assume the `first` of each +element is the expected value, and the `second` of each element is the +actual value and generate a call to `IS` accordingly. + +If not every element of CLAUSES is a cons then we assume that each +element is a value to pass to predicate (the 1 argument form of `IS`)" `(progn ,@(if (every #'consp clauses) (loop for (expected actual . reason) in clauses @@ -217,10 +297,11 @@ REASON-ARGS is provided, is generated based on the form of TEST: `(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 @@ -232,17 +313,18 @@ REASON-ARGS is provided, is generated based on the form of TEST: `(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 &body body) - "Generates a pass if BODY signals a condition of type -CONDITION. BODY is evaluated in a block named NIL, CONDITION is -not evaluated." + "Generates a pass if `BODY` signals a condition of type +`CONDITION`. `BODY` is evaluated in a block named `NIL`, `CONDITION` +is not evaluated." (let ((block-name (gensym))) (destructuring-bind (condition &optional reason-control reason-args) (ensure-list condition-spec) @@ -256,16 +338,18 @@ not evaluated." (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) - "Generates a pass if BODY executes to normal completion. In -other words if body does signal, return-from or throw this test -fails." + "Generates a pass if BODY executes to normal completion. + +In other words if body signals a condition (which is then handled), +return-froms or throws this test fails." `(let ((ok nil)) (unwind-protect (progn @@ -274,22 +358,30 @@ fails." (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) - "Simply generate a PASS." + "Generate a PASS." `(add-result 'test-passed :test-expr ',message-args ,@(when message-args `(:reason (format nil ,@message-args))))) (defmacro fail (&rest message-args) - "Simply generate a FAIL." + "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." + `(progn + (format *test-dribble* "s") + (add-result 'test-skipped :reason (format nil ,@message-args)))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved.