Better function parsing

R/parse.R

@@ -142,33 +142,8 @@ parse_all.connection <- function(x, filename = NULL, ...) {
 
 #' @export
 parse_all.function <- function(x, filename = NULL, ...) {
-  src <- attr(x, "srcref", exact = TRUE)
-  if (is.null(src)) {
-    src <- deparse(body(x))
-    # Remove { and }
-    n <- length(src)
-    if (n >= 2) src <- src[-c(1, n)]
-    if (is.null(filename))
-      filename <- "<function>"
-    parse_all(src, filename, ...)
-  } else {
-    src2 <- attr(body(x), "srcref", exact = TRUE)
-    n <- length(src2)
-    if (n > 0) {
-      if (is.null(filename))
-        filename <- attr(src, 'srcfile')$filename
-      if (n >= 2) {
-        parse_all(unlist(lapply(src2[-1], as.character)), filename, ...)
-      } else  {
-        # f <- function(...) {}
-        parse_all(character(0), filename, ...)
-      }
-    } else {
-      if (is.null(filename))
-        filename <- "<function>"
-      parse_all(deparse(body(x)), filename, ...)
-    }
-  }
+  filename <- filename %||% "<filename>"
+  parse_all(find_function_body(x), filename = filename, ...)
 }
 
 #' @export
@@ -185,3 +160,23 @@ parse_all.call <- function(x, filename = NULL, ...) {
   out$expr <- list(as.expression(x))
   out
 }
+
+find_function_body <- function(f) {
+  if (is_call(body(f), "{")) {
+    lines <- deparse(f, control = "useSource")
+    expr <- parse(text = lines, keep.source = TRUE)
+
+    data <- getParseData(expr)
+    token_start <- which(data$token == "'{'")[[1]]
+    token_end <- last(which(data$token == "'}'"))
+
+    line_start <- data$line1[token_start] + 1
+    line_end <- data$line2[token_end] - 1
+    lines <- lines[seq2(line_start, line_end)]
+
+    dedent <- min(data$col1[seq2(token_start + 1, token_end - 1)], 1e3) 
+    substr(lines, dedent, nchar(lines))
+  } else {
+    deparse(body(f))
+  }
+}

R/utils.R

@@ -23,3 +23,20 @@
 env_var_is_true <- function(x) {
   isTRUE(as.logical(Sys.getenv(x, "false")))
 }
+
+is_call <- function(x, name) {
+  if (!is.call(x)) {
+    return(FALSE)
+  }
+  is.name(x[[1]]) && as.character(x[[1]]) %in% name
+}
+
+last <- function(x) x[length(x)]
+
+seq2 <- function(start, end, by = 1) {
+  if (start > end) {
+    integer()
+  } else {
+    seq(start, end, by = 1)
+  }
+}

tests/testthat/_snaps/replay.md

@@ -11,24 +11,29 @@
     Code
       replay(ev)
     Output
-      > f()
+      > print("1")
       [1] "1"
+      > message("2")
       2
-      Warning in f():
+      > warning("3")
+      Warning:
       3
-      Error in f():
+      > stop("4")
+      Error:
       4
 
 # replay handles rlang conditions
 
     Code
       replay(ev)
     Output
-      > f()
+      > rlang::inform("2")
       2
+      > rlang::warn("3")
       Warning:
       3
-      Error in f():
+      > rlang::abort("4", call = NULL)
+      Error:
       4
 
 # format_condition handles different types of warning

tests/testthat/helper.R

@@ -1,12 +1,3 @@
-evaluate_ <- function(text, ..., envir = parent.frame()) {
-  # Trim off leading/trailing new lines and dedent
-  text <- gsub("^\n {4}", "", text)
-  text <- gsub("\n {4}", "\n", text)
-  text <- gsub("\n +$", "", text)
-
-  evaluate(text, ..., envir = envir)
-}
-
 expect_output_types <- function(x, types) {
   output_types <- vapply(x, output_type, character(1))
   expect_equal(output_types, types)

tests/testthat/test-conditions.R

@@ -106,7 +106,7 @@ test_that("log_warning causes warnings to be emitted", {
 
 test_that("all three starts of stop_on_error work as expected", {
 
-  ev <- evaluate_('stop("1")\n2', stop_on_error = 0L)
+  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)

tests/testthat/test-eval.R

@@ -1,9 +1,9 @@
 
 test_that("file with only comments runs", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     # This test case contains no executable code
     # but it shouldn't throw an error
-  ")
+  })
   expect_output_types(ev, c("source", "source"))
 })
 
@@ -34,10 +34,10 @@ test_that("log_echo causes output to be immediately written to stderr()", {
 test_that("data sets loaded", {
   skip_if_not_installed("lattice")
 
-  ev <- evaluate_('
+  ev <- evaluate(function() {
     data(barley, package = "lattice")
     barley
-  ')
+  })
   expect_output_types(ev, c("source", "source", "text"))
 })
 
@@ -57,20 +57,20 @@ test_that("S4 methods are displayed with show, not print", {
 })
 
 test_that("output and plots interleaved correctly", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     for (i in 1:2) {
       cat(i)
       plot(i)
     }
-  ")
+  })
   expect_output_types(ev, c("source", "text", "plot", "text", "plot"))
 
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     for (i in 1:2) {
       plot(i)
       cat(i)
     }
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "text", "plot", "text"))
 })
 

tests/testthat/test-graphics.R

@@ -4,21 +4,21 @@ test_that("single plot is captured", {
 })
 
 test_that("plot additions are captured", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     plot(1:10)
     lines(1:10)
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "source", "plot"))
 })
 
 test_that("blank plots created by plot.new() are preserved", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     plot.new()
     plot(1:10)
     plot.new()
     plot(1:10)
     plot.new()
-  ")
+  })
   expect_output_types(ev, rep(c("source", "plot"), 5))
 })
 
@@ -31,13 +31,13 @@ test_that("evaluate doesn't open plots or create files", {
 })
 
 test_that("base plots in a single expression are captured", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     {
       plot(rnorm(100))
       plot(rnorm(100))
       plot(rnorm(100))
     }
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "plot", "plot"))
 })
 
@@ -48,68 +48,70 @@ test_that("captures ggplots", {
   )
   expect_output_types(ev, c("source", "plot"))
 
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     for (j in 1:2) {
       print(ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point())
     }
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "plot"))
 })
 
 test_that("erroring ggplots should not be recorded", {
   skip_if_not_installed("ggplot2")
 
   # error in aesthetics
-  ev <- evaluate_("
-    ggplot2::ggplot(iris, ggplot2::aes(XXXXXXXXXX, Sepal.Length) + ggplot2::geom_boxplot()
-  ")
+  ev <- evaluate(function() {
+    ggplot2::ggplot(iris, ggplot2::aes(XXXXXXXXXX, Sepal.Length)) + 
+      ggplot2::geom_boxplot()
+  })
   expect_output_types(ev, c("source", "error"))
 
   # error in geom
-  ev <- evaluate_("
-    ggplot2::ggplot(iris, ggplot2::aes(Species, Sepal.Length)) + ggplot2::geom_bar()
-  ")
+  ev <- evaluate(function() {
+    ggplot2::ggplot(iris, ggplot2::aes(Species, Sepal.Length)) + 
+      ggplot2::geom_bar()
+  })
   expect_output_types(ev, c("source", "error"))
 })
 
 test_that("multirow graphics are captured only when complete", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     par(mfrow = c(1, 2))
     plot(1)
     plot(2)
-  ")
+  })
   expect_output_types(ev, c("source", "source", "source", "plot"))
 })
 
 test_that("multirow graphics are captured on close even if not complete", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     par(mfrow = c(1, 2))
     plot(1)
-  ")
+  })
   expect_output_types(ev, c("source", "source", "plot"))
 
   # Even if there's a comment at the end
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     par(mfrow = c(1, 2))
     plot(1)
     # comment
-  ")
+  })
   expect_output_types(ev, c("source", "source", "source", "plot"))
 })
 
 test_that("plots are captured in a non-rectangular layout", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     for (j in 1:3) {
       layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE))
       plot(rnorm(10))
       plot(rnorm(10))
       plot(rnorm(10))
       plot(rnorm(10))
     }
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "plot", "plot"))
 
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE))
     # another expression before drawing the plots
     x <- 1 + 1
@@ -119,42 +121,42 @@ test_that("plots are captured in a non-rectangular layout", {
       plot(rnorm(10))
       plot(rnorm(10))
     }
-  ")
+  })
   expect_output_types(ev, rep(c("source", "plot"), c(4, 2)))
 })
 
 test_that("changes in parameters don't generate new plots", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     plot(1)
     par(mar = rep(0, 4))
     plot(2)
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "source", "source", "plot"))
 })
 
 test_that("multiple plots are captured even if calls in DL are the same", {
-  ev <- evaluate_('
+  ev <- evaluate(function() {
     barplot(1)
     barplot(2); barplot(3)
-  ')
+  })
   expect_output_types(ev, c("source", "plot", "source", "plot", "plot"))
 })
 
 test_that("strwidth()/strheight() should not produce new plots", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     x <- strwidth('foo', 'inches')
     y <- strheight('foo', 'inches')
     plot(1)
-  ")
+  })
   expect_output_types(ev, c("source", "source", "source", "plot"))
 })
 
 test_that("clip() does not produce new plots", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     plot(1)
     clip(-1, 1, -1, 1)
     points(1, col = 'red')
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "source", "source", "plot"))
 })
 
@@ -165,11 +167,11 @@ test_that("perspective plots are captured", {
   z <- outer(x, y, ff)
   z[is.na(z)] <- 1
 
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     for (i in 1:3) {
       persp(x, y, z, phi = 30 + i * 10, theta = 30)
     }
-  ")
+  })
   expect_output_types(ev, c("source", "plot", "plot", "plot"))
 })
 
@@ -211,11 +213,11 @@ test_that("evaluate restores existing plot", {
 })
 
 test_that("evaluate ignores plots created in new device", {
-  ev <- evaluate_("
+  ev <- evaluate(function() {
     pdf(NULL)
     plot(1)
     invisible(dev.off())
     plot(1)
-  ")
+  })
   expect_output_types(ev, c("source", "source", "source", "source", "plot"))
 })