fixup! Break into the debugger upon error

Draft the restart strategy
melusina-org · Apr 12, 2024 · 5ab8e54 · 5ab8e54
1 parent 32f965c
commit 5ab8e54
Show file tree

Hide file tree

Showing 2 changed files with 138 additions and 93 deletions.
diff --git 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
@@ -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)