Collect output in an accumulating stack

I think this slightly simplifies the existing code, and as you'll seen in upcoming PRs, allows us to tease apart concerns to yield code that's a little easier to understand.
r-lib · Jun 21, 2024 · b6a314f · b6a314f
1 parent be1f9cf
commit b6a314f
Show file tree

Hide file tree

Showing 2 changed files with 47 additions and 39 deletions.
diff --git a/R/eval.R b/R/eval.R
@@ -79,17 +79,15 @@ evaluate <- function(input,
   # Capture output
   watcher <- watchout(output_handler, new_device = new_device, debug = debug)
 
-  out <- vector("list", nrow(parsed))
-  for (i in seq_along(out)) {
+  for (i in seq_len(nrow(parsed))) {
     if (log_echo || debug) {
       cat_line(parsed$src[[i]], file = stderr())
     }
-    out[[i]] <- evaluate_top_level_expression(
+    evaluate_top_level_expression(
       exprs = parsed$expr[[i]],
       src = parsed$src[[i]],
       watcher = watcher,
       envir = envir,
-      last = i == length(out),
       use_try = stop_on_error != 2L,
       keep_warning = keep_warning,
       keep_message = keep_message,
@@ -98,26 +96,21 @@ evaluate <- function(input,
     )
     watcher$check_devices()
 
-    if (stop_on_error > 0L) {
-      errs <- vapply(out[[i]], is.error, logical(1))
-
-      if (!any(errs)) next
-      if (stop_on_error == 1L) break
+    if (stop_on_error > 0L && watcher$has_errored()) {
+      break
     }
   }
 
-  is_empty <- vapply(out, identical, list(NULL), FUN.VALUE = logical(1))
-  out <- out[!is_empty]
+  # Always capture last plot, even if incomplete
+  watcher$capture_plot(TRUE)
 
-  out <- unlist(out, recursive = FALSE, use.names = FALSE)
-  new_evaluation(out)
+  watcher$get()
 }
 
 evaluate_top_level_expression <- function(exprs,
                                           src,
                                           watcher,
                                           envir = parent.frame(),
-                                          last = FALSE,
                                           use_try = FALSE,
                                           keep_warning = TRUE,
                                           keep_message = TRUE,
@@ -126,14 +119,12 @@ evaluate_top_level_expression <- function(exprs,
   stopifnot(is.expression(exprs))
 
   source <- new_source(src, exprs[[1]], output_handler$source)
-  output <- list(source)
+  if (!is.null(source))
+    watcher$push(source)
 
-  handle_output <- function(plot = TRUE, incomplete_plots = FALSE) {
-    out <- list(
-      if (plot) watcher$capture_plot(incomplete_plots),
-      watcher$capture_output()
-    )
-    output <<- c(output, compact(out))
+  handle_output <- function(plot = TRUE) {
+    if (plot) watcher$capture_plot()
+    watcher$capture_output()
   }
 
   local_output_handler(function() handle_output(FALSE))
@@ -151,7 +142,7 @@ evaluate_top_level_expression <- function(exprs,
   mHandler <- function(cnd) {
     handle_output()
     if (isTRUE(keep_message)) {
-      output <<- c(output, list(cnd))
+      watcher$push(cnd)
       output_handler$message(cnd)
       invokeRestart("muffleMessage")
     } else if (isFALSE(keep_message)) {
@@ -171,7 +162,7 @@ evaluate_top_level_expression <- function(exprs,
     handle_output()
     if (isTRUE(keep_warning)) {
       cnd <- reset_call(cnd)
-      output <<- c(output, list(cnd))
+      watcher$push(cnd)
       output_handler$warning(cnd)
       invokeRestart("muffleWarning")
     } else if (isFALSE(keep_warning)) {
@@ -182,7 +173,8 @@ evaluate_top_level_expression <- function(exprs,
     handle_output()
     if (use_try) {
       cnd <- reset_call(cnd)
-      output <<- c(output, list(cnd))
+      watcher$errored()
+      watcher$push(cnd)
       output_handler$error(cnd)
     }
   }
@@ -226,15 +218,13 @@ evaluate_top_level_expression <- function(exprs,
       )
       handle_output(TRUE)
       # If the return value is visible, save the value to the output
-      if (pv$visible) output <- c(output, list(pv$value))
+      if (pv$visible) {
+        watcher$push(pv$value)
+      }
     }
   }
-  # Always capture last plot, even if incomplete
-  if (last) {
-    handle_output(TRUE, TRUE)
-  }
 
-  output
+  invisible()
 }
 
 with_handlers <- function(code, handlers) {

diff --git a/R/watcher.R b/R/watcher.R
@@ -2,8 +2,6 @@ watchout <- function(handler = new_output_handler(),
                      new_device = TRUE,
                      debug = FALSE,
                      frame = parent.frame()) {
-  last_plot <- NULL
-
   if (new_device) {
     # Ensure we have a graphics device available for recording, but choose
     # one that's available on all platforms and doesn't write to disk
@@ -12,10 +10,24 @@ watchout <- function(handler = new_output_handler(),
     dev <- dev.cur()
     defer(dev.off(dev), frame)
   }
+
+  # Maintain a list of outputs that we'll grow over time
+  output <- list()
+  i <- 1
+  push <- function(value) {
+    output[i] <<- list(value)
+    i <<- i + 1
+    invisible()
+  }
+
+  # record whether or not we've seen an error
+  has_error <- FALSE
+  errored <- function() has_error <<- TRUE
+  has_errored <- function() has_error
 
-  # record current devices
-  devs <- dev.list()
-  devn <- length(devs)
+  # record current devices for plot handling
+  last_plot <- NULL
+  devn <- length(dev.list())
   dev <- dev.cur()
 
   con <- file("", "w+b")
@@ -54,15 +66,17 @@ watchout <- function(handler = new_output_handler(),
 
     last_plot <<- plot
     handler$graphics(plot)
-    plot
+    push(plot)
+    invisible()
   }
 
   capture_output <- function() {
     out <- read_con(con)
     if (!is.null(out)) {
+      push(out)
       handler$text(out)
     }
-    out
+    invisible()
   }
 
   check_devices <- function() {
@@ -74,11 +88,15 @@ watchout <- function(handler = new_output_handler(),
     devn <<- length(dev.list())
     invisible()
   }
-  
+
   list(
     capture_plot = capture_plot,
     capture_output = capture_output,
-    check_devices = check_devices
+    check_devices = check_devices,
+    push = push,
+    get = function() new_evaluation(output),
+    errored = errored,
+    has_errored = has_errored
   )
 }