Keeps last value of eval_code()/within()

NEWS.md

@@ -1,5 +1,9 @@
 # teal.code 0.6.1.9002
 
+### Enhancements
+
+* Code evaluation keeps the last evaluated expression in the `.Last.value` attribute of the environment.
+
 ### Bug fixes
 
 * Fix a problem detecting co-occurrences when expression has multiple lines.

R/qenv-eval_code.R

@@ -9,9 +9,12 @@
 #' @param code (`character`, `language` or `expression`) code to evaluate.
 #' It is possible to preserve original formatting of the `code` by providing a `character` or an
 #' `expression` being a result of `parse(keep.source = TRUE)`.
+#' @param ... ([`dots`]) additional arguments passed to future methods.
 #'
 #' @return
 #' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
+#' The environment contains an attribute called `".Last.value"` which is the last evaluated value,
+#' similarly to [base::.Last.value].
 #'
 #' @examples
 #' # evaluate code in qenv
@@ -21,15 +24,28 @@
 #' q <- eval_code(q, quote(library(checkmate)))
 #' q <- eval_code(q, expression(assert_number(a)))
 #'
-#' @aliases eval_code,qenv,character-method
-#' @aliases eval_code,qenv,language-method
-#' @aliases eval_code,qenv,expression-method
-#' @aliases eval_code,qenv.error,ANY-method
-#'
+#' @aliases eval_code,qenv-method
+#' @aliases eval_code,qenv.error-method
+#' @seealso [within.qenv]
 #' @export
-setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
+setGeneric("eval_code", function(object, code, ...) standardGeneric("eval_code"))
+
+setMethod("eval_code", signature = c(object = "qenv"), function(object, code, ...) {
+  if (!is.language(code) && !is.character(code)) {
+    stop("eval_code accepts code being language or character")
+  }
+  code <- .preprocess_code(code)
+  # preprocess code to ensure it is a character vector
+  .eval_code(object = object, code = code, ...)
+})
+
+setMethod("eval_code", signature = c(object = "qenv.error"), function(object, code, ...) object)
 
-setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
+#' @keywords internal
+.eval_code <- function(object, code, ...) {
+  if (identical(code, "")) {
+    return(object)
+  }
   parsed_code <- parse(text = code, keep.source = TRUE)
   [email protected] <- rlang::env_clone([email protected], parent = parent.env(.GlobalEnv))
   if (length(parsed_code) == 0) {
@@ -42,13 +58,13 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
   for (i in seq_along(code_split)) {
     current_code <- code_split[[i]]
     current_call <- parse(text = current_code, keep.source = TRUE)
-
     # Using withCallingHandlers to capture warnings and messages.
     # Using tryCatch to capture the error and abort further evaluation.
     x <- withCallingHandlers(
       tryCatch(
         {
-          eval(current_call, envir = [email protected])
+          .Last.value <- eval(current_call, envir = [email protected])
+          attr([email protected], ".Last.value") <- .Last.value
           if (!identical(parent.env([email protected]), parent.env(.GlobalEnv))) {
             # needed to make sure that @.xData is always a sibling of .GlobalEnv
             # could be changed when any new package is added to search path (through library or require call)
@@ -60,7 +76,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
           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"),
@@ -69,11 +85,11 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
         }
       ),
       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")
       }
     )
@@ -87,42 +103,17 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
 
   lockEnvironment([email protected], bindings = TRUE)
   object
-})
-
-setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
-  eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
-})
+}
 
-setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
-  srcref <- attr(code, "wholeSrcref")
-  if (length(srcref)) {
-    eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
+setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code"))
+setMethod(".preprocess_code", signature = c("character"), function(code) paste(code, collapse = "\n"))
+setMethod(".preprocess_code", signature = c("ANY"), function(code) {
+  if (is.expression(code) && length(attr(code, "wholeSrcref"))) {
+    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)
+    paste(
+      vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)),
+      collapse = "\n"
+    )
   }
 })
-
-setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
-  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)))
-}

R/qenv-within.R

@@ -1,9 +1,11 @@
-#' @details
-#' `within()` is a convenience method that wraps `eval_code` to provide a simplified way of passing expression.
+#' Evaluate code in `qenv`
+#'
+#' @description Convenience method that wraps [eval_code()] to provide a simplified way of passing expression.
+#'
 #' `within` accepts only inline expressions (both simple and compound) and allows to substitute `expr`
 #' with `...` named argument values.
 #'
-#' @section Using language objects with `within`:
+#' # Using language objects with `within`:
 #' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
 #' Only single `expression`s will work and substitution is not available. See examples.
 #'
@@ -43,25 +45,18 @@
 #' within(q, exprlist) # fails
 #' do.call(within, list(q, do.call(c, exprlist)))
 #'
-#' @rdname eval_code
-#'
 #' @export
 #'
 within.qenv <- function(data, expr, ...) {
-  expr <- substitute(expr)
+  expr <- as.expression(substitute(expr))
   extras <- list(...)
 
-  # Add braces for consistency.
-  if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
-    expr <- call("{", expr)
-  }
-
-  calls <- as.list(expr)[-1]
-
   # Inject extra values into expressions.
-  calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))
-
-  eval_code(object = data, code = as.expression(calls))
+  calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras)))
+  do.call(
+    eval_code,
+    utils::modifyList(extras, list(object = data, code = as.expression(calls)))
+  )
 }
 
 

tests/testthat/test-qenv_eval_code.R

@@ -45,6 +45,11 @@ testthat::test_that("eval_code works with expression", {
   testthat::expect_equal(q1, list2env(list(a = 1, b = 2)))
 })
 
+testthat::test_that("eval_code ignores empty code", {
+  q <- qenv()
+  testthat::expect_identical(q, eval_code(q, ""))
+})
+
 testthat::test_that("eval_code preserves original formatting when `srcref` is present in the expression", {
   code <- "# comment
   a <- 1L"
@@ -77,12 +82,11 @@ testthat::test_that("eval_code works with quoted code block", {
   testthat::expect_equal(q1, list2env(list(a = 1, b = 2)))
 })
 
-testthat::test_that("eval_code fails with unquoted expression", {
-  b <- 3
-  testthat::expect_error(
-    eval_code(qenv(), a <- b),
-    "unable to find an inherited method for function .eval_code. for signature"
-  )
+testthat::test_that("eval_code fails with code not being language nor character", {
+  msg <- "eval_code accepts code being language or character"
+  testthat::expect_error(eval_code(qenv(), NULL), msg)
+  testthat::expect_error(eval_code(qenv(), 1), msg)
+  testthat::expect_error(eval_code(qenv(), list()), msg)
 })
 
 testthat::test_that("an error when calling eval_code returns a qenv.error object which has message and trace", {
@@ -183,7 +187,9 @@ testthat::test_that("comments passed alone to eval_code that contain @linksto ta
   )
 })
 
-testthat::test_that("Code executed with integer shorthand (1L) is the same as original", {
-  q <- within(qenv(), a <- 1L)
-  testthat::expect_identical(get_code(q), "a <- 1L")
+testthat::test_that("eval_code keeps .Last.value as an attribute of the environment", {
+  q <- eval_code(qenv(), quote(x <- 1))
+  env <- as.environment(q)
+  testthat::expect_true(".Last.value" %in% names(attributes(env)))
+  testthat::expect_equal(attr(env, ".Last.value"), 1)
 })