Allow user-supplied calling handlers (#105)

Registered in the innermost context so that they are called even
within `try()`.

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: evaluate
 Type: Package
 Title: Parsing and Evaluation Tools that Provide More Details than the Default
-Version: 0.14.1
+Version: 0.14.2
 Authors@R: c(
     person("Hadley", "Wickham", role = "aut"),
     person("Yihui", "Xie", role = c("aut", "cre"), email = "xie@yihui.name", comment = c(ORCID = "0000-0003-0645-5666")),

NEWS.md

@@ -1,7 +1,7 @@
 Version 0.15
 ================================================================================
 
-
+- `new_output_handler()` gains a `calling_handlers` argument. These are passed to `withCallingHandlers()` before `evaluate()` captures any conditions.
 
 Version 0.14
 ================================================================================

R/eval.r

@@ -190,12 +190,19 @@ evaluate_call <- function(call, src = NULL,
     for (i in seq_along(funs_names)) assign(funs_names[i], funs[[i]], envir)
   }
 
+  user_handlers <- output_handler$calling_handlers
+
   multi_args <- length(formals(value_handler)) > 1
   for (expr in call) {
     srcindex <- length(output)
-    time <- timing_fn(handle(ev <- withCallingHandlers(
-      withVisible(eval(expr, envir, enclos)),
-      warning = wHandler, error = eHandler, message = mHandler)))
+    time <- timing_fn(handle(
+      ev <- withCallingHandlers(
+        withVisible(eval_with_user_handlers(expr, envir, enclos, user_handlers)),
+        warning = wHandler,
+        error = eHandler,
+        message = mHandler
+      )
+    ))
     handle_output(TRUE)
     if (!is.null(time))
       attr(output[[srcindex]]$src, 'timing') <- time
@@ -222,6 +229,24 @@ evaluate_call <- function(call, src = NULL,
   output
 }
 
+eval_with_user_handlers <- function(expr, envir, enclos, calling_handlers) {
+  if (!length(calling_handlers)) {
+    return(eval(expr, envir, enclos))
+  }
+
+  if (!is.list(calling_handlers)) {
+    stop("`calling_handlers` must be a list", call. = FALSE)
+  }
+
+  call <- as.call(c(
+    quote(withCallingHandlers),
+    quote(eval(expr, envir, enclos)),
+    calling_handlers
+  ))
+
+  eval(call)
+}
+
 #' Inject functions into the environment of `evaluate()`
 #'
 #' Create functions in the environment specified in the `envir` argument of

R/output.r

@@ -54,13 +54,17 @@ render <- function(x) if (isS4(x)) methods::show(x) else print(x)
 #' @param value Function to handle the values returned from evaluation. If it
 #'   only has one argument, only visible values are handled; if it has more
 #'   arguments, the second argument indicates whether the value is visible.
+#' @param calling_handlers List of [calling handlers][withCallingHandlers].
+#'   These handlers have precedence over the exiting handler installed
+#'   by [evaluate()] when `stop_on_error` is set to 0.
 #' @return A new `output_handler` object
 #' @aliases output_handler
 #' @export
 new_output_handler <- function(source = identity,
                                text = identity, graphics = identity,
                                message = identity, warning = identity,
-                               error = identity, value = render) {
+                               error = identity, value = render,
+                               calling_handlers = list()) {
   source <- match.fun(source)
   stopifnot(length(formals(source)) >= 1)
   text <- match.fun(text)
@@ -76,10 +80,39 @@ new_output_handler <- function(source = identity,
   value <- match.fun(value)
   stopifnot(length(formals(value)) >= 1)
 
+  check_handlers(calling_handlers)
+
   structure(list(source = source, text = text, graphics = graphics,
                  message = message, warning = warning, error = error,
-                 value = value),
+                 value = value, calling_handlers = calling_handlers),
             class = "output_handler")
 }
 
+check_handlers <- function(x) {
+  if (!is.list(x)) {
+    stop_bad_handlers()
+  }
+
+  if (!length(x)) {
+    return()
+  }
+
+  names <- names(x)
+  if (!is.character(names) || anyNA(names) || any(names == "")) {
+    stop_bad_handlers()
+  }
+
+  for (elt in x) {
+    if (!is.function(elt)) {
+      stop_bad_handlers()
+    }
+  }
+}
+stop_bad_handlers <- function() {
+  stop(simpleError(
+    "`calling_handlers` must be a named list of functions.",
+    call = call("new_output_handler")
+  ))
+}
+
 default_output_handler <- new_output_handler()

tests/testthat/test-evaluate.r

@@ -96,3 +96,39 @@ test_that("multiple lines of comments do not lose the terminating \\n", {
   ev <- evaluate("# foo\n#bar")
   expect_equal(ev[[1]][["src"]], "# foo\n")
 })
+
+test_that("user can register calling handlers", {
+  cnd <- structure(list(), class = c("foobar", "condition"))
+  hnd <- function(cnd) handled <<- cnd
+
+  handled <- NULL
+  hnd <- function(cnd) handled <<- cnd
+
+  out_hnd <- new_output_handler(calling_handlers = list(foobar = hnd))
+  evaluate("signalCondition(cnd)", output_handler = out_hnd)
+  expect_s3_class(handled, "foobar")
+
+  handled <- NULL
+  out_hnd <- new_output_handler(calling_handlers = list(error = hnd))
+  evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd)
+  expect_s3_class(handled, "error")
+})
+
+test_that("calling handlers are checked", {
+  expect_error(
+    new_output_handler(calling_handlers = list(condition = 1)),
+    "must be"
+  )
+  expect_error(
+    new_output_handler(calling_handlers = list(function(...) NULL)),
+    "must be"
+  )
+  expect_error(
+    new_output_handler(calling_handlers = stats::setNames(list(function(...) NULL), NA)),
+    "must be"
+  )
+  expect_error(
+    new_output_handler(calling_handlers = stats::setNames(list(function(...) NULL), "")),
+    "must be"
+  )
+})