From c978852f91901252c7b8c5d5a1fd31918d374932 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sun, 4 Feb 2024 11:02:32 -0800
Subject: test suites; readme
---
README.org | 36 +++++++++++++++++++-
examples/examples.lisp | 1 +
src/package.lisp | 1 +
src/testiere.lisp | 91 ++++++++++++++++++++++++++++----------------------
4 files changed, 88 insertions(+), 41 deletions(-)
diff --git a/README.org b/README.org
index 3d6c449..657c4b9 100644
--- a/README.org
+++ b/README.org
@@ -20,7 +20,10 @@ This approach has several beneifts:
end up compiled into executable code unless ~testiere~ is "on"),
you get purposeful documentation of your code for free. Why read a
comment when there's a test!?
-
+4. **Automatic Test Suite Definition** Tests of definition forms are
+ automatically added to a test suite associated with the package of
+ the name being defined. These tests can be run using
+ ~testiere:run-suites~.
Out of the box, ~testiere~ supports testing of the following:
@@ -235,6 +238,37 @@ tests that aren't part of the package you're testing."
(:is (not (typep "foo" 'optional-int))))
'(or integer null))
#+end_src
+*** Running the suite
+
+The above also defines a test suite for the forms defined in the
+~:testiere.examples~ package.
+
+The ~RUN-SUITES~ function lets you run test suites associated with
+packages. The `:AUTOMATIC-CONTINUE` argument avoids dropping into the
+debugger, instead printing a test failure.
+
+If the ~:PACKAGES~ argument is empty, then all test suites known to
+Testiere are run.
+
+#+begin_src lisp
+
+(run-suites :packages '(:testiere.examples)
+ :automatic-continue t)
+
+#+end_src
+
+#+begin_example
+
+Running tests for package "TESTIERE.EXAMPLES"
+ Testing DEFUN ADD3 [pass]
+ Testing DEFUN ADD10 [pass]
+ Testing DEFUN INCREMENT-COUNT [pass]
+ Testing DEFUN COUNT-WORDS-IN-RESPONSE [pass]
+ Testing DEFCLASS POINT [pass]
+ Testing DEFTYPE OPTIONAL-INT [pass]
+
+#+end_example
+
** How does it work?
diff --git a/examples/examples.lisp b/examples/examples.lisp
index c9f8a07..bf59434 100644
--- a/examples/examples.lisp
+++ b/examples/examples.lisp
@@ -119,3 +119,4 @@ tests that aren't part of the package you're testing."
(:is (typep 10 'optional-int))
(:is (not (typep "foo" 'optional-int))))
'(or integer null))
+
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))))))
--
cgit v1.2.3