-;; -*- 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")
- (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)
()
(: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)
()
(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)`::
- (predicate value) - Means that we want to ensure that VALUE
- satisfies PREDICATE.
+Means that we want to check whether, according to PREDICATE, the
+ACTUAL value is in fact what we EXPECTED.
-Wrapping the TEST form in a NOT simply preducse a negated reason string."
+`(predicate value)`::
+
+Means that we want to ensure that VALUE satisfies PREDICATE.
+
+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)
- (list-match-case test
- ((not (?predicate ?expected ?actual))
- (setf bindings (list (list e ?expected)
- (list a ?actual))
- effective-test `(not (,?predicate ,e ,a))
- default-reason-args (list "~S was ~S to ~S" 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)))
- ((?predicate ?expected ?actual)
- (setf bindings (list (list e ?expected)
- (list a ?actual))
- effective-test `(,?predicate ,e ,a)
- default-reason-args (list "~S was not ~S to ~S" 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)))
- (_?
- (setf bindings '()
- effective-test test
- default-reason-args (list "No reason supplied."))))
- `(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."
+(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
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
+ (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
- (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
+ (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)
(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
- ,@body
- (process-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)))))))
+ ,@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 :test-expr ',body)
+ (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."
- `(add-result 'test-passed
+ "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.
-;;
+;; 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