From cc93cf0ba33cd87302296ff0dd74648eb51b0756 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?= Date: Fri, 12 Apr 2024 22:20:28 +0200 Subject: [PATCH] fixup! Break into the debugger upon error Work the restart strategy out --- src/testcase.lisp | 186 ++++++++++++++++++++++++---------------------- 1 file changed, 97 insertions(+), 89 deletions(-) diff --git a/src/testcase.lisp b/src/testcase.lisp index 3f1b883..3e4847a 100644 --- a/src/testcase.lisp +++ b/src/testcase.lisp @@ -319,89 +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." - (flet ((evaluate-assertion-lambda (argument-values argument-conditions) - (labels ((signal-or-break (condition) - (if *testcase-break-into-the-debugger-on-errors* - (restart-case (error condition) - (assertion-retry () - :report "Retry to evaluate this assertion and its arguments." - (error "Not implemented")) - (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 - :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 - :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)))))) - (evaluate-argument-lambda (argument-lambda) - (handler-case (values nil (funcall argument-lambda)) - (t (unexpected-condition) - (values t unexpected-condition))))) - (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)))) + (labels ((evaluate-assertion-lambda (argument-values argument-conditions) + (labels ((signal-or-break (condition) + (if *testcase-break-into-the-debugger-on-errors* + (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 + :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 + :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) + (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. @@ -528,7 +533,7 @@ symbol of this function." (format stream "Retry testcase ~A." testcase-name))) :test (lambda (condition) (current-testcase-p condition)) - (error "Cannot retry testcase.")) + (throw :testcase-retry t)) (testcase-step-up () :report (lambda (stream) @@ -537,8 +542,11 @@ symbol of this function." (format stream "Step up from testcase ~A." testcase-name))) :test (lambda (condition) (current-testcase-p condition)) - (return-from run-testcase-with-restarts))))) - (install-signal-handlers-and-run-testcase-with-restarts () + (return-from run-testcase-with-restarts)))) + (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) @@ -576,14 +584,14 @@ symbol of this function." (incf current-success testcase-success) (incf current-failure testcase-failure) (incf current-condition testcase-condition)))))) - (run-testcase-with-restarts) + (run-testcase-with-retry) (setf *last-testsuite-outcome* this-testcase-outcome) (describe *last-testsuite-outcome*) (terpri)))) (if testsuite-p - (install-signal-handlers-and-run-testcase-with-restarts) + (install-signal-handlers-and-run-testcase-with-retry) (progn - (run-testcase-with-restarts) + (run-testcase-with-retry) (signal 'testcase-end :outcome this-testcase-outcome))) (values this-testcase-outcome))))