Handle interrupts in tests (#2148)

I don't see any way to test this programmatically, so I've just been adding `Sys.sleep(10)` to a random test.

Fixes #1464

Author: hadley

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* Interrupting a test now prints the test name. This makes it easier to tell where a very slow test might be hanging (#1464)
 * Parallel testthat now does not ignore test files with syntax errors (#1360).
 * `expect_lt()`, `expect_gt()`, and friends have a refined display that is more likely to display the correct number of digits and shows you the actual values compared.
 * `describe()`, `it()`, and `test_that()` now have a shared stack of descriptions so that if you nest any inside of each other, any resulting failures will show you the full path.

R/reporter-stop.R

@@ -14,48 +14,53 @@ StopReporter <- R6::R6Class(
   "StopReporter",
   inherit = Reporter,
   public = list(
-    failures = NULL,
+    # All expectations that need to be reported (error, failure, warning, skip)
+    issues = NULL,
+    # Expectations that should cause the test to fail (error, failure)
     n_fail = 0L,
+    # Successful expectations
+    n_success = 0L,
     stop_reporter = TRUE,
     praise = TRUE,
 
     initialize = function(stop_reporter = TRUE, praise = TRUE) {
       super$initialize()
-      self$failures <- Stack$new()
+      self$issues <- Stack$new()
       self$praise <- praise
       self$stop_reporter <- stop_reporter
     },
 
     start_test = function(context, test) {
-      self$failures <- Stack$new()
+      self$issues <- Stack$new()
     },
 
     add_result = function(context, test, result) {
       if (expectation_success(result)) {
+        self$n_success <- self$n_success + 1
         return()
       }
 
       if (expectation_broken(result)) {
         self$n_fail <- self$n_fail + 1
       }
-
-      self$failures$push(result)
+      self$issues$push(result)
     },
 
     end_test = function(context, test) {
       self$local_user_output()
 
-      failures <- self$failures$as_list()
-      if (length(failures) == 0 && self$praise) {
-        self$cat_line(colourise("Test passed", "success"), " ", praise_emoji())
-        return()
-      }
-
-      messages <- map_chr(failures, issue_summary, rule = TRUE)
-      if (length(messages) > 0) {
+      if (self$issues$size() == 0) {
+        if (self$praise && self$n_success > 0) {
+          emoji <- praise_emoji()
+          self$cat_line(colourise("Test passed", "success"), " ", emoji)
+        }
+      } else {
+        issues <- self$issues$as_list()
+        messages <- map_chr(issues, issue_summary, rule = TRUE)
         self$cat_line(messages, "\n")
       }
     },
+
     stop_if_needed = function() {
       if (self$stop_reporter && self$n_fail > 0) {
         abort("Test failed", call = NULL)

R/test-that.R

@@ -149,6 +149,12 @@ test_code <- function(code, env, reporter = NULL, skip_on_empty = TRUE) {
     register_expectation(e, debug_end)
     invokeRestart("end_test")
   }
+  handle_interrupt <- function(e) {
+    if (!is.null(test)) {
+      cat("\n")
+      cli::cli_inform(c("!" = "Interrupting test: {test}"))
+    }
+  }
 
   test_env <- new.env(parent = env)
   old <- options(rlang_trace_top_env = test_env)[[1]]
@@ -170,7 +176,8 @@ test_code <- function(code, env, reporter = NULL, skip_on_empty = TRUE) {
         skip = handle_skip,
         warning = handle_warning,
         message = handle_message,
-        error = handle_error
+        error = handle_error,
+        interrupt = handle_interrupt
       ),
       # some errors may need handling here, e.g., stack overflow
       error = handle_fatal