close #65: add an argument allow_error in parse_all() so evaluate() d…

…oes not have to stop on syntactical errors in source code

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: evaluate
 Type: Package
 Title: Parsing and Evaluation Tools that Provide More Details than the Default
-Version: 0.8.3
+Version: 0.8.4
 Date: 2016-03-04
 Authors@R: c(
     person("Hadley", "Wickham", role = "aut"),

NEWS

@@ -1,3 +1,12 @@
+Version 0.9
+------------------------------------------------------------------------------
+
+* Added an argument `allow_error` to `parse_all()` to allow syntactical errors
+  in R source code when `allow_error = TRUE`; this means `evaluate(stop_on_error
+  = 0 or 1)` will no longer stop on syntactical errors but returns a list of
+  source code and the error object instead. This can be useful to show
+  syntactical errors for pedagogical purposes.
+
 Version 0.8.3
 ------------------------------------------------------------------------------
 

R/eval.r

@@ -33,11 +33,18 @@ evaluate <- function(input, envir = parent.frame(), enclos = NULL, debug = FALSE
                      stop_on_error = 0L, keep_warning = TRUE, keep_message = TRUE,
                      new_device = TRUE, output_handler = default_output_handler,
                      filename = NULL) {
-  parsed <- parse_all(input, filename)
-
   stop_on_error <- as.integer(stop_on_error)
   stopifnot(length(stop_on_error) == 1)
 
+  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)
+    output_handler$error(err)
+    err$call <- NULL  # the call is unlikely to be useful
+    return(list(source, err))
+  }
+
   if (is.null(enclos)) {
     enclos <- if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv()
   }

R/parse.r

@@ -3,16 +3,18 @@
 #' Works very similarly to parse, but also keeps original formatting and
 #' comments.
 #'
-#' @param x object to parse.  Can be a string, a file connection, or a
-#'   function
+#' @param x object to parse.  Can be a string, a file connection, or a function
 #' @param filename string overriding the file name
-#' @return a data.frame with columns \code{src}, the source code, and
-#'   \code{expr}
+#' @param allow_error whether to allow syntax errors in \code{x}
+#' @return A data.frame with columns \code{src}, the source code, and
+#'   \code{expr}. If there are syntax errors in \code{x} and \code{allow_error =
+#'   TRUE}, the data frame has an attribute \code{PARSE_ERROR} that stores the
+#'   error object.
 #' @export
-parse_all <- function(x, filename = NULL) UseMethod("parse_all")
+parse_all <- function(x, filename = NULL, allow_error = FALSE) UseMethod("parse_all")
 
 #' @export
-parse_all.character <- function(x, filename = NULL) {
+parse_all.character <- function(x, filename = NULL, allow_error = FALSE) {
 
   # Do not convert strings to factors by default in data.frame()
   op <- options(stringsAsFactors = FALSE)
@@ -25,7 +27,15 @@ parse_all.character <- function(x, filename = NULL) {
   if (is.null(filename))
     filename <- "<text>"
   src <- srcfilecopy(filename, x)
-  exprs <- parse(text = x, srcfile = src)
+  if (allow_error) {
+    exprs <- tryCatch(parse(text = x, srcfile = src), error = identity)
+    if (inherits(exprs, 'error')) return(structure(
+      data.frame(src = paste(x, collapse = '\n'), expr = I(list(expression()))),
+      PARSE_ERROR = exprs
+    ))
+  } else {
+    exprs <- parse(text = x, srcfile = src)
+  }
 
   # No code, only comments and/or empty lines
   ne <- length(exprs)
@@ -112,19 +122,19 @@ if (getRversion() <= '3.2.2') srcfilecopy <- function(filename, lines, ...) {
 }
 
 #' @export
-parse_all.connection <- function(x, filename = NULL) {
+parse_all.connection <- function(x, filename = NULL, ...) {
   if (!isOpen(x, "r")) {
       open(x, "r")
       on.exit(close(x))
   }
   text <- readLines(x)
   if (is.null(filename))
     filename <- summary(x)$description
-  parse_all(text, filename)
+  parse_all(text, filename, ...)
 }
 
 #' @export
-parse_all.function <- function(x, filename = NULL) {
+parse_all.function <- function(x, filename = NULL, ...) {
   src <- attr(x, "srcref", exact = TRUE)
   if (is.null(src)) {
     src <- deparse(body(x))
@@ -133,30 +143,30 @@ parse_all.function <- function(x, filename = NULL) {
     if (n >= 2) src <- src[-c(1, n)]
     if (is.null(filename))
       filename <- "<function>"
-    parse_all(src, filename)
+    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)
+        parse_all(unlist(lapply(src2[-1], as.character)), filename, ...)
       } else  {
         # f <- function(...) {}
-        parse_all(character(0), filename)
+        parse_all(character(0), filename, ...)
       }
     } else {
       if (is.null(filename))
         filename <- "<function>"
-      parse_all(deparse(body(x)), filename)
+      parse_all(deparse(body(x)), filename, ...)
     }
   }
 }
 
 #' @export
-parse_all.default <- function(x, filename = NULL) {
+parse_all.default <- function(x, filename = NULL, ...) {
   if (is.null(filename))
     filename <- "<expression>"
-  parse_all(deparse(x), filename)
+  parse_all(deparse(x), filename, ...)
 }

tests/test-parse.R

@@ -0,0 +1,4 @@
+library(evaluate)
+
+# this should not signal an error
+evaluate('x <-', stop_on_error = 0)

tests/testthat/test-parse.r

@@ -13,6 +13,12 @@ test_that("{ not removed", {
 
 })
 
+test_that("parse(allow_error = TRUE/FALSE)", {
+  expect_error(parse_all('x <-', allow_error = FALSE))
+  res <- parse_all('x <-', allow_error = TRUE)
+  expect_true(inherits(attr(res, 'PARSE_ERROR'), 'error'))
+})
+
 # test some multibyte characters when the locale is UTF8 based
 if (identical(Sys.getlocale("LC_CTYPE"), "en_US.UTF-8")) {