Skip to content

Handlers refactoring #185

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 14 commits into from
Jul 1, 2024
Merged

Handlers refactoring #185

Show file tree
Hide file tree
Changes from 9 commits
Commits
Show all changes
14 commits
Select commit Hold shift + click to select a range
bfb7f4e
Move handlers into their own file in conditions.R
hadley Jun 26, 2024
7dd9692
Create handlers once per evaluate call
hadley Jun 26, 2024
3342d3b
Another test
hadley Jun 26, 2024
f04be87
Make watcher responsible for calling the output handler
hadley Jun 26, 2024
11bcdc1
Add news bullet
hadley Jun 26, 2024
6df9b94
Add print_value "method" to watcher; eliminate evaluate_tle
hadley Jun 26, 2024
b8a8b88
Move more setup to watcher
hadley Jun 26, 2024
df45c3f
Make watcher responsible for src too
hadley Jun 26, 2024
f694c61
Use watcher for failed parse
hadley Jun 26, 2024
6601944
Merge commit 'd0e5d98bd619dd17c1ed9a5ae1031afd705c7b88'
hadley Jun 28, 2024
300f719
Fix typo
hadley Jun 28, 2024
14da7c4
Clarify stop_on_error behaviour
hadley Jun 28, 2024
a2aa015
More feedback from code review
hadley Jun 28, 2024
6b5dedb
Redocument
hadley Jun 28, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions NEWS.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
# evaluate (development version)

* The `source` output handler is now parsed 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.
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think I might have actually changed this behaviour when I started using restarts, but it's now tested and documented. This is a bug that umpire works around in https://github.com/rstudio/umpire/blob/main/R/evaluate.R#L6-L11.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I find this terminology quite confusing because to me 1\n2 and 1;2 both contain two top-level expressions. I.e. 1;2 is not a single expression.

parse(text = "1; 2")
#> expression(1, 2)

parse(text = "1\n 2")
#> expression(1, 2)

Can we improve the terms used for this? Maybe "parser inputs"? Parser inputs are broken down by line by the R REPL, so 1;2 is one input containing two TLE and 1\n2 is two inputs containing each one TLE?

To put it another way a top-level expression should correspond to one iteration of the evaluation loop rather than multiple iterations. Each TLE produces one piece of printed output.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'd say 1;2 is one top-level expression consisting of two expressions. In your definition, what's the difference between a TLE and an expression?

I'd say each TLE generates one source statement.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Whether an expression is top-level is a property of where it's evaluated, at the top-level evaluation loop. It certainly makes sense to call 1;2 "top-level" but I find it confusing to also call it an "expression" because it's not an R expression stricto sensu. An expression is something that can be evaluated and thus must be representable as an AST node or leaf.

You could argue that 1;2 is parsed as an EXPRSXP vector and that you can evaluate it with the R-level eval() function, but I think it's the C-level function that should guide meaning here. And for the C-level function, EXPRSXP is a literal.

From this point of view foo(bar) consists of two expressions with bar nested in foo(bar). Whereas 1; 2 is not an expression but a sequence of two expressions managed by a top-level evaluation loop.

I'd say each TLE generates one source statement.

Sorry I'm not sure what that means.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ok, I see where you're coming from. I'm going to merge this PR but I'll keep thinking about the vocab.

* The package now depends on R 4.0.0 in order to decrease our maintenance burden.
* `evaluate()` automatically strips calls from conditions emitted by top-level code (these incorrectly get calls because they're wrapped inside `eval()`) (#150).
* `evalute(include_timing)` has been deprecated. I can't find any use of it on GitHub, and it adds substantial code complexity for little gain.
Expand Down
58 changes: 58 additions & 0 deletions R/conditions.R
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
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)
}
if (on_warning$silence) {
invokeRestart("muffleWarning")
}
},
error = 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)
)
}
)
}


with_handlers <- function(code, handlers) {
if (!is.list(handlers)) {
stop("`handlers` must be a list", call. = FALSE)

Check warning on line 46 in R/conditions.R

View check run for this annotation

Codecov / codecov/patch

R/conditions.R#L46 

Added line #L46 was not covered by tests
}

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
}
161 changes: 31 additions & 130 deletions R/eval.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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_output_handler(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) {
Expand Down
6 changes: 3 additions & 3 deletions R/output-handler.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down
38 changes: 36 additions & 2 deletions R/watcher.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,8 +17,23 @@ watchout <- function(handler = new_output_handler(),
push <- function(value) {
output[i] <<- list(value)
i <<- i + 1

switch(output_type(value),
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The watcher is now in charge of calling the handler when we push an output onto the stack.

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
Expand Down Expand Up @@ -48,7 +63,6 @@ watchout <- function(handler = new_output_handler(),
}

last_plot <<- plot
handler$graphics(plot)
push(plot)
invisible()
}
Expand All @@ -57,7 +71,6 @@ watchout <- function(handler = new_output_handler(),
out <- sink_con()
if (!is.null(out)) {
push(out)
handler$text(out)
}
invisible()
}
Expand All @@ -67,6 +80,22 @@ watchout <- function(handler = new_output_handler(),
capture_output()
}

print_value <- function(value, visible) {
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It feels a little weird to have this here, but the watcher is the one object that has all the details to handle this correctly.

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
Expand All @@ -77,12 +106,17 @@ watchout <- function(handler = new_output_handler(),
invisible()
}

local_output_handler(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)
)
}
Expand Down
6 changes: 5 additions & 1 deletion tests/testthat/test-conditions.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -104,8 +104,12 @@ 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"))
})

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"))

Expand Down
7 changes: 4 additions & 3 deletions tests/testthat/test-output-handler.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -25,8 +25,10 @@ test_that("graphic output handler not called with no graphics", {


test_that("can conditionally omit output with output handler", {
hide_source <- function(src, call) {
if (is.call(call) && identical(call[[1]], quote(hide))) {
hide_source <- function(src, tle) {
if (length(tle) == 0) {
src
} else if (is.call(tle[[1]]) && identical(tle[[1]][[1]], quote(hide))) {
NULL
} else {
src
Expand Down Expand Up @@ -96,4 +98,3 @@ test_that("user can register calling handlers", {
evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd)
expect_s3_class(handled, "error")
})

Loading