aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2024-02-04 11:02:32 -0800
committercolin <colin@cicadas.surf>2024-02-04 11:02:32 -0800
commitc978852f91901252c7b8c5d5a1fd31918d374932 (patch)
treeaba259631bf7d547868e02578774c785cd096773 /src
parent7159a111b28fa88af41967e195b78c1571059d7a (diff)
test suites; readme
Diffstat (limited to 'src')
-rw-r--r--src/package.lisp1
-rw-r--r--src/testiere.lisp91
2 files changed, 52 insertions, 40 deletions
diff --git a/src/package.lisp b/src/package.lisp
index 9594019..bbeb7d4 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -7,6 +7,7 @@
#:on
#:off
#:register-hook
+ #:run-suites
;; legacy
#:defun/t
#:with-stub
diff --git a/src/testiere.lisp b/src/testiere.lisp
index c7c7e73..acd3460 100644
--- a/src/testiere.lisp
+++ b/src/testiere.lisp
@@ -70,19 +70,24 @@ string, to be processed by CL:FORMAT."
:using (:hash-value test-thunk)
:do (run-test form-key test-thunk))))))
-(defun run-suites (packages &key (automatic-continue nil) (require-all t))
+(defun run-suites (&key packages (automatic-continue nil) (require-all t))
"PACKAGES is a list of pacakge designators. Attempts to run test
-suites named in PACKAGES.
+suites named in PACKAGES. If PACKAGES is NIL, then all known test
+suites are run.
If AUTOMATIC-CONTINUE is T then all TEST-FAILURE-ERRORs will be
handled by printing a test failure before continuing with the suite.
If REQUIRE-ALL is T then an error will be signalled if no suite exists
for one of the members of PACKAGES."
- (if automatic-continue
- (handler-bind ((test-failure-error #'report-and-continue-tests))
- (loop :for p :in packages :do (run-package-suite p require-all)))
- (loop :for p :in packages :do (run-package-suite p require-all))))
+ (let ((packages
+ (if packages packages
+ (loop :for p :being :the :hash-keys :of *suite-dict*
+ :collect p))))
+ (if automatic-continue
+ (handler-bind ((test-failure-error #'report-and-continue-tests))
+ (loop :for p :in packages :do (run-package-suite p require-all)))
+ (loop :for p :in packages :do (run-package-suite p require-all)))))
(defun register-hook (macro extractor form-key-fn &optional restarts-expander)
"Register a new hook for use with testiere.
@@ -113,8 +118,8 @@ restarts to try when tests fail."
(with-slots (extractor restarts-expander form-key-fn) hook
(multiple-value-bind (form test-forms) (funcall extractor form)
(if test-forms
- (let ((key (funcall form-key-fn form))
- (tests (expand-test-forms test-forms)))
+ (let* ((key (funcall form-key-fn form))
+ (tests (expand-test-forms key test-forms)))
(if restarts-expander
`(prog1 ,(funcall expander form environment)
(restart-case (progn ,@tests)
@@ -127,57 +132,63 @@ restarts to try when tests fail."
(t
(funcall expander form environment)))))
-(defun expand-test-forms (forms)
- (mapcar #'expand-test-form forms))
+(defun expand-test-forms (key forms)
+ (loop :for form :in forms :collect (expand-test-form key form)))
-(defun expand-test-form (form)
+(defun expand-test-form (key form)
(ematch form
((list :fails failing-form)
- `(assert (handler-case (progn ,failing-form nil)
+ `(unless (handler-case (progn ,failing-form nil)
(error () t))
- ()
- "~s should have signalled an error but did not."
- ',failing-form))
+ (failed ',key "~s should have signalled an error but did not."
+ ',failing-form)))
((list :signals condition signalling-form)
- `(assert (handler-case (progn ,signalling-form)
+ `(unless (handler-case (progn ,signalling-form)
(,condition () t)
(condition () nil))
- ()
- "~s should have signalled ~s but did not."
- ',signalling-form
- ',condition))
+ (failed ',key "~s should have signalled ~s but did not."
+ ',signalling-form
+ ',condition)))
((list* :funcall function args)
- `(funcall ,function ,@args))
+ (let ((err (gensym "ERROR-")))
+ `(handler-case (funcall ,function ,@args)
+ (error (,err) (failed ',key "~s signalled an error: ~s"
+ '(funcall ,function ,@args)
+ ,err)))))
((list* :with-defuns (list* stubs) body)
- (expand-defun-stubs stubs body))
+ (expand-defun-stubs key stubs body))
((list* :with-generic name (list* method-stubs) body)
- (expand-generic-stub name method-stubs body))
+ (expand-generic-stub key name method-stubs body))
((list* :let (list* bindings) body)
- `(let ,bindings ,@(expand-test-forms body)))
+ `(let ,bindings ,@(expand-test-forms key body)))
((list :do form)
- form)
+ (let ((err (gensym "ERROR-")))
+ `(handler-case ,form
+ (error (,err)
+ (failed ',key "Side effecting code ~s signalled an error ~s"
+ ',form ,err)))))
((list :is form)
- `(assert ,form () "~s failed" ',form))
+ `(unless ,form
+ (failed ',key "~s returned NIL" ',form)))
((list comparator a b)
- (let ((a-result (gensym))
- (b-result (gensym))
- (pred-result (gensym)))
- `(let* ((,a-result ,a)
- (,b-result ,b)
- (,pred-result (,comparator ,a-result ,b-result)))
- (assert ,pred-result () "~s failed with ~s"
- ',form
- (list ',comparator ,a-result ,b-result)))))))
-
-(defun expand-defun-stubs (defs body)
+ (let ((left (gensym "LEFT-"))
+ (right (gensym "RIGHT-"))
+ (pred-result (gensym "RESULT-")))
+ `(let* ((,left ,a)
+ (,right ,b)
+ (,pred-result (,comparator ,left ,right)))
+ (unless ,pred-result
+ (failed ',key "~s is NIL" ',form)))))))
+
+(defun expand-defun-stubs (key defs body)
(let* ((redef-names
(mapcar #'car defs))
@@ -204,10 +215,10 @@ restarts to try when tests fail."
`(let ((,defun-cache-var (list ,@defun-cache)))
(unwind-protect
(progn ,@defun-redefs
- ,@(expand-test-forms body))
+ ,@(expand-test-forms key body))
,@defun-restore))))
-(defun expand-generic-stub (name method-stubs body)
+(defun expand-generic-stub (key name method-stubs body)
(let* ((orig-generic
(gensym "DEFGENERIC-CACHE"))
@@ -219,7 +230,7 @@ restarts to try when tests fail."
(unwind-protect
(progn
,@method-defs
- ,@(expand-test-forms body))
+ ,@(expand-test-forms key body))
(when ,orig-generic
(setf (fdefinition ',name) ',orig-generic))))))