X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=9b7ad636e5794a9bdb027d71376676b6f8f2461e;hb=f3f10e21f646bddb8c1817e496be199afc65b648;hp=2e91193fc98166556bea4363e758fa9fa826a81d;hpb=e8bbac684406062746dc0f31bf9bf1124120e0bf;p=fiveam.git diff --git a/src/check.lisp b/src/check.lisp index 2e91193..9b7ad63 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,14 +29,14 @@ ;;;; ** 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)) (:documentation "All checking macros will generate an object of - type TEST-RESULT.")) +type TEST-RESULT.")) (defclass test-passed (test-result) () @@ -58,9 +58,9 @@ (defmacro process-failure (&rest args) `(progn - (with-simple-restart (ignore-failure "Continue the test run.") - (error 'check-failure ,@args)) - (add-result 'test-failure ,@args))) + (with-simple-restart (ignore-failure "Continue the test run.") + (error 'check-failure ,@args)) + (add-result 'test-failure ,@args))) (defclass test-failure (test-result) () @@ -91,16 +91,16 @@ 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." +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))))) (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 @@ -111,23 +111,22 @@ 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 - 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) - Means that we want to ensure that VALUE - satisfies PREDICATE. +\(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 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-unique-names (e a v) + (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) @@ -135,9 +134,7 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." (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))) + (rotatef expected actual)) (let ((setf-forms)) (if (and (consp expected) (eq (car expected) 'values)) @@ -154,29 +151,37 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." (setf bindings (list (list e expected) (list a actual)))) (setf effective-test `(progn - ,@setf-forms - ,(if negatedp - `(not (,predicate ,e ,a)) - `(,predicate ,e ,a))))))) + ,@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 was ~S to ~S" a `',?predicate e))) + (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 "~S satisfied ~S" v `',?satisfies))) + 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 "~S was not ~S to ~S" a `',?predicate e))) + (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 "~S did not satisfy ~S" v `',?satisfies))) + 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 "No reason supplied"))))) + default-reason-args (list "~2&~S~2% was NIL." `',test))))) `(let ,bindings (if ,effective-test (add-result 'test-passed :test-expr ',test) @@ -195,13 +200,13 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." "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 &rest 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))))))) + ,@(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 @@ -209,25 +214,28 @@ 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 :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))) + (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))) (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 - (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-gensyms (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) @@ -241,7 +249,7 @@ not evaluated." (handler-bind ((,condition (lambda (c) (declare (ignore c)) ;; ok, body threw condition - (add-result 'test-passed + (add-result 'test-passed :test-expr ',condition) (return-from ,block-name t)))) (block nil @@ -259,18 +267,18 @@ other words if body does signal, return-from or throw this test fails." `(let ((ok nil)) (unwind-protect - (progn - ,@body - (setf ok t)) + (progn + ,@body + (setf ok t)) (if ok - (add-result 'test-passed :test-expr ',body) + (add-result 'test-passed :test-expr ',body) (process-failure :reason (format nil "Test didn't finish") :test-expr ',body))))) (defmacro pass (&rest message-args) "Simply generate a PASS." - `(add-result 'test-passed + `(add-result 'test-passed :test-expr ',message-args ,@(when message-args `(:reason (format nil ,@message-args))))) @@ -283,15 +291,15 @@ fails." `(: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. @@ -299,7 +307,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