Handlers refactoring (#185)

This is the culmination of all the evaluate() refactoring I've been working on — we can now define the handlers once (instead of once per top-level expression) and evaluate_tle() becomes sufficiently simple that we can inline it, making the double-loop strategy more clear. Includes a test and news bullet tracking the change in behaviour in `evaluate("stop(1);2")`, and corrects the source handler now that I better understand the data structures involved.
r-lib · Jul 1, 2024 · d8f00ea · d8f00ea
1 parent a691f59
commit d8f00ea
Show file tree

Hide file tree

Showing 8 changed files with 147 additions and 141 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,7 @@
 # evaluate (development version)
 
+* The `source` output handler is now passed the entire top-level expression, not just the first component.
+* `evaluate()` will now terminate on the first error in a top-level expression. This matches R's own behaviour more closely.
 * `is.value()` has been removed since it tests for an object that evaluate never creates.
 * `parse_all()` no longer has a default method, which will generate better errors if you pass in something unexpectected.
 * The package now depends on R 4.0.0 in order to decrease our maintenance burden.

diff --git a/R/conditions.R b/R/conditions.R
@@ -0,0 +1,58 @@
+condition_handlers <- function(watcher, on_error, on_warning, on_message) {
+  list(
+    message = function(cnd) {
+      watcher$capture_plot_and_output()
+
+      if (on_message$capture) {
+        watcher$push(cnd)
+      }
+      if (on_message$silence) {
+        invokeRestart("muffleMessage")
+      }
+    },
+    warning =  function(cnd) {
+      # do not handle warnings that shortly become errors or have been silenced
+      if (getOption("warn") >= 2 || getOption("warn") < 0) {
+        return()
+      } 
+
+      watcher$capture_plot_and_output()
+      if (on_warning$capture) {
+        cnd <- sanitize_call(cnd)
+        watcher$push(cnd)
+      }
+      if (on_warning$silence) {
+        invokeRestart("muffleWarning")
+      }
+    },
+    error = function(cnd) {
+      watcher$capture_plot_and_output()
+
+      cnd <- sanitize_call(cnd)
+      watcher$push(cnd)
+
+      switch(on_error,
+        continue = invokeRestart("eval_continue"),
+        stop = invokeRestart("eval_stop"),
+        error = invokeRestart("eval_error", cnd)
+      )
+    }
+  )
+}
+
+
+with_handlers <- function(code, handlers) {
+  if (!is.list(handlers)) {
+    stop("`handlers` must be a list", call. = FALSE)
+  }
+
+  call <- as.call(c(quote(withCallingHandlers), quote(code), handlers))
+  eval(call)
+}
+
+sanitize_call <- function(cnd) {
+  if (identical(cnd$call, quote(eval(expr, envir)))) {
+    cnd$call <- NULL
+  }
+  cnd
+}
diff --git a/R/eval.R b/R/eval.R
@@ -77,40 +77,51 @@ evaluate <- function(input,
     warning("`evaluate(include_timing)` is deprecated")
   }
 
+  # Capture output
+  watcher <- watchout(output_handler, new_device = new_device, debug = debug)
+
   parsed <- parse_all(input, filename, on_error != "error")
   if (inherits(err <- attr(parsed, 'PARSE_ERROR'), 'error')) {
-    source <- new_source(parsed$src, expression(), output_handler$source)
-    output_handler$error(err)
-    err$call <- NULL  # the call is unlikely to be useful
-    return(new_evaluation(list(source, err)))
+    watcher$push_source(parsed$src, expression())
+    watcher$push(err)
+    return(watcher$get())
   }
 
   if (is.list(envir)) {
     envir <- list2env(envir, parent = enclos %||% parent.frame())
   }
   local_inject_funs(envir)
 
-  # Capture output
-  watcher <- watchout(output_handler, new_device = new_device, debug = debug)
 
+  # Handlers for warnings, errors and messages
+  user_handlers <- output_handler$calling_handlers
+  evaluate_handlers <- condition_handlers(
+    watcher,
+    on_error = on_error,
+    on_warning = on_warning,
+    on_message = on_message
+  )
+  # The user's condition handlers have priority over ours
+  handlers <- c(user_handlers, evaluate_handlers)
+
   for (i in seq_len(nrow(parsed))) {
-    if (log_echo || debug) {
+    watcher$push_source(parsed$src[[i]], parsed$expr[[i]])
+    if (debug || log_echo) {
       cat_line(parsed$src[[i]], file = stderr())
     }
+
     continue <- withRestarts(
-      {
-        evaluate_top_level_expression(
-          exprs = parsed$expr[[i]],
-          src = parsed$src[[i]],
-          watcher = watcher,
-          envir = envir,
-          on_error = on_error,
-          on_warning = on_warning,
-          on_message = on_message,
-          output_handler = output_handler
-        )
-        TRUE
-      },
+      with_handlers(
+        {
+          for (expr in parsed$expr[[i]]) {
+            ev <- withVisible(eval(expr, envir))
+            watcher$capture_plot_and_output()
+            watcher$print_value(ev$value, ev$visible)
+          }
+          TRUE
+        },
+        handlers
+      ),
       eval_continue = function() TRUE,
       eval_stop = function() FALSE,
       eval_error = function(cnd) stop(cnd)
@@ -121,122 +132,12 @@ evaluate <- function(input,
       break
     }
   }
-
   # Always capture last plot, even if incomplete
   watcher$capture_plot(TRUE)
 
   watcher$get()
 }
 
-evaluate_top_level_expression <- function(exprs,
-                                          src,
-                                          watcher,
-                                          envir = parent.frame(),
-                                          on_error = "continue",
-                                          on_warning,
-                                          on_message,
-                                          log_warning = FALSE,
-                                          output_handler = new_output_handler()) {
-  stopifnot(is.expression(exprs))
-
-  source <- new_source(src, exprs[[1]], output_handler$source)
-  if (!is.null(source))
-    watcher$push(source)
-
-  local_console_flusher(watcher$capture_output)
-  local_plot_hooks(watcher$capture_plot_and_output)
-
-  # Handlers for warnings, errors and messages
-  mHandler <- function(cnd) {
-    watcher$capture_plot_and_output()
-
-    if (on_message$capture) {
-      watcher$push(cnd)
-      output_handler$message(cnd)
-    }
-    if (on_message$silence) {
-      invokeRestart("muffleMessage")
-    }
-  }
-  wHandler <- function(cnd) {
-    # do not handle warnings that shortly become errors
-    if (getOption("warn") >= 2) return()
-    # do not handle warnings that have been completely silenced
-    if (getOption("warn") < 0) return()
-
-    watcher$capture_plot_and_output()
-    if (on_warning$capture) {
-      cnd <- reset_call(cnd)
-      watcher$push(cnd)
-      output_handler$warning(cnd)
-    }
-    if (on_warning$silence) {
-      invokeRestart("muffleWarning")
-    }
-  }
-  eHandler <- function(cnd) {
-    watcher$capture_plot_and_output()
-
-    cnd <- reset_call(cnd)
-    watcher$push(cnd)
-
-    switch(on_error,
-      continue = invokeRestart("eval_continue"),
-      stop = invokeRestart("eval_stop"),
-      error = invokeRestart("eval_error", cnd)
-    )
-  }
-
-  user_handlers <- output_handler$calling_handlers
-  evaluate_handlers <- list(error = eHandler, warning = wHandler, message = mHandler)
-  # The user's condition handlers have priority over ours
-  handlers <- c(user_handlers, evaluate_handlers)
-
-  for (expr in exprs) {
-    ev <- with_handlers(
-      withVisible(eval(expr, envir)),
-      handlers
-    )
-    watcher$capture_plot_and_output()
-
-    if (show_value(output_handler, ev$visible)) {
-      # Ideally we'd evaluate the print() generic in envir in order to find
-      # any methods registered in that environment. That, however, is 
-      # challenging and only makes a few tests a little simpler so we don't
-      # bother.
-      pv <- with_handlers(
-        withVisible(
-          handle_value(output_handler, ev$value, ev$visible)
-        ),
-        handlers
-      )
-      watcher$capture_plot_and_output()
-      # If the return value is visible, save the value to the output
-      if (pv$visible) {
-        watcher$push(pv$value)
-      }
-    }
-  }
-
-  invisible()
-}
-
-with_handlers <- function(code, handlers) {
-  if (!is.list(handlers)) {
-    stop("`handlers` must be a list", call. = FALSE)
-  }
-
-  call <- as.call(c(quote(withCallingHandlers), quote(code), handlers))
-  eval(call)
-}
-
-reset_call <- function(cnd) {
-  if (identical(cnd$call, quote(eval(expr, envir)))) {
-    cnd$call <- NULL
-  }
-  cnd
-}
-
 check_stop_on_error <- function(x) {
   if (is.numeric(x) && length(x) == 1 && !is.na(x)) {
     if (x == 0L) {

diff --git a/R/output-handler.R b/R/output-handler.R
@@ -16,10 +16,10 @@
 #' printing, then the `text` or `graphics` handlers may be called.
 #'
 #' @param source Function to handle the echoed source code under evaluation.
-#'  This function should take two arguments (`src` and `call`), and return
+#'  This function should take two arguments (`src` and `tle`), and return
 #'  an object that will be inserted into the evaluate outputs. `src` is the
-#'  unparsed text of the source code, and `call` is the parsed language object 
-#'  If `src` is unparsable, `call` will be `expression()`.
+#'  unparsed text of the source code, and `tle` is the parsed top-level 
+#'  expression. If `src` is unparsable, `tle` will be `expression()`.
 #' 
 #'  Return `src` for the default evaluate behaviour. Return `NULL` to 
 #'  drop the source from the output.

diff --git a/R/watcher.R b/R/watcher.R
@@ -17,8 +17,23 @@ watchout <- function(handler = new_output_handler(),
   push <- function(value) {
     output[i] <<- list(value)
     i <<- i + 1
+
+    switch(output_type(value),
+      plot = handler$graphics(value),
+      text = handler$text(value),
+      message = handler$message(value),
+      warning = handler$warning(value),
+      error = handler$error(value)
+    )
+
     invisible()
   }
+  push_source <- function(src, tle) {
+    source <- new_source(src, tle, handler$source)
+    if (!is.null(source)) {
+      push(source)
+    }
+  }
 
   # record current devices for plot handling
   last_plot <- NULL
@@ -48,7 +63,6 @@ watchout <- function(handler = new_output_handler(),
     }
 
     last_plot <<- plot
-    handler$graphics(plot)
     push(plot)
     invisible()
   }
@@ -57,7 +71,6 @@ watchout <- function(handler = new_output_handler(),
     out <- sink_con()
     if (!is.null(out)) {
       push(out)
-      handler$text(out)
     }
     invisible()
   }
@@ -67,6 +80,22 @@ watchout <- function(handler = new_output_handler(),
     capture_output()
   }
 
+  print_value <- function(value, visible) {
+    if (!show_value(handler, visible)) 
+      return()
+
+    # Ideally we'd evaluate the print() generic in envir in order to find
+    # any methods registered in that environment. That, however, is 
+    # challenging and only makes a few tests a little simpler so we don't
+    # bother.
+    pv <- withVisible(handle_value(handler, value, visible))
+    capture_plot_and_output()
+    # If the return value is visible, save the value to the output
+    if (pv$visible) {
+      push(pv$value)
+    }
+  }
+
   check_devices <- function() {
     # if dev.off() was called, make sure to restore device to the one opened 
     # when watchout() was called
@@ -77,12 +106,17 @@ watchout <- function(handler = new_output_handler(),
     invisible()
   }
 
+  local_console_flusher(capture_output, frame = frame)
+  local_plot_hooks(capture_plot_and_output, frame = frame)
+
   list(
     capture_plot = capture_plot,
     capture_output = capture_output,
     capture_plot_and_output = capture_plot_and_output,
     check_devices = check_devices,
     push = push,
+    push_source = push_source,
+    print_value = print_value,
     get = function() new_evaluation(output)
   )
 }

diff --git a/man/new_output_handler.Rd b/man/new_output_handler.Rd
diff --git a/tests/testthat/test-conditions.R b/tests/testthat/test-conditions.R
@@ -104,8 +104,17 @@ test_that("log_warning causes warnings to be emitted", {
 
 # errors ----------------------------------------------------------------------
 
-test_that("all three starts of stop_on_error work as expected", {
+test_that("an error terminates evaluation of top-level expression", {
+  ev <- evaluate("stop('1');2\n3")
+  expect_output_types(ev, c("source", "error", "source", "text"))
+  expect_equal(ev[[1]]$src, "stop('1');2\n")
+
+  ev <- evaluate("stop('1');2\n3", stop_on_error = 1L)
+  expect_equal(ev[[1]]$src, "stop('1');2\n")
+  expect_output_types(ev, c("source", "error"))
+})
 
+test_that("all three starts of stop_on_error work as expected", {
   ev <- evaluate('stop("1")\n2', stop_on_error = 0L)
   expect_output_types(ev, c("source", "error", "source", "text"))