From 7159a111b28fa88af41967e195b78c1571059d7a Mon Sep 17 00:00:00 2001 From: colin Date: Sun, 4 Feb 2024 10:25:31 -0800 Subject: Add: automatic test suite construction --- examples/examples.lisp | 3 +- src/standard-hooks.lisp | 31 ++++++++++++-- src/testiere.lisp | 107 +++++++++++++++++++++++++++++++++++++----------- 3 files changed, 114 insertions(+), 27 deletions(-) diff --git a/examples/examples.lisp b/examples/examples.lisp index 4088d32..c9f8a07 100644 --- a/examples/examples.lisp +++ b/examples/examples.lisp @@ -7,7 +7,8 @@ (in-package :testiere.examples) ;;; Turn Testiere On. -(testiere:on) +(eval-when (:compile-toplevel :load-toplevel :execute) + (testiere:on)) ;;; BASIC TESTS diff --git a/src/standard-hooks.lisp b/src/standard-hooks.lisp index 86725ca..0548865 100644 --- a/src/standard-hooks.lisp +++ b/src/standard-hooks.lisp @@ -2,6 +2,29 @@ (in-package :testiere) +;;; COMMON FUNCTIONS + +(defun standard-extractor (orig-form) + "A somewhat naive default test form extractor. Returns two values, +orig-form without test forms included, and a collection of test forms." + (loop + :for form :in orig-form + :when (and (listp form) + (eq :tests (first form))) + :append (cdr form) :into tests-forms + :else + :collect form :into defun-form + :finally (return (values defun-form tests-forms)))) + +(defun standard-form-key (form) + "The first is a list (MACRO NAME) that uniquely identifies the form +form which tests are being defined. NAME's package is the suite to +which the tests of FORM will be be added. + +This form key function is sutable for Common Lisp definition macros." + (list (first form) (second form))) + + ;;; DEFSTRUCT ;; (defstruct moo @@ -11,6 +34,7 @@ (register-hook 'cl:defstruct + #'standard-form-key #'standard-extractor) ;;; DEFCLASS @@ -30,6 +54,7 @@ (register-hook 'cl:defclass #'standard-extractor + #'standard-form-key #'defclass-restarts-expander) ;;; DEFMETHOD @@ -40,7 +65,7 @@ ;; (:tests ...) ;; (flah (moo-blah x) (barbar y))) -(register-hook 'cl:defmethod #'standard-extractor) +(register-hook 'cl:defmethod #'standard-extractor #'standard-form-key) ;;; DEFUN @@ -57,7 +82,7 @@ () (fmakunbound ',name))))) -(register-hook 'cl:defun #'standard-extractor #'defun-restarts-expander) +(register-hook 'cl:defun #'standard-extractor #'standard-form-key #'defun-restarts-expander) ;;; DEFTYPE @@ -67,4 +92,4 @@ ;; (:tests ...) ;; `(or number null)) -(register-hook 'cl:deftype #'standard-extractor) +(register-hook 'cl:deftype #'standard-extractor #'standard-form-key) diff --git a/src/testiere.lisp b/src/testiere.lisp index 6ccf5ae..c7c7e73 100644 --- a/src/testiere.lisp +++ b/src/testiere.lisp @@ -4,15 +4,87 @@ (defstruct testiere-hook ;; a function that extracts '(:tests ...), returning them and the modified form - (extractor nil) + (extractor (error "required")) ;; a function that accepts a form and returns a list of restart handlers - (restarts-expander nil)) + (restarts-expander nil) + ;; a function that accepts an sexpr and returns a list of symbols + ;; (MACRO NAME . MORE) where MACRO names the macro being expanded, + ;; NAME is some kind of unique name in the package where the form is + ;; being defined, and MORE is a possibly empty list of arbitrary + ;; symbols. These lists should uniquely name, a particular + ;; invocation of a macro up to comparison by EQUAL. + (form-key-fn (error "required"))) (defvar *testiere-hooks* (make-hash-table) "Registry of macro functions and testiere-hook") -(defun register-hook (macro extractor &optional restarts-expander) +(defvar *suite-dict* + (make-hash-table :test #'eq) + "PACKAGE -> {FORM-KEY -> TEST-LAMBDA}") + +(defun add-test-to-package-suite (form-key test-thunk) + (let ((suite (or (gethash (symbol-package (second form-key)) *suite-dict*) + (setf (gethash (symbol-package (second form-key)) *suite-dict*) + (make-hash-table :test #'equal))))) + (setf (gethash form-key suite) test-thunk))) + +(define-condition testiere-error (error) + ((reason :initarg :reason))) + +(define-condition test-failure-error (testiere-error) + ((test :initarg :test))) + +(defun failed (test reason-fmt &rest fmt-args) + "Signal a TEST-FAILURE-ERROR. TEST is a deignator for the +test. REASON-FMT is a format string and FMT-ARGS are arguments to that +string, to be processed by CL:FORMAT." + (error 'test-failure-error + :test test + :reason (apply #'format nil reason-fmt fmt-args))) + +(defun report (fmt-string &rest args) + (apply #'format *standard-output* fmt-string args)) + +(defun run-test (key thunk) + (report " Testing ~{~a~^ ~}~65,1t~:[[FAIL]~;[pass]~]~%" + key + (restart-case (funcall thunk) + (report-and-continue-tests () nil)))) + +(defun report-and-continue-tests (e) + (declare (ignore e)) + (invoke-restart 'report-and-continue-tests)) + +(defun run-package-suite (package &optional required) + (let ((suite (gethash (find-package package) *suite-dict*))) + (cond ((not suite) + (if required + (error 'testiere-error + :reason (format nil "No test suite found for package ~s" + (package-name package))) + (report "~%No tests found for package ~s~%" (package-name package)))) + (t + (report "~%Running tests for package ~s~%" (package-name package)) + (loop :for form-key :being :the :hash-keys :of suite + :using (:hash-value test-thunk) + :do (run-test form-key test-thunk)))))) + +(defun run-suites (packages &key (automatic-continue nil) (require-all t)) + "PACKAGES is a list of pacakge designators. Attempts to run test +suites named in PACKAGES. + +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)))) + +(defun register-hook (macro extractor form-key-fn &optional restarts-expander) "Register a new hook for use with testiere. MACRO is a symbol naming a macro-function @@ -29,25 +101,28 @@ restarts to try when tests fail." (setf (gethash (macro-function macro) *testiere-hooks*) (make-testiere-hook :extractor extractor + :form-key-fn form-key-fn :restarts-expander restarts-expander))) (defvar *cached-macroexpand-hook* nil) (defun testiere-hook (expander form environment) - (let* ((hook - (gethash expander *testiere-hooks*))) + (let* ((hook (gethash expander *testiere-hooks*))) (cond (hook - (with-slots (extractor restarts-expander) hook + (with-slots (extractor restarts-expander form-key-fn) hook (multiple-value-bind (form test-forms) (funcall extractor form) (if test-forms - (let ((tests (expand-test-forms test-forms))) + (let ((key (funcall form-key-fn form)) + (tests (expand-test-forms test-forms))) (if restarts-expander `(prog1 ,(funcall expander form environment) (restart-case (progn ,@tests) - ,@(funcall restarts-expander form))) + ,@(funcall restarts-expander form)) + (add-test-to-package-suite ',key (lambda () ,@tests t))) `(prog1 ,(funcall expander form environment) - ,@tests))) + ,@tests + (add-test-to-package-suite ',key (lambda () ,@tests t))))) (funcall expander form environment))))) (t (funcall expander form environment))))) @@ -148,20 +223,6 @@ restarts to try when tests fail." (when ,orig-generic (setf (fdefinition ',name) ',orig-generic)))))) - -(defun standard-extractor (orig-form) - "A somewhat naive default test form extractor. Returns two values, -orig-form without test forms included, and a collection of test forms." - (loop - :for form :in orig-form - :when (and (listp form) - (eq :tests (first form))) - :append (cdr form) :into tests-forms - :else - :collect form :into defun-form - :finally (return (values defun-form tests-forms)))) - - (defun on () (unless (member :testiere *features*) (pushnew :testiere *features*) -- cgit v1.2.3