Fix compatibility with dev rlang

R/add_trace_back.R

@@ -23,11 +23,6 @@ winch_add_trace_back <- function(trace = rlang::trace_back(bottom = parent.frame
     return(trace)
   }
 
-  # Check for trace version
-  if (!identical(attr(trace, "version"), 1L)) {
-    return(trace)
-  }
-
   # Avoid recursion
   old_options <- options(rlang_trace_use_winch = NULL)
   on.exit(options(old_options))
@@ -137,6 +132,81 @@ find_calls <- function(x) {
 }
 
 insert_native_chunk <- function(trace, idx, native) {
+  # Check for trace version
+  if (identical(attr(trace, "version"), 1L)) {
+    # pre 1.0.0
+    return(insert_native_chunk_0(trace, idx, native))
+  }
+
+  added_namespaces <- paste0("/", basename(native$pathname))
+  added_calls <- lapply(native$func, function(func) call(func))
+
+  old_size <- length(trace$call)
+  new_size <- old_size + length(added_calls)
+  if (old_size == new_size) {
+    # Nothing to do
+    return(native)
+  }
+
+  # Prepare for pasting
+  added_idx <- seq.int(idx + 1L, length.out = length(added_calls))
+  added_parents <- lag(added_idx, default = idx)
+  rechain_idx <- added_idx[[length(added_idx)]]
+
+  # Create translation table
+  xlat <- c(
+    seq_len(idx),
+    seq.int(idx + length(added_calls) + 1L, length.out = old_size - idx)
+  )
+  xlat1 <- c(0L, xlat)
+
+  # Move
+  new_parents <- rep(-1L, new_size)
+  new_parents[xlat] <- xlat1[trace$parent + 1L]
+
+  new_calls <- rep(NULL, new_size)
+  new_calls[xlat] <- trace$call
+
+  new_visible <- rep(TRUE, new_size)
+  new_visible[xlat] <- trace$visible
+
+  new_namespace <- rep(NA_character_, new_size)
+  new_namespace[xlat] <- trace$namespace
+
+  new_scope <- rep(NA_character_, new_size)
+  new_scope[xlat] <- trace$scope
+
+  new_idx <- seq_len(new_size)
+
+  # Rechain existing
+  parents_fix_idx <- (new_parents == idx)
+  grandparents_fix_idx <- (new_parents == new_parents[[idx]] & seq_along(new_parents) > idx)
+  new_parents[parents_fix_idx | grandparents_fix_idx] <- rechain_idx
+
+  # Paste (after rechaining!)
+  new_parents[added_idx] <- added_parents
+  new_calls[added_idx] <- added_calls
+  new_namespace[added_idx] <- added_namespaces
+  new_scope[added_idx] <- "::"
+
+  # Use new
+  new <- data.frame(
+    call = new_parents, parent = new_parents,
+    visible = new_visible, namespace = new_namespace, scope = new_scope,
+    stringsAsFactors = FALSE
+  )
+  # Can't pass in constructor
+  new$call <- new_calls
+
+  # Clumsy way of replacing the contents of `trace` without touching the attributes
+  new_idx <- seq_len(nrow(new))
+  trace[new_idx, ] <- trace[new_idx, ]
+  trace[] <- new
+
+  trace
+}
+
+insert_native_chunk_0 <- function(trace, idx, native) {
   added_calls <- Map(
     basename(native$pathname),
     native$func,

tests/testthat/_snaps/add_trace_back.md

@@ -0,0 +1,19 @@
+# traceback changed if native code
+
+    Code
+      foo_baz
+    Output
+          x
+       1. \-winch foo(baz) at test-add_trace_back.R:25:2
+       2.   +-winch::winch_call(fun) at test-add_trace_back.R:13:4
+       3.   \-winch `<fn>`()
+       4.     \-`/winch.so`::winch_call()
+    Code
+      as.data.frame(foo_baz)
+    Output
+                   call parent visible namespace scope
+      1        foo(baz)      0    TRUE     winch local
+      2 winch_call(fun)      1    TRUE     winch    ::
+      3        `<fn>`()      1    TRUE     winch local
+      4    winch_call()      3    TRUE /winch.so    ::
+

tests/testthat/test-add_trace_back.R

@@ -7,6 +7,36 @@ test_that("traceback unchanged if no native code", {
 
 test_that("traceback changed if native code", {
   skip_if_not(winch_available())
+  skip_if_not_installed("rlang", "0.99.0.9000")
+
+  foo <- function(fun) {
+    winch_call(fun)
+  }
+
+  bar <- function() {
+    rlang::trace_back()
+  }
+
+  baz <- function() {
+    winch_add_trace_back(rlang::trace_back())
+  }
+
+  foo_bar <- foo(bar)
+  foo_baz <- foo(baz)
+
+  expect_false(identical(foo_bar, foo_baz))
+  expect_true(any(grepl("/winch", foo_baz$namespace)))
+
+  expect_snapshot({
+    foo_baz
+    as.data.frame(foo_baz)
+  })
+})
+
+
+test_that("traceback changed if native code (rlang < 1.0.0)", {
+  skip_if_not(winch_available())
+  skip_if(packageVersion("rlang") > "0.99")
 
   foo <- function(fun) {
     winch_call(fun)