let qenv, eval_code and get_code work on @code that has length as the number of calls in @code

Author: m7pr

NEWS.md

@@ -4,6 +4,8 @@
 
 * `get_code()` was extended with `names` parameter and allows the code extraction to be limited to objects stored in
 `qenv` but limited to `names`.
+* `eval_code(qenv, code)` analyzes code by single calls and returns `@id`, `@code`, `@messages`, `@warnings` fields of
+the length of calls included in `code`.
 
 # teal.code 0.5.0
 

R/qenv-eval_code.R

@@ -28,18 +28,20 @@
 setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
 
 setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
-  id <- sample.int(.Machine$integer.max, size = 1)
+  parsed_code <- parse(text = code, keep.source = TRUE)
+  comments <- extract_comments(parsed_code)
+  id <- sample.int(.Machine$integer.max, size = length(parsed_code))
 
   object@id <- c(object@id, id)
   object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
-  code <- paste(code, collapse = "\n")
-  object@code <- c(object@code, code)
+  object@code <- c(object@code, trimws(paste(as.character(parsed_code), comments)))
 
-  current_warnings <- ""
-  current_messages <- ""
+  current_warnings <- rep("", length(parsed_code))
+  current_messages <- rep("", length(parsed_code))
 
-  parsed_code <- parse(text = code, keep.source = TRUE)
-  for (single_call in parsed_code) {
+
+  for (i in 1:length(parsed_code)) {
+    single_call <- parsed_code[i]
     # Using withCallingHandlers to capture warnings and messages.
     # Using tryCatch to capture the error and abort further evaluation.
     x <- withCallingHandlers(
@@ -66,11 +68,11 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
         }
       ),
       warning = function(w) {
-        current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
+        current_warnings[i] <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
         invokeRestart("muffleWarning")
       },
       message = function(m) {
-        current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
+        current_messages[i] <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
         invokeRestart("muffleMessage")
       }
     )

R/qenv-get_code.R

@@ -124,11 +124,12 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names
   }
 
   if (deparse) {
-    if (length(code) == 0) {
-      code
-    } else {
-      paste(code, collapse = "\n")
-    }
+    # if (length(code) == 0) {
+    #   code
+    # } else {
+    #   paste(code, collapse = "\n")
+    # }
+    code
   } else {
     parse(text = paste(c("{", code, "}"), collapse = "\n"), keep.source = TRUE)
   }

R/qenv-subset.R

@@ -30,21 +30,18 @@ setMethod("subset", signature = c("qenv"), function(object, names) {
     return(qenv())
   }
 
-  new_qenv <- qenv()
-  new_qenv@env <- list2env(mget(x = names_in_env, envir = get_env(object)))
-  new_qenv@code <- get_code(object, names = names_in_env)
-  # Question: what about @id, @warnings, @messages?
-  # Currently:
-  # > new_qenv@id
-  # integer(0)
-  # > new_qenv@warnings
-  # character(0)
-  # > new_qenv@messages
-  # character(0)
-  new_qenv
+  limited_code <- get_code(object, names = names_in_env)
+  indexes <- which(object@code %in% limited_code)
 
-})
+  object@env <- list2env(mget(x = names_in_env, envir = get_env(object)))
+  object@code <- limited_code
+  object@id <- object@id[indexes]
+  object@warnings <- object@warnings[indexes]
+  object@messages <- object@messages[indexes]
+
+  object
 
+})
 
 setMethod("subset", signature = c("qenv.error", "ANY"), function(object, names) {
   object

R/utils-get_code_dependency.R

@@ -44,6 +44,7 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
   pd <- utils::getParseData(code)
   pd <- normalize_pd(pd)
   calls_pd <- extract_calls(pd)
+  comments <- extract_comments(code)
 
   if (check_names) {
     # Detect if names are actually in code.
@@ -64,7 +65,8 @@ get_code_dependency <- function(code, names, check_names = TRUE) {
 
   lib_ind <- detect_libraries(calls_pd)
 
-  as.character(code[sort(unique(c(lib_ind, ind)))])
+  code_ids <- sort(unique(c(lib_ind, ind)))
+  trimws(paste(as.character(code[code_ids]), comments[code_ids]))
 }
 
 #' Locate function call token
@@ -451,3 +453,22 @@ normalize_pd <- function(pd) {
 
   pd
 }
+
+#' Extract comments from parsed code
+#'
+#' @param parsed_code `expression`, result of `parse()` function
+#'
+#' @return `character` vector of length of `parsed_code` with comments included in `parsed_code`
+#' @keywords internal
+#' @noRd
+extract_comments <- function(parsed_code) {
+  get_comments <- function(call) {
+    comment <- call[call$token == "COMMENT", "text"]
+    if (length(comment) == 0) "" else comment
+  }
+  unlist(lapply(
+    extract_calls(utils::getParseData(parsed_code)),
+    get_comments
+  ))
+}
+