-;; -*- lisp -*-
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
-(in-package :it.bese.FiveAM)
+(in-package :it.bese.fiveam)
;;;; * Checks
;;;; ** 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)
(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)
(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))
(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 . 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-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)
(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