cleanup: remove method from eval_code and removal of unecessary functions

Author: averissimo

R/qenv-eval_code.R

@@ -32,8 +32,29 @@
 #' @export
 setGeneric("eval_code", function(object, code, cache = FALSE, ...) standardGeneric("eval_code"))
 
-setMethod("eval_code", signature = c("qenv"), function(object, code, cache = FALSE, ...) {
+setMethod("eval_code", signature = c(object = "qenv", code = "ANY"), function(object, code, cache = FALSE, ...) {
   code <- .preprocess_code(code) # preprocess code to ensure it is a character vector
+  srcref <- attr(code, "wholeSrcref")
+  if (is.expression(code) && length(srcref) == 0L) {
+    result <- Reduce(function(u, v) {
+      if (inherits(v, "=") && identical(typeof(v), "language")) {
+        # typeof(`=`) is language, but it doesn't dispatch on it, so we need to
+        # explicitly pass it as first class of the object
+        class(v) <- unique(c("language", class(v)))
+      }
+      .eval_code(u, v, cache = FALSE, ...)
+    }, init = object, x = code)
+    return(result)
+  } else if (is.expression(code)) {
+    code <- paste(attr(code, "wholeSrcref"), collapse = "\n")
+  }
+  .eval_code(object = object, code = code, cache = cache, ...)
+})
+
+setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code, cache = FALSE, ...) object)
+
+#' @keywords internal
+.eval_code <- function(object, code, cache = FALSE, ...) {
   parsed_code <- parse(text = code, keep.source = TRUE)
   object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
   if (length(parsed_code) == 0) {
@@ -66,7 +87,7 @@ setMethod("eval_code", signature = c("qenv"), function(object, code, cache = FAL
           errorCondition(
             message = sprintf(
               "%s \n when evaluating qenv code:\n%s",
-              .ansi_strip(conditionMessage(e)),
+              cli::ansi_strip(conditionMessage(e)),
               current_code
             ),
             class = c("qenv.error", "try-error", "simpleError"),
@@ -75,11 +96,11 @@ setMethod("eval_code", signature = c("qenv"), function(object, code, cache = FAL
         }
       ),
       warning = function(w) {
-        attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
+        attr(current_code, "warning") <<- cli::ansi_strip(sprintf("> %s\n", conditionMessage(w)))
         invokeRestart("muffleWarning")
       },
       message = function(m) {
-        attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
+        attr(current_code, "message") <<- cli::ansi_strip(sprintf("> %s", conditionMessage(m)))
         invokeRestart("muffleMessage")
       }
     )
@@ -93,49 +114,10 @@ setMethod("eval_code", signature = c("qenv"), function(object, code, cache = FAL
 
   lockEnvironment(object@.xData, bindings = TRUE)
   object
-})
-
-
-setMethod("eval_code", signature = c("qenv", "expression"), function(object, code, cache = FALSE, ...) {
-  srcref <- attr(code, "wholeSrcref")
-  if (length(srcref)) {
-    eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
-  } else {
-    Reduce(function(u, v) {
-      if (inherits(v, "=") && identical(typeof(v), "language")) {
-        # typeof(`=`) is language, but it doesn't dispatch on it, so we need to
-        # explicitly pass it as first class of the object
-        class(v) <- unique(c("language", class(v)))
-      }
-      eval_code(u, v)
-    }, init = object, x = code)
-  }
-})
+}
 
 setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code"))
-
-setMethod(".preprocess_code", signature = c("ANY"), function(code) {
-  as.character(code)
-})
-
+setMethod(".preprocess_code", signature = c("ANY"), function(code) as.character(code))
 setMethod(".preprocess_code", signature = c("language"), function(code) {
   paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)))
 })
-
-setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code, cache = FALSE, ...) {
-  object
-})
-
-# if cli is installed rlang adds terminal printing characters
-# which need to be removed
-.ansi_strip <- function(chr) {
-  if (requireNamespace("cli", quietly = TRUE)) {
-    cli::ansi_strip(chr)
-  } else {
-    chr
-  }
-}
-
-get_code_attr <- function(qenv, attr) {
-  unlist(lapply(qenv@code, function(x) attr(x, attr)))
-}

tests/testthat/test-qenv_join.R

@@ -131,7 +131,7 @@ testthat::test_that("Joining two independent qenvs with warnings results in obje
   q <- c(q1, q2)
 
   testthat::expect_equal(
-    unname(get_code_attr(q, "warning")),
+    vapply(q@code, attr, which = "warning", character(1L), USE.NAMES = FALSE),
     c(
       "> This is warning 1\n",
       "> This is warning 2\n"
@@ -146,7 +146,7 @@ testthat::test_that("Joining two independent qenvs with messages results in obje
   q <- c(q1, q2)
 
   testthat::expect_equal(
-    unname(get_code_attr(q, "message")),
+    vapply(q@code, attr, which = "message", character(1L), USE.NAMES = FALSE),
     c(
       "> This is message 1\n",
       "> This is message 2\n"