X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=cecc267ec5befec4c210e66ef0f9724646fe9e6e;hb=2f4561b2f18b405c4dbb0d8326d5de60c4d54d73;hp=eba0adf9b9941c4eb6ee0b52e15d27b6105d4781;hpb=287c9bb8435332a4cb5f07fd4ef08c6a76c3499f;p=fiveam.git diff --git a/src/check.lisp b/src/check.lisp index eba0adf..cecc267 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -1,6 +1,6 @@ -;; -*- lisp -*- +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- -(in-package :it.bese.FiveAM) +(in-package :it.bese.fiveam) ;;;; * Checks @@ -29,13 +29,21 @@ ;;;; ** Types of test results -;;;; Every check produces a result object. +;;;; Every check produces a result object. (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-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) () @@ -45,6 +53,30 @@ (: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) + ((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 (failure c)) + (reason (failure c)))))) + +(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) () (:documentation "Class for unsuccessful checks.")) @@ -74,65 +106,188 @@ 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* ".")) + (test-passed (format *test-dribble* ".")) (unexpected-test-failure (format *test-dribble* "X")) - (test-failure (format *test-dribble* "f")) - (test-skipped (format *test-dribble* "s"))) + (test-failure (format *test-dribble* "f")) + (test-skipped (format *test-dribble* "s"))) (push result result-list)))) ;;;; ** The check operators ;;;; *** 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. 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 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 preducse 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) - `(if ,test - (add-result 'test-passed) - (add-result 'test-failure - :reason ,(if (null reason-args) - (list-match-case test - ((not (?predicate ?expected ?actual)) - `(format nil "~S was ~S to ~S" ,?actual ',?predicate ,?expected)) - ((not (?satisfies ?value)) - `(format nil "~S satisfied ~S" ,?value ',?satisfies)) - ((?predicate ?expected ?actual) - `(format nil "~S was not ~S to ~S" ,?actual ',?predicate ,?expected)) - ((?satisfies ?value) - `(format nil "~S did not satisfy ~S" ,?value ',?satisfies)) - (t - `(is-true ,test ,@reason-args))) - `(format nil ,@reason-args))))) + (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." +(defmacro is-every (predicate &body clauses) + "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 - (format *test-dribble* "s") - (add-result 'test-skipped :reason (format nil ,@reason)))) + ,@(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 @@ -140,72 +295,104 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." does not inspect CONDITION to determine how to report the failure." `(if ,condition - (add-result 'test-passed) - (add-result 'test-failure :reason ,(if reason-args - `(format nil ,@reason-args) - `(format nil "~S did not return a true value" ',condition))))) + (add-result 'test-passed :test-expr ',condition) + (process-failure + (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 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 - (add-result 'test-failure :reason ,(if reason-args - `(format nil ,@reason-args) - `(format nil "~S returned a true value" ',condition))) - (add-result 'test-passed))) - -(defmacro signals (condition &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." + + (with-gensyms (value) + `(let ((,value ,condition)) + (if ,value + (process-failure + (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." (let ((block-name (gensym))) - `(block ,block-name - (handler-bind ((,condition (lambda (c) - (declare (ignore c)) - ;; ok, body threw condition - (add-result 'test-passed) - (return-from ,block-name t)))) - (block nil - ,@body - (add-result 'test-failure :reason (format nil "Failed to signal a ~S" ',condition)) - (return-from ,block-name nil)))))) + (destructuring-bind (condition &optional reason-control reason-args) + (ensure-list condition-spec) + `(block ,block-name + (handler-bind ((,condition (lambda (c) + (declare (ignore c)) + ;; ok, body threw condition + (add-result 'test-passed + :test-expr ',condition) + (return-from ,block-name t)))) + (block nil + ,@body)) + (process-failure + (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 - ,@body - (setf ok t)) + (progn + ,@body + (setf ok t)) (if ok - (add-result 'test-passed) - (add-result 'test-failure - :reason (format nil "Test didn't finish")))))) + (add-result 'test-passed :test-expr ',body) + (process-failure + (make-instance 'test-failure + :reason (format nil "Test didn't finish") + :test-expr ',body)))))) (defmacro pass (&rest message-args) - "Simply generate a PASS." - `(add-result 'test-passed ,@(when message-args - `(:reason (format nil ,@message-args))))) + "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." - `(add-result 'test-failure ,@(when message-args - `(:reason (format nil ,@message-args))))) + "Generate a FAIL." + `(process-failure + (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. -;; +;; All rights reserved. +;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: -;; +;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. -;; +;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. @@ -213,7 +400,7 @@ fails." ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. -;; +;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR