From 98b0b68a31a93a2c2a7e588133a6462142f290fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?= Date: Thu, 11 Apr 2024 11:09:06 +0200 Subject: [PATCH] Break into the debugger upon error --- doc/org.melusina.confidence.texinfo | 88 +++++++-- src/package.lisp | 3 + src/testcase.lisp | 273 ++++++++++++++++++---------- testsuite/testcase.lisp | 19 +- 4 files changed, 267 insertions(+), 116 deletions(-) diff --git a/doc/org.melusina.confidence.texinfo b/doc/org.melusina.confidence.texinfo index 1d2a907..54284aa 100644 --- a/doc/org.melusina.confidence.texinfo +++ b/doc/org.melusina.confidence.texinfo @@ -11,7 +11,7 @@ @end direntry @copying -Confidence software and associated documentation is distributed +@b{Confidence} software and associated documentation is distributed under the terms of the MIT License. @quotation @@ -112,7 +112,7 @@ function. A special kind of function, but a function. * String Assertions:: * List Assertions:: * Vector Assertions:: -* Floating Numbers Assertions:: +* Floating Number Assertions:: @end menu @node Define Assertions, Basic Assertions, Assertions, Assertions @@ -169,13 +169,13 @@ function. A special kind of function, but a function. @include include/fun-org.melusina.confidence-assert-set-equal.texinfo @include include/fun-org.melusina.confidence-assert-subsetp.texinfo -@node Vector Assertions, Floating Numbers Assertions, List Assertions, Assertions +@node Vector Assertions, Floating Number Assertions, List Assertions, Assertions @section Vector Assertions @include include/fun-org.melusina.confidence-assert-vector-equal.texinfo -@node Floating Numbers Assertions, Testcases, Vector Assertions, Assertions -@section Floating Numbers Assertions +@node Floating Number Assertions, Testcases, Vector Assertions, Assertions +@section Floating Number Assertions @include include/var-org.melusina.confidence-star-double-float-precision-star.texinfo @include include/var-org.melusina.confidence-star-single-float-precision-star.texinfo @@ -184,24 +184,80 @@ function. A special kind of function, but a function. @include include/fun-org.melusina.confidence-assert-float-is-definitely-greater-than.texinfo @include include/fun-org.melusina.confidence-assert-float-is-definitely-less-than.texinfo -@node Testcases, Specialities, Floating Numbers Assertions, Top +@node Testcases, Specialities, Floating Number Assertions, Top @chapter Testcases -The @i{define-testcase} macro allows to define testcases, which are -functions specially crafted to run tests. There are two differences -with regular functions. The first difference is that calls to -testcases and assertions in a testcase are instrumented, so that a -global success report is produced. The second difference is that when -a testcase is run as a toplevel form in a batch environment (not at a -REPL) the testcase prints a summary of results when done and exits the -program with a success status reflecting the testcase result. +The @i{define-testcase} macro allows to define @i{testcases}, which +are functions specially crafted to run @i{assertions} and build a +testsuite. There are three important differences with regular +functions. The first one is that calls to assertions in a testcase are +instrumented, so that a global success report is produced. The second +difference is that when a testcase is run as a toplevel form the +testcase prints a summary of results when done. The third difference +is that some specific @i{restarts} are available in this context. + +@section Define a Testcase + +@include include/macro-org.melusina.confidence-define-testcase.texinfo +@include include/class-org.melusina.confidence-testcase-outcome.texinfo + +@section Describe Failed Assertions + +When an assertion fails, it prints a description on the +@code{*error-output*}, unless the following configuration variable +is set to @code{nil}. + +@include include/var-org.melusina.confidence-star-testcase-describe-failed-assertions-star.texinfo + + +@section Run Testcases in Batch + +The @b{Confidence} system normally runs test cases in batch, which is +appropriate when it is used for fully automated tests, in continuous +integration and delivery pipelines. + +@section Run Testcases Interactively + +The @b{Confidence} system can be configured so that when a testcase +meets an unexpected condition, such as an error or an unsatisfied +assertion, the debugger is invoked. To do so, modify the variable +@code{*testcase-break-into-the-debugger-on-errors*} either directly +or with the function @code{testcase-break-into-the-debugger-on-errors}. + +@include include/var-org.melusina.confidence-star-testcase-break-into-the-debugger-on-errors-star.texinfo +@include include/fun-org.melusina.confidence-testcase-break-into-the-debugger-on-errors.texinfo + +When this configuration is active, the following @i{restarts} are +available in the debugger: + +@itemize +@item +@b{ASSERTION-RETRY} Which retries to evaluate the arguments of the +failing assertion and the assertion itself. +@item +@b{TESTCASE-RETRY} Which retries the current testcase. +@item +@b{TESTCASE-CONTINUE} Which registers an error and continues the +current testcase. +@item +@b{TESTCASE-RETURN} Which registers an error and immediately returns +from the current testcase. +@item +@b{TESTCASE-STEP-UP} Which registers an error and continue the current +testcase without breaking into the debugger. +@item +@b{TESTCASE-SCROLL} Which registers an error and continue the current +testcase and other testcases higher in the call stack without breaking +into the debugger. +@end itemize + +@section Add Testcases to the Export List of a Package Defined testcases are automatically exported, which makes it easy to call them from the REPL, the testsuite tool or to add them to generated documentation. -@include include/var-org.melusina.confidence-star-testcase-interactive-p-star.texinfo -@include include/macro-org.melusina.confidence-define-testcase.texinfo +XXXX @node Specialities, , Testcases, Top @chapter Specialities diff --git a/src/package.lisp b/src/package.lisp index 2e2b41d..e23962b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -23,6 +23,7 @@ #:testcase-success #:testcase-failure #:testcase-condition + #:testcase-argument-values ;; Testcases #:assertion-path #:assertion-name @@ -40,6 +41,8 @@ #:*testsuite-id* #:*testsuite-last-result* #:list-testcases + #:testcase-break-into-the-debugger-on-errors + #:*testcase-break-into-the-debugger-on-errors* ;; Assertions #:define-assertion #:list-assertions diff --git a/src/testcase.lisp b/src/testcase.lisp index caa9a6e..389da28 100644 --- a/src/testcase.lisp +++ b/src/testcase.lisp @@ -28,7 +28,10 @@ When the flag is a generalised boolean, a failed assertion can be retried. The default value of the parameter is based on the :SWANK and :SLYNK features.") -(defparameter *testcase-describe-failed-assertions* t +(defvar *testcase-break-into-the-debugger-on-errors* nil + "Flag controlling whether an unexpected error should open the debugger.") + +(defvar *testcase-describe-failed-assertions* *error-output* "Flag controlling whether a testcase should describe failed assertions or not.") (defparameter *testcase-path* nil @@ -46,6 +49,10 @@ Usually TESTSUITE but commonly used values are ACCEPTANCE, INTEGRATION, PREFLIGH (defvar *last-testsuite-result* nil "The results of the last testsuite that ran.") +(defun testcase-break-into-the-debugger-on-errors (&optional (breakp t)) + "Set the flag controlling wether an unexpected error should open the debugger." + (setf *testcase-break-into-the-debugger-on-errors* breakp)) + ;;;; ;;;; TESTSUITE-IDENTIFICATION @@ -312,60 +319,94 @@ instead of returning normally.")) (defun instrument-assertion-1 (&key name form type argument-names argument-lambdas assertion-lambda) "Supervise the execution of ARGUMENTS-LAMBDA and ASSERTION-LAMBDA." - (labels ((evaluation-strategy-1 (argument-condition argument-values) - (when argument-condition - (signal - 'assertion-condition - :path *testcase-path* - :name name - :argument-names argument-names - :argument-values argument-values - :form form - :type type - :condition (first argument-condition)) - (return-from evaluation-strategy-1)) - (multiple-value-bind (success-p description) - (handler-case (funcall assertion-lambda argument-values) - (serious-condition (unexpected-condition) - (signal - 'assertion-condition - :path *testcase-path* - :name name - :argument-names argument-names - :argument-values argument-values - :form form - :type type - :condition unexpected-condition) - (return-from evaluation-strategy-1))) - (cond - ((not success-p) - (signal 'assertion-failure + (labels ((evaluate-assertion-lambda (argument-values argument-conditions) + (labels ((signal-or-break (condition) + (if (eq *testcase-break-into-the-debugger-on-errors* t) + (restart-case (error condition) + (assertion-retry () + :report "Retry to evaluate this assertion and its arguments." + (throw :retry-assertion t)) + (testcase-continue () + :report + (lambda (stream) + (let ((testcase-name + (testcase-name *current-testcase-outcome*))) + (format stream "Register an error and continue testcase ~A." testcase-name))) + (signal condition))) + (signal condition))) + (signal-argument-condition (condition) + (signal-or-break + (make-condition + 'assertion-condition + :path *testcase-path* + :name name + :argument-names argument-names + :argument-values argument-values + :form form + :type type + :condition condition))) + (signal-unexpected-condition (condition) + (signal-or-break + (make-condition + 'assertion-condition :path *testcase-path* :name name :argument-names argument-names :argument-values argument-values :form form :type type - :description description)) - (t - (signal 'assertion-success + :condition condition))) + (signal-failure (description) + (signal-or-break + (make-condition + 'assertion-failure :path *testcase-path* :name name :argument-names argument-names :argument-values argument-values :form form - :type type))))) - (evaluation-strategy (argument-values) - (evaluation-strategy-1 - (member-if (lambda (object) (typep object 'condition)) argument-values) - argument-values)) - (supervise-evaluation-1 (argument-lambda) - (handler-case (funcall argument-lambda) + :type type + :description description))) + (signal-success () + (signal + (make-condition + 'assertion-success + :path *testcase-path* + :name name + :argument-names argument-names + :argument-values argument-values + :form form + :type type)))) + (when argument-conditions + (signal-argument-condition (first argument-conditions)) + (return-from evaluate-assertion-lambda)) + (multiple-value-bind (success-p description) + (handler-case (funcall assertion-lambda argument-values) + (serious-condition (unexpected-condition) + (signal-unexpected-condition unexpected-condition) + (return-from evaluate-assertion-lambda))) + (cond + ((not success-p) + (signal-failure description)) + (t + (signal-success))) + (values nil)))) + (evaluate-argument-lambda (argument-lambda) + (handler-case (values nil (funcall argument-lambda)) (t (unexpected-condition) - unexpected-condition))) - (supervise-evaluation (argument-lambdas) - (evaluation-strategy (mapcar #'supervise-evaluation-1 argument-lambdas)))) - (supervise-evaluation argument-lambdas))) + (values t unexpected-condition)))) + (evaluate-assertion () + (loop :with argument-condition-p :and argument-value + :for argument-lambda :in argument-lambdas + :do (setf (values argument-condition-p argument-value) + (evaluate-argument-lambda argument-lambda)) + :collect argument-value :into argument-values + :when argument-condition-p + :collect argument-value :into argument-conditions + :finally (evaluate-assertion-lambda argument-values argument-conditions))) + (evaluate-assertion-with-retry () + (loop :while (catch :retry-assertion (evaluate-assertion))))) + (evaluate-assertion-with-retry))) (defmacro instrument-assertion (form) "Instrument the execution of the assertion FORM and return ASSERTION evaluation details. @@ -478,66 +519,110 @@ symbol of this function." :name testcase-name)) (*testcase-path* (cons testcase-name *testcase-path*))) - (flet ((install-signal-handlers-and-run-testcase () - (handler-bind - ((assertion-success - (lambda (condition) - (declare (ignore condition)) - (with-slots (total success) *current-testcase-outcome* - (incf total) - (incf success)))) - (assertion-failure - (lambda (condition) - (when *testcase-describe-failed-assertions* - (format *testcase-describe-failed-assertions* "~&Assertion Failure~%~A" condition)) - (with-slots (total failure) *current-testcase-outcome* - (incf total) - (incf failure)))) - (assertion-condition - (lambda (condition) - (when *testcase-describe-failed-assertions* - (format *testcase-describe-failed-assertions* "~&Assertion Condition~%~A" condition)) - (with-slots (total condition) *current-testcase-outcome* - (incf total) - (incf condition)))) - (testcase-end - (lambda (condition) - (with-slots ((current-total total) - (current-success success) - (current-failure failure) - (current-condition condition)) - *current-testcase-outcome* - (with-slots ((testcase-total total) - (testcase-success success) - (testcase-failure failure) - (testcase-condition condition)) - (testcase-outcome condition) - (incf current-total testcase-total) - (incf current-success testcase-success) - (incf current-failure testcase-failure) - (incf current-condition testcase-condition)))))) + (labels ((current-testcase-p (condition) + (declare (ignore condition)) + (eq this-testcase-outcome *current-testcase-outcome*)) + (run-testcase-with-restarts () (let ((*current-testcase-outcome* this-testcase-outcome)) - (funcall testcase-body) - (setf *last-testsuite-outcome* *current-testcase-outcome*)) - (describe *last-testsuite-outcome*) - (terpri))) - (just-run-testcase () - (let ((*current-testcase-outcome* this-testcase-outcome)) - (funcall testcase-body)) - (signal 'testcase-end :outcome this-testcase-outcome))) + (restart-case (funcall testcase-body) + (testcase-retry () + :report + (lambda (stream) + (let ((testcase-name + (testcase-name *current-testcase-outcome*))) + (format stream "Retry testcase ~A." testcase-name))) + :test + (lambda (condition) (current-testcase-p condition)) + (throw :testcase-retry t)) + (testcase-return () + :report + (lambda (stream) + (let ((testcase-name + (testcase-name *current-testcase-outcome*))) + (format stream "Return from testcase ~A." testcase-name))) + :test + (lambda (condition) (current-testcase-p condition)) + (return-from run-testcase-with-restarts)) + (testcase-step-up () + :report + (lambda (stream) + (let ((testcase-name + (testcase-name *current-testcase-outcome*))) + (format stream "Step up from testcase ~A." testcase-name))) + :test + (lambda (condition) (current-testcase-p condition)) + (setf *testcase-break-into-the-debugger-on-errors* :testcase-step-up)) + (testcase-scroll () + :report "Scroll through remaining errors." + :test + (lambda (condition) (current-testcase-p condition)) + (setf *testcase-break-into-the-debugger-on-errors* :testcase-scroll)))) + (when (eq *testcase-break-into-the-debugger-on-errors* :testcase-step-up) + (setf *testcase-break-into-the-debugger-on-errors* t)) + (values nil)) + (run-testcase-with-retry () + (loop :while (catch :testcase-retry (run-testcase-with-restarts)))) + (install-signal-handlers-and-run-testcase-with-retry () + (handler-bind + ((assertion-success + (lambda (condition) + (declare (ignore condition)) + (with-slots (total success) *current-testcase-outcome* + (incf total) + (incf success)))) + (assertion-failure + (lambda (condition) + (when *testcase-describe-failed-assertions* + (format *testcase-describe-failed-assertions* "~&Assertion Failure~%~A" condition)) + (with-slots (total failure) *current-testcase-outcome* + (incf total) + (incf failure)))) + (assertion-condition + (lambda (condition) + (when *testcase-describe-failed-assertions* + (format *testcase-describe-failed-assertions* "~&Assertion Condition~%~A" condition)) + (with-slots (total condition) *current-testcase-outcome* + (incf total) + (incf condition)))) + (testcase-end + (lambda (condition) + (with-slots ((current-total total) + (current-success success) + (current-failure failure) + (current-condition condition)) + *current-testcase-outcome* + (with-slots ((testcase-total total) + (testcase-success success) + (testcase-failure failure) + (testcase-condition condition)) + (testcase-outcome condition) + (incf current-total testcase-total) + (incf current-success testcase-success) + (incf current-failure testcase-failure) + (incf current-condition testcase-condition)))))) + (case *testcase-break-into-the-debugger-on-errors* + ((:testcase-scroll :testcase-step-up) + (setf *testcase-break-into-the-debugger-on-errors* t))) + (run-testcase-with-retry) + (when (eq *testcase-break-into-the-debugger-on-errors* :testcase-scroll) + (setf *testcase-break-into-the-debugger-on-errors* t)) + (setf *last-testsuite-outcome* this-testcase-outcome) + (describe *last-testsuite-outcome*) + (terpri)))) (if testsuite-p - (install-signal-handlers-and-run-testcase) - (just-run-testcase)) + (install-signal-handlers-and-run-testcase-with-retry) + (progn + (run-testcase-with-retry) + (signal 'testcase-end :outcome this-testcase-outcome))) (values this-testcase-outcome)))) (defmacro define-testcase (testcase-name testcase-args &body body) "Define a test case function TESTCASE-NAME, accepting TESTCASE-ARGS with BODY. - The BODY is examined and assertions spotted in it are wrapped with extra code installing restarts and aggregating outcomes for assertions and nested testcases.. -The return value of a testcase is a OUTCOME, holding a precise description of test that -ran and their outcomes." +The return value of a testcase is a TESTCASE-OUTCOME, holding a precise description +of tests that ran and their outcomes." (set-testcase-properties testcase-name) (multiple-value-bind (remaining-forms declarations doc-string) (alexandria:parse-body body :documentation t) diff --git a/testsuite/testcase.lisp b/testsuite/testcase.lisp index d96d068..b1bd531 100644 --- a/testsuite/testcase.lisp +++ b/testsuite/testcase.lisp @@ -36,14 +36,21 @@ (assert-t t)) (define-testcase a-failing-argument-testsuite () - (assert-t nil) - (assert-eq 0 (+ 1 1)) - (assert-t (error "An intentional error"))) + (assert-t t) + (assert-eq 0 0) + (assert-t (error "An intentional error occuring when evaluating assertion arguments."))) (define-testcase a-failing-testcase-testsuite () - (error "An intentional error") - (assert-t nil) - (assert-eq 0 (+ 1 1))) + (assert-t t) + (assert-eq 0 0) + (error "An intentional error occuring in the testsuite.")) + +(define-testcase a-compound-failing-testsuite () + (a-successful-testsuite) + (a-successful-testsuite) + (a-failing-argument-testsuite) + (a-failing-argument-testsuite) + (a-failing-testcase-testsuite)) (define-testcase a-successful-testsuite-with-function-calls () (funcall 'a-successful-testsuite)