Allow source handler to control source

NEWS.md

@@ -1,5 +1,6 @@
 # evaluate (development version)
 
+* The `source` output handler can now take two arguments (the unparsed `src` and the parsed `call`) and choose to affect the displayed source.
 
 # Version 0.23
 

R/eval.R

@@ -58,8 +58,7 @@ evaluate <- function(input,
 
   parsed <- parse_all(input, filename, stop_on_error != 2L)
   if (inherits(err <- attr(parsed, 'PARSE_ERROR'), 'error')) {
-    source <- new_source(parsed$src)
-    output_handler$source(source)
+    source <- new_source(parsed$src, call[[1]], output_handler$source)
     output_handler$error(err)
     err$call <- NULL  # the call is unlikely to be useful
     return(list(source, err))
@@ -124,6 +123,9 @@ evaluate <- function(input,
     }
   }
 
+  is_empty <- vapply(out, identical, list(NULL), FUN.VALUE = logical(1))
+  out <- out[!is_empty]
+
   unlist(out, recursive = FALSE, use.names = FALSE)
 }
 
@@ -143,8 +145,7 @@ evaluate_call <- function(call,
   if (debug) message(src)
 
   if (is.null(call) && !last) {
-    source <- new_source(src)
-    output_handler$source(source)
+    source <- new_source(src, call[[1]], output_handler$source)
     return(list(source))
   }
   stopifnot(is.call(call) || is.language(call) || is.atomic(call) || is.null(call))
@@ -161,8 +162,7 @@ evaluate_call <- function(call,
     cat(src, "\n", sep = "", file = stderr())
   }
 
-  source <- new_source(src)
-  output_handler$source(source)
+  source <- new_source(src, call[[1]], output_handler$source)
   output <- list(source)
 
   dev <- dev.cur()

R/output.R

@@ -19,8 +19,23 @@ new_value <- function(value, visible = TRUE) {
   structure(list(value = value, visible = visible), class = "value")
 }
 
-new_source <- function(src) {
-  structure(list(src = src), class = "source")
+new_source <- function(src, call, handler = NULL) {
+  src <- structure(list(src = src), class = "source")
+  if (is.null(handler)) {
+    return(src)
+  }
+
+  n_args <- length(formals(handler))
+  if (n_args == 1) {
+    # Old format only called for side effects
+    handler(src)
+    src
+  } else if (n_args == 2) {
+    # New format can influence result
+    handler(src, call)
+  } else {
+    stop("Source output handler must have one or two arguments")
+  }
 }
 
 classes <- function(x) vapply(x, function(x) class(x)[1], character(1))
@@ -45,6 +60,11 @@ render <- function(x) if (isS4(x)) methods::show(x) else print(x)
 #' 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
+#'  an object that will be inserted into the evaluate outputs. 
+#' 
+#'  Return `src` for the default evaluate behaviour. Return `NULL` to 
+#'  drop the source from the output.
 #' @param text Function to handle any textual console output.
 #' @param graphics Function to handle graphics, as returned by
 #'   [recordPlot()].

tests/testthat/_snaps/eval.md

@@ -25,3 +25,11 @@
       Warning:
       This is a warning
 
+# can conditionally omit output with output handler
+
+    Code
+      replay(out)
+    Output
+      > x
+      [1] 1
+

tests/testthat/_snaps/output.md

@@ -0,0 +1,8 @@
+# handles various numbers of arguments
+
+    Code
+      new_source("x", quote(x), f3)
+    Condition
+      Error in `new_source()`:
+      ! Source output handler must have one or two arguments
+

tests/testthat/test-eval.R

@@ -43,3 +43,19 @@ test_that("show_warning handles different types of warning", {
   })
 
 })
+
+test_that("can conditionally omit output with output handler", {
+  hide_source <- function(src, call) {
+    if (is.call(call) && identical(call[[1]], quote(hide))) {
+      NULL
+    } else {
+      src
+    }
+  }
+  handler <- new_output_handler(source = hide_source)
+  hide <- function(x) invisible(x)
+
+  out <- evaluate("hide(x <- 1)\nx", output_handler = handler)
+  expect_length(out, 2)
+  expect_snapshot(replay(out))
+})

tests/testthat/test-output.R

@@ -4,3 +4,29 @@ test_that("open plot windows maintained", {
   expect_length(dev.list(), n)
 })
 
+
+# new_source -------------------------------------------------------------------
+
+test_that("handles various numbers of arguments", {
+  signal_condition <- function(class) {
+    signalCondition(structure(list(), class = c(class, "condition")))
+  } 
+  expected <- structure(list(src = "x"), class = "source")
+
+  # No handler
+  expect_equal(new_source("x", quote(x)), expected)
+
+  # One argument
+  f1 <- function(src) signal_condition("handler_called")
+  expect_condition(out <- new_source("x", quote(x), f1), class = "handler_called")
+  expect_equal(out, expected)
+
+  # Two arguments
+  f2 <- function(src, call) {signal_condition("handler_called"); NULL}
+  expect_condition(out <- new_source("x", quote(x), f2), class = "handler_called")
+  expect_equal(out, NULL)
+
+  # Three arguments
+  f3 <- function(a, b, c) NULL
+  expect_snapshot(new_source("x", quote(x), f3), error = TRUE)
+})