Merge pull request #533 from cynkra/b-526-fix-reticulate

fix environment issues re names and topenv

Author: aviator-app[bot]

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: constructive
 Title: Display Idiomatic Code to Construct Most R Objects
-Version: 1.1.0
+Version: 1.1.0.9000
 Authors@R: c(
     person("Antoine", "Fabri", , "[email protected]", role = c("aut", "cre")),
     person("Kirill", "Müller", , "[email protected]", role = "ctb",

NEWS.md

@@ -1,3 +1,5 @@
+# constructive (development version)
+
 # constructive 1.1.0
 
 Features:

R/contains_self_reference.R

@@ -16,8 +16,10 @@ contains_self_reference <- function(
     address <- rlang::obj_address(x)
     if (address %in% envs) return(TRUE)
     envs <- c(envs, address)
+    # since we override S3 dispatch here we can circumvent rlang bug
+    # https://github.com/r-lib/rlang/issues/1783
     bindings <- names(x)
-    lazy_bindings <- bindings[rlang::env_binding_are_lazy(x)]
+    lazy_bindings <- bindings[rlang::env_binding_are_lazy(x, bindings)]
     lazy_binding_envs <- lapply(lazy_bindings, promise_env, x)
     for (lazy_binding_env in lazy_binding_envs) {
       if (rec(lazy_binding_env)) return(TRUE)

R/environment_utils.R

@@ -30,6 +30,15 @@ construct_special_env <- function(x) {
   }
 }
 
+construct_top_env <- function(x) {
+  repeat {
+    code <- construct_special_env(x)
+    if (!is.null(code)) break
+    x <- parent.env(x)
+  }
+  code
+}
+
 env_memory_address <- function(x, by_name = FALSE) {
   if (identical(Sys.getenv("TESTTHAT"), "true")) return("0x123456789")
   if (by_name) rlang::env_label(x) else rlang::obj_address(x)
@@ -159,7 +168,10 @@ update_predefinition <- function(envir, ...) {
 }
 
 apply_env_locks <- function(x, code, ...) {
-  locked_bindings <- rlang::env_binding_are_locked(x)
+  # since we override S3 dispatch here we can circumvent rlang bug
+  # https://github.com/r-lib/rlang/issues/1783
+  bindings <- names(x)
+  locked_bindings <- rlang::env_binding_are_locked(x, bindings)
   if (environmentIsLocked(x)) {
     if (length(locked_bindings) && all(locked_bindings)) {
       rhs <- c(

R/s3-environment.R

@@ -44,7 +44,9 @@
 #'   its memory address.
 #' * `"list2env"`: We construct the environment as a list then
 #'   use `base::list2env()` to convert it to an environment and assign it a parent. By
-#'   default we will use `base::topenv()` to construct a parent. If `recurse` is `TRUE`
+#'   default we use as a parent the first special environment we find when going
+#'   through ancestors, so we can print code that doesn't use `.env()`.
+#'   If `recurse` is `TRUE`
 #'   the parent will be built recursively so all ancestors will be created until
 #'   we meet a known environment, this might be verbose and will fail if environments
 #'   are nested too deep or have a circular relationship. If the environment is empty we use `new.env(parent=)`
@@ -156,12 +158,19 @@ is_corrupted_environment <- function(x) {
   }
 
   if (!opts$recurse) {
+    parent_code <- construct_top_env(parent.env(x))
     if (length(names(x))) {
-      code <- .cstr_apply(list(env2list(x), parent = topenv(x)), "list2env", ...)
+      list_code <- .cstr_construct(env2list(x), ...)
+      code <- .cstr_apply(
+        list(list_code, parent = parent_code),
+        "list2env",
+        ...,
+        recurse = FALSE
+      )
       code <- apply_env_locks(x, code, ...)
       return(repair_attributes_environment(x, code, ...))
     }
-    code <- .cstr_apply(list(parent = topenv(x)), "new.env", ...)
+    code <- .cstr_apply(list(parent = parent_code), "new.env", ..., recurse = FALSE)
     code <- apply_env_locks(x, code, ...)
     return(repair_attributes_environment(x, code, ...))
   }
@@ -195,12 +204,19 @@ is_corrupted_environment <- function(x) {
     abort_self_reference()
   }
   if (!opts$recurse) {
+    parent_code <- construct_top_env(parent.env(x))
     if (length(names(x))) {
-      code <- .cstr_apply(list(env2list(x), parent = topenv(x)), "rlang::new_environment", ...)
+      list_code <- .cstr_construct(env2list(x), ...)
+      code <- .cstr_apply(
+        list(list_code, parent = parent_code),
+        "rlang::new_environment",
+        ...,
+        recurse = FALSE
+      )
       code <- apply_env_locks(x, code)
       return(repair_attributes_environment(x, code, ...))
     }
-    code <- .cstr_apply(list(parent = topenv(x)), "rlang::new_environment", ...)
+    code <- .cstr_apply(list(parent = parent_code), "rlang::new_environment", ...)
     code <- apply_env_locks(x, code)
     return(repair_attributes_environment(x, code, ...))
   }

man/opts_environment.Rd

@@ -26,11 +26,8 @@
       asNamespace("stats")
     Code
       construct(as.environment(head(cars, 2)), opts_environment("list2env"))
-    Message
-      {constructive} couldn't create code that reproduces perfectly the input
-      i Call `construct_issues()` to inspect the last issues
     Output
-      list2env(list(dist = c(2, 10), speed = c(4, 4)), parent = .GlobalEnv)
+      list2env(list(dist = c(2, 10), speed = c(4, 4)), parent = emptyenv())
     Code
       construct(as.environment(head(cars, 2)), opts_environment(constructor = "new.env"))
     Message
@@ -213,3 +210,11 @@
     Output
       parent.env(asNamespace("stats"))
 
+# environments with names method are constructed properly
+
+    Code
+      construct(env, opts_environment("list2env"), check = FALSE)
+    Output
+      list2env(list(x = 1), parent = asNamespace("constructive")) |>
+        structure(class = "foo")
+

tests/testthat/_snaps/s3-environment.md

@@ -71,3 +71,16 @@ test_that("environment", {
     construct(parent.env(asNamespace("stats")))
   })
 })
+
+test_that("environments with names method are constructed properly", {
+  env <- new.env()
+  env$x <- 1
+  class(env) <- "foo"
+  names.foo <- function(x) "y"
+  expect_snapshot({
+    construct(env, opts_environment("list2env"), check = FALSE)
+  })
+})
+
+
+