Feature/list viewer 1399

package.json

@@ -1119,7 +1119,7 @@
         {
           "command": "r.workspaceViewer.view",
           "group": "inline",
-          "when": "view == workspaceViewer && viewItem == rootNode"
+          "when": "view == workspaceViewer && (viewItem == rootNode || viewItem == viewableNode)"
         },
         {
           "command": "r.workspaceViewer.remove",

sess/R/handlers.R

@@ -118,6 +118,7 @@ workspace_child_item <- function(object, str, selector) {
     class = paste(class(object), collapse = ", "),
     type = typeof(object),
     has_children = workspace_child_count(object) > 0L,
+    viewable = TRUE,
     selector = selector
   )
 }
@@ -130,72 +131,118 @@ workspace_child_label <- function(name, index) {
   }
 }
 
-get_workspace_children <- function(name, path = list(), start = 1L) {
+handle_workspace_view <- function(name, path = list()) {
+  title <- paste0(c(name, vapply(path, function(selector) switch(selector$kind,
+    index = if (!is.null(selector$name) && !is.na(selector$name) && nzchar(selector$name)) paste0("$", selector$name) else paste0("[[", selector$value, "]]"),
+    name = paste0("$", selector$value),
+    slot = paste0("@", selector$value)
+  ), "")), collapse = "")
+  utils::View(workspace_object(name, path), title = title)
+  TRUE
+}
+
+get_workspace_children <- function(name = NULL, path = list(), start = 1L, view_id = NULL) {
   tryCatch({
-    object <- workspace_object(name, path)
-    child_count <- workspace_child_count(object)
-    if (child_count == 0L) {
-      return(list(children = I(list()), next_start = NULL))
+    if (is.null(view_id)) {
+      object <- workspace_object(name, path)
+      kind <- if (is.environment(object)) "name" else if (isS4(object)) "slot" else "index"
+      child_names <- switch(kind,
+        name = workspace_env_names(object),
+        slot = methods::slotNames(object),
+        index = names(object)
+      )
+    } else {
+      state <- dataview_get_state(view_id)
+      if (!identical(state$type, "list")) stop("Not a list view")
+      object <- state$data
+      kind <- state$kind
+      child_names <- state$names
     }
-
+    child_count <- if (kind == "index") workspace_child_count(object) else length(child_names)
     start <- max(1L, as.integer(start))
     end <- min(child_count, start + workspace_child_page_size - 1L)
     if (start > end) {
       return(list(children = I(list()), next_start = NULL))
     }
 
-    children <- if (is.environment(object)) {
-      child_names <- workspace_env_names(object)[seq.int(start, end)]
-      lapply(child_names, function(child_name) {
-        if (bindingIsActive(child_name, object)) {
-          list(
-            str = paste0("$ ", child_name, ": (active-binding)"),
-            class = "active_binding",
-            type = "active_binding",
-            has_children = FALSE
-          )
+    children <- lapply(seq.int(start, end), function(index) {
+      child_name <- if (is.null(child_names)) NULL else child_names[[index]]
+      label <- if (kind == "slot") {
+        paste0("@ ", child_name)
+      } else {
+        workspace_child_label(child_name, index)
+      }
+      unavailable <- if (kind == "name" && !exists(child_name, envir = object, inherits = FALSE)) {
+        "removed"
+      } else if (kind == "name" && bindingIsActive(child_name, object)) {
+        "active_binding"
+      } else {
+        NULL
+      }
+      if (!is.null(unavailable)) {
+        summary <- if (unavailable == "removed") "(removed)" else "(active-binding)"
+        if (!is.null(view_id)) {
+          return(list(label = label, str = summary, viewable = FALSE, index = index))
+        }
+        return(list(
+          str = paste0(label, ": ", summary), class = unavailable,
+          type = unavailable, has_children = FALSE
+        ))
+      }
+      child <- switch(kind,
+        name = get(child_name, envir = object, inherits = FALSE),
+        slot = methods::slot(object, child_name),
+        index = object[[index]]
+      )
+      summary <- trimws(try_capture_str(child))
+      if (!is.null(view_id)) {
+        list(label = label, str = summary, viewable = TRUE, index = index)
+      } else {
+        selector <- if (kind == "index") {
+          list(kind = kind, value = index, name = child_name)
         } else {
-          child <- get(child_name, envir = object, inherits = FALSE)
-          workspace_child_item(
-            child,
-            paste0("$ ", child_name, ": ", trimws(try_capture_str(child))),
-            list(kind = "name", value = child_name)
-          )
+          list(kind = kind, value = child_name)
         }
-      })
-    } else if (isS4(object)) {
-      child_names <- methods::slotNames(object)[seq.int(start, end)]
-      lapply(child_names, function(child_name) {
-        child <- methods::slot(object, child_name)
-        workspace_child_item(
-          child,
-          paste0("@ ", child_name, ": ", trimws(try_capture_str(child))),
-          list(kind = "slot", value = child_name)
-        )
-      })
-    } else {
-      indices <- seq.int(start, end)
-      child_names <- names(object)
-      lapply(indices, function(index) {
-        child <- object[[index]]
-        child_name <- if (is.null(child_names)) NULL else child_names[[index]]
-        workspace_child_item(
-          child,
-          paste0(
-            workspace_child_label(child_name, index),
-            ": ",
-            trimws(try_capture_str(child))
-          ),
-          list(kind = "index", value = index)
-        )
-      })
-    }
+        workspace_child_item(child, paste0(label, ": ", summary), selector)
+      }
+    })
+    list(children = I(children), next_start = if (end < child_count) end + 1L else NULL)
+  }, error = function(e) {
+    if (!is.null(view_id)) stop(e)
+    list(children = I(list()), next_start = NULL)
+  })
+}
 
-    list(
-      children = I(children),
-      next_start = if (end < child_count) end + 1L else NULL
-    )
-  }, error = function(e) list(children = I(list()), next_start = NULL))
+handle_listview_view <- function(view_id, index) {
+  state <- .sess_env$dataviews[[as.character(view_id)]]
+  if (is.null(state) || !identical(state$type, "list")) {
+    return(FALSE)
+  }
+  index <- as.integer(index)
+  child_count <- if (state$kind == "index") length(state$data) else length(state$names)
+  if (length(index) != 1L || is.na(index) || index < 1L || index > child_count) {
+    return(FALSE)
+  }
+  child_name <- if (is.null(state$names)) NULL else state$names[[index]]
+  if (state$kind == "name" &&
+        (!exists(child_name, envir = state$data, inherits = FALSE) ||
+           bindingIsActive(child_name, state$data))) {
+    return(FALSE)
+  }
+  child <- switch(state$kind,
+    name = get(child_name, envir = state$data, inherits = FALSE),
+    slot = methods::slot(state$data, child_name),
+    index = state$data[[index]]
+  )
+  title <- if (state$kind == "slot") {
+    paste0(state$title, "@", child_name)
+  } else if (!is.null(child_name) && !is.na(child_name) && nzchar(child_name)) {
+    paste0(state$title, "$", child_name)
+  } else {
+    paste0(state$title, "[[", index, "]]")
+  }
+  utils::View(child, title = title)
+  TRUE
 }
 
 handle_hover <- function(expr_str) {

sess/R/hooks.R

@@ -14,21 +14,30 @@ register_hooks <- function(use_rstudioapi = TRUE, use_httpgd = TRUE, use_jgd = F
     # make sure title is computed.
     force(title)
 
-    if (dataview_is_table(x)) {
+    view_type <- if (dataview_is_table(x)) {
+      "table"
+    } else if (is.list(x) || is.environment(x) || isS4(x)) {
+      "list"
+    } else {
+      "object"
+    }
+    if (view_type != "object") {
       title_key <- paste(as.character(title), collapse = "\n")
+      registry_key <- paste0(view_type, ":", title_key)
       dataview_registry <- .sess_env$dataview_registry
-      has_view_id <- nzchar(title_key) &&
-        exists(title_key, envir = dataview_registry, inherits = FALSE)
-      view_id <- if (has_view_id) {
-        get(title_key, envir = dataview_registry, inherits = FALSE)
+      view_id <- if (nzchar(title_key) &&
+                       exists(registry_key, envir = dataview_registry, inherits = FALSE)) {
+        get(registry_key, envir = dataview_registry, inherits = FALSE)
       } else {
         id <- dataview_new_id()
         if (nzchar(title_key)) {
-          assign(title_key, id, envir = dataview_registry)
+          assign(registry_key, id, envir = dataview_registry)
         }
         id
       }
+    }
 
+    if (view_type == "table") {
       registration <- dataview_register(x, view_id = view_id)
 
       notify_client("dataview", list(
@@ -37,14 +46,25 @@ register_hooks <- function(use_rstudioapi = TRUE, use_httpgd = TRUE, use_jgd = F
         type = "json",
         view_id = registration$view_id
       ))
-    } else if (is.list(x)) {
-      file_path <- tempfile(tmpdir = .sess_env$tempdir, fileext = ".json")
-      jsonlite::write_json(x, file_path, auto_unbox = TRUE, null = "null", na = "string")
+    } else if (view_type == "list") {
+      child_kind <- if (is.environment(x)) "name" else if (isS4(x)) "slot" else "index"
+      x_names <- switch(child_kind,
+        name = workspace_env_names(x),
+        slot = methods::slotNames(x),
+        index = names(x)
+      )
+      .sess_env$dataviews[[view_id]] <- list(
+        type = "list",
+        data = x,
+        title = title_key,
+        kind = child_kind,
+        names = x_names
+      )
       notify_client("dataview", list(
         title = title,
-        file = file_path,
         source = "list",
-        type = "json"
+        type = "json",
+        view_id = view_id
       ))
     } else {
       code <- if (is.primitive(x)) utils::capture.output(print(x)) else deparse(x)

sess/R/server.R

@@ -174,10 +174,12 @@ dispatch_message <- function(line) {
     # Request from vscode → R must reply
     handlers <- list(
       "workspace" = function(p) get_workspace_data(),
-      "workspace_children" = function(p) get_workspace_children(p$name, p$path, p$start),
+      "workspace_children" = function(p) get_workspace_children(p$name, p$path, p$start, p$view_id),
+      "workspace_view" = function(p) handle_workspace_view(p$name, p$path),
       "hover" = function(p) handle_hover(p$expr),
       "completion" = function(p) handle_complete(p$expr, p$trigger),
       "plot_latest" = function(p) handle_plot_latest(p),
+      "listview_view" = function(p) handle_listview_view(p$view_id, p$index),
       "dataview_init" = function(p) handle_dataview_init(p),
       "dataview_page" = function(p) handle_dataview_page(p),
       "dataview_dispose" = function(p) handle_dataview_dispose(p)

sess/inst/tinytest/test-dataview.R

@@ -79,3 +79,50 @@ local({
     ), 2L, info = case_name)
   }
 })
+
+
+# Workspace children expose View for both structured and text-viewable objects.
+local({
+  selector <- list(kind = "index", value = 1L)
+  expect_true(sess:::workspace_child_item(data.frame(x = 1), "df", selector)$viewable)
+  expect_true(sess:::workspace_child_item(matrix(1:4, 2), "matrix", selector)$viewable)
+  expect_true(sess:::workspace_child_item(list(x = 1), "list", selector)$viewable)
+  expect_true(sess:::workspace_child_item(new.env(), "environment", selector)$viewable)
+  expect_true(sess:::workspace_child_item(pairlist(x = 1), "pairlist", selector)$viewable)
+  methods::setClass("list_viewer_test_slots", slots = c(child = "list"))
+  on.exit(methods::removeClass("list_viewer_test_slots"), add = TRUE)
+  object <- methods::new("list_viewer_test_slots", child = list(x = 1))
+  expect_true(sess:::workspace_child_item(object, "S4", selector)$viewable)
+  expect_true(sess:::workspace_child_item(1:3, "vector", selector)$viewable)
+})
+
+# List pages inspect only the requested children, with stable indices across pages.
+local({
+  runtime <- sess:::.sess_env
+  previous <- runtime$dataviews
+  on.exit(runtime$dataviews <- previous, add = TRUE)
+  object <- new.env(parent = emptyenv())
+  child_names <- paste0("item", seq_len(501L))
+  for (name in child_names[1:500]) assign(name, 1L, envir = object)
+  delayedAssign("item501", stop("unrequested binding was evaluated"), assign.env = object)
+  runtime$dataviews$paging_test <- list(
+    type = "list", data = object, kind = "name", names = child_names, title = "object"
+  )
+
+  first <- sess:::get_workspace_children(view_id = "paging_test", start = 1L)
+  expect_length(first$children, 500L)
+  expect_equal(first$next_start, 501L)
+  expect_equal(vapply(first$children, `[[`, 1L, "index"), 1:500)
+
+  # Removing a binding must not shift later indices or fail the next page.
+  rm("item501", envir = object)
+  last <- sess:::get_workspace_children(view_id = "paging_test", start = 501L)
+  expect_equal(last$children[[1L]]$label, "$ item501")
+  expect_false(last$children[[1L]]$viewable)
+  expect_null(last$next_start)
+  makeActiveBinding("item501", function() stop("active binding was evaluated"), object)
+  last <- sess:::get_workspace_children(view_id = "paging_test", start = 501L)
+  expect_equal(last$children[[1L]]$str, "(active-binding)")
+  expect_false(last$children[[1L]]$viewable)
+  expect_length(sess:::get_workspace_children(view_id = "paging_test", start = 502L)$children, 0L)
+})

src/extension.ts

@@ -138,7 +138,7 @@ export async function activate(context: vscode.ExtensionContext): Promise<apiImp
 
         // workspace viewer
         'r.workspaceViewer.refreshEntry': () => rWorkspace?.refresh(),
-        'r.workspaceViewer.view': (node: workspaceViewer.GlobalEnvItem) => node?.label && workspaceViewer.viewItem(node.label),
+        'r.workspaceViewer.view': (node: workspaceViewer.GlobalEnvItem) => node && workspaceViewer.viewItem(node),
         'r.workspaceViewer.remove': (node: workspaceViewer.GlobalEnvItem) => node?.label && workspaceViewer.removeItem(node.label),
         'r.workspaceViewer.clear': workspaceViewer.clearWorkspace,
         'r.workspaceViewer.load': workspaceViewer.loadWorkspace,