From 5ab8e54cffb0eb482df4992bb75f2cadbaf5db43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?= Date: Fri, 12 Apr 2024 16:20:00 +0200 Subject: [PATCH] fixup! Break into the debugger upon error Draft the restart strategy --- src/testcase.lisp | 213 ++++++++++++++++++++++++---------------- testsuite/testcase.lisp | 18 ++-- 2 files changed, 138 insertions(+), 93 deletions(-) diff --git a/src/testcase.lisp b/src/testcase.lisp index 8743df0..3f1b883 100644 --- a/src/testcase.lisp +++ b/src/testcase.lisp @@ -320,45 +320,63 @@ 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) - (flet ((signal-argument-condition (condition) - (signal - '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 - '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 - 'assertion-failure - :path *testcase-path* - :name name - :argument-names argument-names - :argument-values argument-values - :form form - :type type - :description description)) - (signal-success () - (signal - 'assertion-success - :path *testcase-path* - :name name - :argument-names argument-names - :argument-values argument-values - :form form - :type type))) + (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)) @@ -496,56 +514,77 @@ 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)) + (error "Cannot retry testcase.")) + (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)) + (return-from run-testcase-with-restarts))))) + (install-signal-handlers-and-run-testcase-with-restarts () + (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)))))) + (run-testcase-with-restarts) + (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-restarts) + (progn + (run-testcase-with-restarts) + (signal 'testcase-end :outcome this-testcase-outcome))) (values this-testcase-outcome)))) (defmacro define-testcase (testcase-name testcase-args &body body) diff --git a/testsuite/testcase.lisp b/testsuite/testcase.lisp index d96d068..116846b 100644 --- a/testsuite/testcase.lisp +++ b/testsuite/testcase.lisp @@ -36,14 +36,20 @@ (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-testcase-testsuite)) (define-testcase a-successful-testsuite-with-function-calls () (funcall 'a-successful-testsuite)