Handle errors in parallel teardown files

I also changed the exit status of the subprocesses to 0 (normal exit),
from 1. I didn't find any reason why it was 1, hopefully there
wasn't any. It is a normal exit, so 0 makes more senset to me (now).

Closes #1165.

Author: gaborcsardi

R/parallel.R

@@ -333,7 +333,7 @@ queue_teardown <- function(queue) {
 
   clean_fn <- function() {
     withr::deferred_run(.GlobalEnv)
-    quit(save = "no", status = 1L, runLast = TRUE)
+    quit(save = "no", status = 0L, runLast = TRUE)
   }
 
   topoll <- list()
@@ -344,7 +344,7 @@ queue_teardown <- function(queue) {
       tryCatch(
         {
           tasks$worker[[i]]$call(clean_fn)
-          topoll <- c(topoll, tasks$worker[[i]]$get_poll_connection())
+          topoll <- c(topoll, tasks$worker[[i]])
         },
         error = function(e) tasks$worker[i] <- list(NULL)
       )
@@ -357,10 +357,16 @@ queue_teardown <- function(queue) {
   } else {
     grace <- 3L
   }
+  first_error <- NULL
   limit <- Sys.time() + grace
   while (length(topoll) > 0 && (timeout <- limit - Sys.time()) > 0) {
     timeout <- as.double(timeout, units = "secs") * 1000
-    pr <- processx::poll(topoll, as.integer(timeout))
+    conns <- lapply(topoll, function(x) x$get_poll_connection())
+    pr <- unlist(processx::poll(conns, as.integer(timeout)))
+    for (i in which(pr == "ready")) {
+      msg <- topoll[[i]]$read()
+      first_error <- first_error %||% msg$error
+    }
     topoll <- topoll[pr != "ready"]
   }
 
@@ -377,6 +383,13 @@ queue_teardown <- function(queue) {
       }
     }
   }
+
+  if (!is.null(first_error)) {
+    cli::cli_abort(
+      "At least one parallel worker failed to run teardown",
+      parent = first_error
+    )
+  }
 }
 
 # Reporter that just forwards events in the subprocess back to the main process

tests/testthat/test-parallel-teardown.R

@@ -1,5 +1,4 @@
 test_that("teardown error", {
-  skip("teardown errors are ignored")
   withr::local_envvar(TESTTHAT_PARALLEL = "TRUE")
   err <- tryCatch(
     capture.output(suppressMessages(testthat::test_local(
@@ -8,6 +7,14 @@ test_that("teardown error", {
     ))),
     error = function(e) e
   )
-  expect_s3_class(err, "testthat_process_error")
-  expect_match(err$message, "Error in teardown", fixed = TRUE)
+  expect_s3_class(err$parent, "callr_error")
+  expect_match(
+    err$message,
+    "At least one parallel worker failed to run teardown"
+  )
+  expect_match(
+    err$parent$parent$parent$message,
+    "Error in teardown",
+    fixed = TRUE
+  )
 })