Compare unnamed environments by value (#133)

Fixes #127. Fixes #117.

NEWS.md

@@ -1,5 +1,11 @@
 # waldo (development version)
 
+* Unnamed environments now compare by value, not by reference (i.e. if 
+  two environments contain the same values, they compare the same, even
+  if they're different environments) (#127). Environments that contain
+  self-references are handled correctly (#117). Differences between pairs 
+  of environments are only ever reported once.
+
 * Atomic S3 classes with format methods now use those methods when 
   displaying comparisons (#98). If the printed representation is the
   same, they fallback to displaying the underlying data.

R/compare-opts.R

@@ -11,6 +11,9 @@ compare_opts <- function(...,
 
   base <- old_opts(...)
 
+  seen <- new.env(parent = emptyenv())
+  seen$envs <- list()
+
   waldo <- list(
     tolerance = tolerance,
     max_diffs = max_diffs,
@@ -19,7 +22,8 @@ compare_opts <- function(...,
     ignore_encoding = ignore_encoding,
     ignore_function_env = ignore_function_env,
     ignore_formula_env = ignore_formula_env,
-    list_as_map = list_as_map
+    list_as_map = list_as_map,
+    seen = seen
   )
 
   utils::modifyList(waldo, base)

R/compare.R

@@ -235,20 +235,32 @@ compare_structure <- function(x, y, paths = c("x", "y"), opts = compare_opts())
     }
 
   } else if (is_environment(x)) {
-    if (env_has(x, ".__enclos_env__")) {
-      # enclosing env of methods is object env
-      opts$ignore_function_env <- TRUE
-      x_fields <- as.list(x)
-      y_fields <- as.list(y)
-      x_fields$.__enclos_env__ <- NULL
-      y_fields$.__enclos_env__ <- NULL
+    if (is_seen(list(x, y), opts$seen$envs)) {
+      # Only report difference between pairs of environments once
+      return(out)
+    } else if (is_named_env(x) || is_named_env(y)) {
+      # Compare by reference
+      out <- c(out, should_be("<env:{env_label(x)}>", "<env:{env_label(y)}>"))
+    } else {
+      # Compare by value
+      x_fields <- as.list(x, all.names = TRUE)
+      y_fields <- as.list(y, all.names = TRUE)
       # Can't use as.list(sorted = TRUE), https://github.com/r-lib/waldo/issues/84
-      x_fields <- x_fields[order(names(x_fields))]
-      y_fields <- y_fields[order(names(y_fields))]
+      if (length(x_fields) > 0) x_fields <- x_fields[order(names(x_fields))]
+      if (length(y_fields) > 0) y_fields <- y_fields[order(names(y_fields))]
+
+      if (env_has(x, ".__enclos_env__")) {
+        # enclosing env of R6 methods is object env
+        opts$ignore_function_env <- TRUE
+        x_fields$.__enclos_env__ <- NULL
+        y_fields$.__enclos_env__ <- NULL
+      }
 
+      opts$seen$envs <- c(opts$seen$envs, list(list(x, y)))
       out <- c(out, compare_structure(x_fields, y_fields, paths, opts = opts))
-    } else {
-      out <- c(out, should_be("<env:{env_label(x)}>", "<env:{env_label(y)}>"))
+      out <- c(out, compare_structure(
+        parent.env(x), parent.env(y), paste0("parent.env(", paths, ")"), opts = opts)
+      )
     }
   } else if (is_closure(x)) {
     if (opts$ignore_function_env) {
@@ -301,6 +313,18 @@ compare_structure <- function(x, y, paths = c("x", "y"), opts = compare_opts())
   out
 }
 
+is_named_env <- function(x) {
+  environmentName(x) != ""
+}
+is_seen <- function(x, envs) {
+  for (env in envs) {
+    if (identical(x, env)) {
+      return(TRUE)
+    }
+  }
+  FALSE
+}
+
 # Fast path for "identical" elements - in the long run we'd eliminate this
 # by re-writing all of waldo in C, but this gives us a nice performance boost
 # with for a relatively low cost in the meantime.

R/utils.R

@@ -173,3 +173,7 @@ as_map <- function(x) {
 
   x
 }
+
+scrub_environment <- function(x) {
+  gsub("<env:0x[0-9a-f]+>", "<env: 0x********>", x)
+}

tests/testthat/_snaps/compare.md

@@ -543,6 +543,94 @@
     Output
       v No differences
 
+# Named environments compare by reference
+
+    Code
+      compare(baseenv(), globalenv())
+    Output
+      `old` is <env:package:base>
+      `new` is <env:global>
+    Code
+      compare(baseenv(), new.env())
+    Output
+      `old` is <env:package:base>
+      `new` is <env: 0x********>
+    Code
+      compare(new.env(), baseenv())
+    Output
+      `old` is <env: 0x********>
+      `new` is <env:package:base>
+
+# unnamed arguments compare by value
+
+    Code
+      e1 <- new.env(parent = emptyenv())
+      e2 <- new.env(parent = emptyenv())
+      compare(e1, e2)
+    Output
+      v No differences
+    Code
+      e1$x <- 10
+      e2$x <- 11
+      compare(e1, e2)
+    Output
+      `old$x`: 10
+      `new$x`: 11
+    Code
+      e2$x <- 10
+      compare(e1, e2)
+    Output
+      v No differences
+
+# compares parent envs
+
+    Code
+      e1 <- new.env(parent = emptyenv())
+      e1$x <- 1
+      e2 <- new.env(parent = emptyenv())
+      e2$x <- 2
+      e3 <- new.env(parent = e1)
+      e4 <- new.env(parent = e2)
+      compare(e3, e4)
+    Output
+      `parent.env(old)$x`: 1
+      `parent.env(new)$x`: 2
+
+# don't get caught in endless loops
+
+    Code
+      e1 <- new.env(parent = emptyenv())
+      e2 <- new.env(parent = emptyenv())
+      e1$x <- 10
+      e1$y <- e1
+      e2$x <- 10
+      e2$y <- e1
+      compare(e1, e2)
+    Output
+      v No differences
+    Code
+      e2$y <- e2
+      compare(e1, e2)
+    Output
+      v No differences
+
+# only shows paired env different once
+
+    Code
+      e1 <- new.env(parent = emptyenv())
+      e2 <- new.env(parent = emptyenv())
+      e3 <- new.env(parent = emptyenv())
+      e1$x <- 1
+      e2$x <- 2
+      e3$x <- 3
+      compare(list(e1, e1, e1), list(e2, e2, e3))
+    Output
+      `old[[1]]$x`: 1
+      `new[[1]]$x`: 2
+      
+      `old[[3]]$x`: 1
+      `new[[3]]$x`: 3
+
 # can compare CHARSXP
 
     Code

tests/testthat/test-compare.R

@@ -266,6 +266,70 @@ test_that("can compare R6 objects", {
   })
 })
 
+test_that("Named environments compare by reference", {
+  expect_snapshot({
+    compare(baseenv(), globalenv())
+    compare(baseenv(), new.env())
+    compare(new.env(), baseenv())
+  }, transform = scrub_environment)
+})
+test_that("unnamed arguments compare by value", {
+  expect_snapshot({
+    e1 <- new.env(parent = emptyenv())
+    e2 <- new.env(parent = emptyenv())
+    compare(e1, e2)
+
+    e1$x <- 10
+    e2$x <- 11
+    compare(e1, e2)
+
+    e2$x <- 10
+    compare(e1, e2)
+  }, transform = scrub_environment)
+})
+test_that("compares parent envs", {
+  expect_snapshot({
+    e1 <- new.env(parent = emptyenv())
+    e1$x <- 1
+    e2 <- new.env(parent = emptyenv())
+    e2$x <- 2
+
+    e3 <- new.env(parent = e1)
+    e4 <- new.env(parent = e2)
+
+    compare(e3, e4)
+  }, transform = scrub_environment)
+})
+test_that("don't get caught in endless loops", {
+  expect_snapshot({
+    e1 <- new.env(parent = emptyenv())
+    e2 <- new.env(parent = emptyenv())
+
+    e1$x <- 10
+    e1$y <- e1
+
+    e2$x <- 10
+    e2$y <- e1
+
+    compare(e1, e2)
+
+    e2$y <- e2
+    compare(e1, e2)
+  }, transform = scrub_environment)
+})
+test_that("only shows paired env different once", {
+  expect_snapshot({
+    e1 <- new.env(parent = emptyenv())
+    e2 <- new.env(parent = emptyenv())
+    e3 <- new.env(parent = emptyenv())
+    e1$x <- 1
+    e2$x <- 2
+    e3$x <- 3
+
+    compare(list(e1, e1, e1), list(e2, e2, e3))
+  }, transform = scrub_environment)
+})
+
 test_that("can compare CHARSXP", {
   skip_if(interactive())