;;;; ** 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")
(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)
()
(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
"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)
(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 "~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 satisfied ~S" v `',?satisfies)))
+ 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 was not ~S to ~S" a `',?predicate e)))
+ (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 did not satisfy ~S" v `',?satisfies)))
+ 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 "No reason supplied")))))
+ default-reason-args (list "~S was NIL." `',test)))))
`(let ,bindings
(if ,effective-test
(add-result 'test-passed :test-expr ',test)
"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
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-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)
(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
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)))))
`(: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.
;; - 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
projects / fiveam.git / blobdiff