From c978852f91901252c7b8c5d5a1fd31918d374932 Mon Sep 17 00:00:00 2001 From: colin 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