Don't use a restart to handle stop_on_error = 2L

DESCRIPTION

@@ -25,11 +25,14 @@ BugReports: https://github.com/r-lib/evaluate/issues
 Depends:
     R (>= 3.6.0)
 Suggests:
+    callr,
     covr,
     ggplot2 (>= 3.3.6),
     lattice,
     methods,
+    pkgload,
     rlang,
+    knitr,
     testthat (>= 3.0.0),
     withr
 Config/Needs/website: tidyverse/tidytemplate

R/conditions.R

@@ -34,7 +34,8 @@ condition_handlers <- function(watcher, on_error, on_warning, on_message) {
       switch(on_error,
         continue = invokeRestart("eval_continue"),
         stop = invokeRestart("eval_stop"),
-        error = invokeRestart("eval_error", cnd)
+        # No need to invoke a restart as we want the error to be thrown in this case.
+        error = NULL
       )
     }
   )

R/evaluate.R

@@ -121,6 +121,11 @@ evaluate <- function(input,
   }
   local_inject_funs(envir)
 
+  if (is.null(getOption("rlang_trace_top_env"))) {
+    # If not already set, indicate the top environment to trim traceback
+    options(rlang_trace_top_env = envir)
+  }
+
   # Handlers for warnings, errors and messages
   user_handlers <- output_handler$calling_handlers
   evaluate_handlers <- condition_handlers(
@@ -151,8 +156,7 @@ evaluate <- function(input,
         handlers
       ),
       eval_continue = function() TRUE,
-      eval_stop = function() FALSE,
-      eval_error = function(cnd) {signalCondition(cnd); stop(cnd)}
+      eval_stop = function() FALSE
     )
     watcher$check_devices()
 

tests/testthat/_snaps/conditions.md

@@ -6,10 +6,10 @@
       Warning in `f()`:
       Hi!
 
-# all three starts of stop_on_error work as expected
+# all three values of stop_on_error work as expected
 
     Code
-      evaluate("stop(\"1\")\n2", stop_on_error = 2L)
+      ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L)
     Condition
       Error:
       ! 1

tests/testthat/_snaps/conditions/abort-error.txt

@@ -0,0 +1,10 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+ 4.       \-rlang::abort("!")
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/rmd-abort-error.md

@@ -0,0 +1,22 @@
+---
+title: document with error
+---
+
+
+``` r
+f <- function() g()
+g <- function() h()
+h <- function() rlang::abort("!")
+f()
+```
+
+```
+## Error in `h()`:
+## ! !
+## Backtrace:
+##     x
+##  1. \-evaluate (local) f()
+##  2.   \-evaluate (local) g()
+##  3.     \-evaluate (local) h()
+##  4.       \-rlang::abort("!")
+```

tests/testthat/_snaps/conditions/rmd-abort-error.txt

@@ -0,0 +1,12 @@
+
+
+processing file: ressources/with-abort-error.Rmd
+Error in `h()`:
+! !
+Backtrace:
+ 1. global f()
+ 2. global g()
+ 3. global h()
+
+Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-abort-error.Rmd)
+Execution halted

tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt

@@ -0,0 +1,12 @@
+
+
+processing file: ressources/with-stop-error-auto-entrace.Rmd
+Error in `h()`:
+! !
+Backtrace:
+ 1. global f()
+ 2. global g()
+ 3. global h()
+
+Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-stop-error-auto-entrace.Rmd)
+Execution halted

tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md

@@ -0,0 +1,27 @@
+---
+title: document with error
+---
+
+
+``` r
+rlang::global_entrace()
+options(rlang_backtrace_on_error_report = "full")
+```
+
+
+``` r
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```
+
+```
+## Error in `h()`:
+## ! !
+## Backtrace:
+##     x
+##  1. \-evaluate (local) f()
+##  2.   \-evaluate (local) g()
+##  3.     \-evaluate (local) h()
+```

tests/testthat/_snaps/conditions/rmd-stop-error.md

@@ -0,0 +1,15 @@
+---
+title: document with error
+---
+
+
+``` r
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```
+
+```
+## Error in h(): !
+```

tests/testthat/_snaps/conditions/stop-error-no-trace.txt

@@ -0,0 +1,4 @@
+Error in h() : !
+Calls: <Anonymous> ... withCallingHandlers -> withVisible -> eval -> eval -> f -> g -> h
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt

@@ -0,0 +1,9 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/stop-error-trace-trimmed.txt

@@ -0,0 +1,9 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/_snaps/conditions/stop-error-trace-wch.txt

@@ -0,0 +1,9 @@
+Error in `h()`:
+! !
+Backtrace:
+    x
+ 1. \-global f()
+ 2.   \-global g()
+ 3.     \-global h()
+Execution halted
+Ran 8/8 deferred expressions

tests/testthat/helper.R

@@ -2,3 +2,20 @@ expect_output_types <- function(x, types) {
   output_types <- vapply(x, output_type, character(1))
   expect_equal(output_types, types)
 }
+
+quick_install <- function(package, lib, quiet = TRUE) {
+  opts <- c(
+    "--data-compress=none",
+    "--no-byte-compile",
+    "--no-data",
+    "--no-demo",
+    "--no-docs",
+    "--no-help",
+    "--no-html",
+    "--no-libs",
+    "--use-vanilla",
+    sprintf("--library=%s", lib),
+    package
+  )
+  invisible(callr::rcmd("INSTALL", opts, show = !quiet, fail_on_status = TRUE))
+}

tests/testthat/ressources/with-abort-error.R

@@ -0,0 +1,7 @@
+testthat::local_reproducible_output()
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() rlang::abort("!")
+  f()
+}, stop_on_error = 2L)

tests/testthat/ressources/with-abort-error.Rmd

@@ -0,0 +1,10 @@
+---
+title: document with error
+---
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() rlang::abort("!")
+f()
+```

tests/testthat/ressources/with-stop-error-auto-entrace.Rmd

@@ -0,0 +1,10 @@
+---
+title: document with error
+---
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```

tests/testthat/ressources/with-stop-error-no-trace.R

@@ -0,0 +1,7 @@
+testthat::local_reproducible_output()
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() stop("!")
+  f()
+}, stop_on_error = 2L)

tests/testthat/ressources/with-stop-error-sewed.Rmd

@@ -0,0 +1,15 @@
+---
+title: document with error
+---
+
+```{r}
+rlang::global_entrace()
+options(rlang_backtrace_on_error_report = "full")
+```
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() stop("!")
+f()
+```

tests/testthat/ressources/with-stop-error-trace-trimmed.R

@@ -0,0 +1,11 @@
+testthat::local_reproducible_output()
+handlers <- evaluate::new_output_handler(
+  calling_handlers = list(error = function(cnd) rlang::entrace(cnd))
+)
+options(rlang_trace_top_env = parent.frame())
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() stop("!")
+  f()
+}, stop_on_error = 2L, output_handler = handlers)

tests/testthat/ressources/with-stop-error-trace.R

@@ -0,0 +1,10 @@
+testthat::local_reproducible_output()
+handlers <- evaluate::new_output_handler(
+  calling_handlers = list(error = function(cnd) rlang::entrace(cnd))
+)
+evaluate::evaluate(function() {
+  f <- function() g()
+  g <- function() h()
+  h <- function() stop("!")
+  f()
+}, stop_on_error = 2L, output_handler = handlers)

tests/testthat/ressources/with-stop-error-wch.R

@@ -0,0 +1,10 @@
+testthat::local_reproducible_output()
+withCallingHandlers(
+  error = function(cnd) rlang::entrace(cnd),
+  evaluate::evaluate(function() {
+    f <- function() g()
+    g <- function() h()
+    h <- function() stop("!")
+    f()
+  }, stop_on_error = 2L)
+)

tests/testthat/test-conditions.R

@@ -118,14 +118,14 @@ test_that("an error terminates evaluation of multi-expression input", {
   expect_output_types(ev, c("source", "error"))
 })
 
-test_that("all three starts of stop_on_error work as expected", {
+test_that("all three values 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"))
 
   ev <- evaluate('stop("1")\n2', stop_on_error = 1L)
   expect_output_types(ev, c("source", "error"))
 
-  expect_snapshot(evaluate('stop("1")\n2', stop_on_error = 2L), error = TRUE)
+  expect_snapshot(ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L), error = TRUE)
 })
 
 test_that("errors during printing are captured", {
@@ -136,3 +136,64 @@ test_that("errors during printing are captured", {
   ev <- evaluate("a")
   expect_output_types(ev, c("source", "error"))
 })
+
+test_that("Error can be entraced and correctly handled in outputs", {
+  skip_if_not_installed("rlang")
+  skip_if_not_installed("knitr")
+  skip_if_not_installed("callr")
+  skip_on_cran()
+  # install dev version of package in temp directory
+  withr::local_temp_libpaths()
+  quick_install(pkgload::pkg_path("."), lib = .libPaths()[1])
+
+  out <- withr::local_tempfile(fileext = ".txt")
+
+  # Checking different way to entrace with evaluate
+  callr::rscript(test_path("ressources/with-stop-error-no-trace.R"), fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'stop-error-no-trace.txt')
+
+  callr::rscript(test_path("ressources/with-stop-error-trace.R"), fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'stop-error-trace-calling-handler.txt')
+
+  callr::rscript(test_path("ressources/with-stop-error-wch.R"), fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'stop-error-trace-wch.txt')
+
+  callr::rscript(test_path("ressources/with-stop-error-trace-trimmed.R"), fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'stop-error-trace-trimmed.txt')
+
+  callr::rscript(test_path("ressources/with-abort-error.R"), fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'abort-error.txt')
+
+  # Checking error thrown when in rmarkdown and knitr context
+  rscript <- withr::local_tempfile(fileext = ".R")
+  out2 <- normalizePath(withr::local_tempfile(fileext = ".md"), winslash = "/", mustWork = FALSE)
+  writeLines(c(
+    "options(knitr.chunk.error = FALSE)",
+    sprintf('knitr::knit("%s", output = "%s")', test_path("ressources/with-stop-error-auto-entrace.Rmd"), out2)
+    ), con = rscript)
+  callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'rmd-stop-error-auto-entrace.txt')
+
+  writeLines(c(
+      "options(knitr.chunk.error = FALSE)",
+      sprintf('res <- knitr::knit("%s", output = "%s")', test_path("ressources/with-abort-error.Rmd"), out2)
+    ), con = rscript)
+  callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out)
+  expect_snapshot_file(out, name = 'rmd-abort-error.txt')
+
+  # Checking error captured in cell output in rmarkdown and knitr context
+  withr::with_options(list(options(knitr.chunk.error = TRUE)), {
+    expect_snapshot_file(
+      knitr::knit(test_path("ressources/with-stop-error-auto-entrace.Rmd"), output = out, quiet = TRUE),
+      name = "rmd-stop-error.md"
+    )
+    expect_snapshot_file(
+      knitr::knit(test_path("ressources/with-stop-error-sewed.Rmd"), output = out, quiet = TRUE),
+      name = "rmd-stop-error-entrace-sewed.md"
+    )
+    expect_snapshot_file(
+      knitr::knit(test_path("ressources/with-abort-error.Rmd"), output = out, quiet = TRUE),
+      name = "rmd-abort-error.md"
+    )
+  })
+})