diff --git a/R/document.R b/R/document.R index 60fd0f00..48a29580 100644 --- a/R/document.R +++ b/R/document.R @@ -186,122 +186,204 @@ get_range_text <- function(content, line1, col1, line2, col2) { lines } -parse_expr <- function(content, expr, env, level = 0L, srcref = attr(expr, "srcref")) { - if (length(expr) == 0L || is.symbol(expr)) { - return(env) - } - # We should handle base function specially as users may use base::fun form - # The reason that we only take care of `base` (not `utils`) is that only `base` calls can generate symbols - # Check if the lang is in base::fun form - is_base_call <- function(x) { - length(x) == 3L && as.character(x[[1L]]) %in% c("::", ":::") && as.character(x[[2L]]) == "base" - } - # Be able to handle `pkg::name` case (note `::` is a function) - is_symbol <- function(x) { - is.symbol(x) || is_base_call(x) - } - # Handle `base` function specically by removing the `base::` prefix - fun_string <- function(x) { - if (is_base_call(x)) as.character(x[[3L]]) else as.character(x) - } - for (i in seq_along(expr)) { - e <- expr[[i]] - if (missing(e) || !is.call(e) || !is_symbol(e[[1L]])) next - f <- fun_string(e[[1L]]) - cur_srcref <- if (level == 0L) srcref[[i]] else srcref - if (f %in% c("{", "(")) { - Recall(content, e[-1L], env, level + 1L, cur_srcref) - } else if (f == "if") { - Recall(content, e[[2L]], env, level + 1L, cur_srcref) - Recall(content, e[[3L]], env, level + 1L, cur_srcref) - if (length(e) == 4L) { - Recall(content, e[[4L]], env, level + 1L, cur_srcref) - } - } else if (f == "for") { - if (is.symbol(e[[2L]])) { - env$nonfuncts <- c(env$nonfuncts, as.character(e[[2L]])) - } - Recall(content, e[[4L]], env, level + 1L, cur_srcref) - } else if (f == "while") { - Recall(content, e[[2L]], env, level + 1L, cur_srcref) - Recall(content, e[[3L]], env, level + 1L, cur_srcref) - } else if (f == "repeat") { - Recall(content, e[[2L]], env, level + 1L, cur_srcref) - } else if (f %in% c("<-", "=", "delayedAssign", "makeActiveBinding", "assign")) { - # to see the pos/env/assign.env of assigning functions is set or not - # if unset, it means using the default value, which is top-level - # if set, we should compare to a vector of known "top-level" candidates - is_top_level <- function(arg_env, ...) { - if (is.null(arg_env)) return(TRUE) - default <- list( - quote(parent.frame(1)), quote(parent.frame(1L)), - quote(environment()), - quote(.GlobalEnv), quote(globalenv()) - ) - extra <- substitute(list(...))[-1L] - top_level_envs <- c(default, as.list(extra)) - any(vapply(top_level_envs, identical, x = arg_env, FUN.VALUE = logical(1L))) - } +is_ns_call <- function(x) { + length(x) == 3L && is.symbol(x[[1L]]) && as.character(x[[1L]]) %in% c("::", ":::") +} - type <- NULL - - if (f %in% c("<-", "=")) { - if (length(e) != 3L || !is.symbol(e[[2L]])) next - symbol <- as.character(e[[2L]]) - value <- e[[3L]] - } else if (f == "delayedAssign") { - call <- match.call(base::delayedAssign, as.call(e)) - if (!is.character(call$x)) next - if (!is_top_level(call$assign.env)) next - symbol <- call$x - value <- call$value - } else if (f == "assign") { - call <- match.call(base::assign, as.call(e)) - if (!is.character(call$x)) next - if (!is_top_level(call$pos, -1L, -1)) next # -1 is the default - if (!is_top_level(call$envir)) next - symbol <- call$x - value <- call$value - } else if (f == "makeActiveBinding") { - call <- match.call(base::makeActiveBinding, as.call(e)) - if (!is.character(call$sym)) next - if (!is_top_level(call$env)) next - symbol <- call$sym - value <- call$fun - type <- "variable" - } +# Check if an expression is a simple call like `foo(bar)` or `pkg::foo(bar)` +# This rules out anonymous function call like `(function(x) x + 1)(bar)` +is_simple_call <- function(x) { + is.call(x) && (is.symbol(x[[1L]]) || is_ns_call(x[[1]])) +} - if (is.null(type)) { - type <- get_expr_type(value) - } +# We should handle base function specially as users may use base::fun form +# The reason that we only take care of `base` (not `utils`) is that only `base` calls can generate symbols +# Check if the lang is in base::fun form +is_base_call <- function(x) { + is_ns_call(x) && as.character(x[[2L]]) == "base" +} - env$objects <- c(env$objects, symbol) +# Handle `base` function specically by removing the `base::` prefix +fun_string <- function(x) { + if (is_base_call(x)) as.character(x[[3L]]) else deparse(x) +} - expr_range <- expr_range(cur_srcref) - env$definitions[[symbol]] <- list( - name = symbol, - type = type, - range = expr_range - ) +# to see the pos/env/assign.env of assigning functions is set or not +# if unset, it means using the default value, which is top-level +# if set, we should compare to a vector of known "top-level" candidates +is_top_level <- function(arg_env, ...) { + if (is.null(arg_env)) return(TRUE) + default <- list( + quote(parent.frame(1)), quote(parent.frame(1L)), + quote(environment()), + quote(.GlobalEnv), quote(globalenv()) + ) + extra <- substitute(list(...))[-1L] + top_level_envs <- c(default, as.list(extra)) + any(vapply(top_level_envs, identical, x = arg_env, FUN.VALUE = logical(1L))) +} - doc_line1 <- detect_comments(content, expr_range$start$line) + 1 - if (doc_line1 <= expr_range$start$line) { - comment <- content[seq.int(doc_line1, expr_range$start$line)] - env$documentation[[symbol]] <- convert_comment_to_documentation(comment) - } +parser_hooks <- list( + "{" = function(expr, action) { + action$parse(as.list(expr)[-1L]) + }, + "(" = function(expr, action) { + action$parse(as.list(expr)[-1L]) + }, + "if" = function(expr, action) { + action$parse(as.list(expr)[-1L]) + }, + "for" = function(expr, action) { + if (is.symbol(e <- expr[[2L]])) { + action$update(nonfuncts = as.character(e)) + } + action$parse(expr[[4L]]) + }, + "while" = function(expr, action) { + action$parse(as.list(expr)[-1L]) + }, + "repeat" = function(expr, action) { + action$parse(expr[[2L]]) + }, + "<-" = function(expr, action) { + if (length(expr) == 3L && is.symbol(expr[[2L]])) { + action$assign(symbol = as.character(expr[[2L]]), value = expr[[3L]]) + action$parse(expr[[3L]]) + } + }, + "=" = function(expr, action) { + if (length(expr) == 3L && is.symbol(expr[[2L]])) { + action$assign(symbol = as.character(expr[[2L]]), value = expr[[3L]]) + action$parse(expr[[3L]]) + } + }, + "assign" = function(expr, action) { + call <- match.call(base::assign, expr) + if (is.character(call$x) && is_top_level(call$pos, -1L, -1) && is_top_level(call$envir)) { + action$assign(symbol = call$x, value = call$value) + action$parse(call$value) + } + }, + "delayedAssign" = function(expr, action) { + call <- match.call(base::delayedAssign, expr) + if (is.character(call$x) && is_top_level(call$assign.env)) { + action$assign(symbol = call$x, value = call$value) + action$parse(call$value) + } + }, + "makeActiveBinding" = function(expr, action) { + call <- match.call(base::makeActiveBinding, expr) + if (is.character(call$sym) && is_top_level(call$env)) { + action$assign(symbol = call$sym, value = call$fun, type = "variable") + } + }, + "library" = function(expr, action) { + call <- match.call(base::library, expr) + if (!isTRUE(call$character.only)) { + action$update(packages = as.character(call$package)) + } + }, + "require" = function(expr, action) { + call <- match.call(base::require, expr) + if (!isTRUE(call$character.only)) { + action$update(packages = as.character(call$package)) + } + }, + "pacman::p_load" = function(expr, action) { + fun <- if (requireNamespace("pacman")) pacman::p_load else + function(..., char, install = TRUE, + update = getOption("pac_update"), + character.only = FALSE) NULL + call <- match.call(fun, expr, expand.dots = FALSE) + if (!isTRUE(call$character.only)) { + packages <- vapply(call[["..."]], as.character, character(1L)) + action$update(packages = packages) + } + }, + "system.time" = function(expr, action) action$parse_args("expr"), + "try" = function(expr, action) action$parse_args("expr"), + "tryCatch" = function(expr, action) action$parse_args(c("expr", "finally")), + "withCallingHandlers" = function(expr, action) action$parse_args("expr"), + "withRestarts" = function(expr, action) action$parse_args("expr"), + "allowInterrupts" = function(expr, action) action$parse_args("expr"), + "suspendInterrupts" = function(expr, action) action$parse_args("expr"), + "suppressPackageStartupMessages" = function(expr, action) action$parse_args("expr"), + "suppressMessages" = function(expr, action) action$parse_args("expr"), + "suppressWarnings" = function(expr, action) action$parse_args("expr") +) - if (type == "function") { - env$functs <- c(env$functs, symbol) - env$formals[[symbol]] <- value[[2L]] - env$signatures[[symbol]] <- get_signature(symbol, value) - } else { - env$nonfuncts <- c(env$nonfuncts, symbol) - } - } else if (f %in% c("library", "require") && length(e) == 2L) { - pkg <- as.character(e[[2L]]) - if (!(pkg %in% env$packages)) { - env$packages <- c(env$packages, pkg) - } +parse_expr <- function(content, expr, env, srcref = attr(expr, "srcref")) { + if (length(expr) == 0L || is.symbol(expr) || is.atomic(expr)) { + return(env) + } + + if (is.expression(expr)) { + for (i in seq_along(expr)) { + Recall(content, expr[[i]], env, srcref[[i]]) + } + } else if (is.list(expr)) { + for (i in seq_along(expr)) { + e <- expr[[i]] + if (missing(e)) next + Recall(content, e, env, srcref) + } + } else if (is_simple_call(expr)) { + f <- fun_string(expr[[1L]]) + fun <- parser_hooks[[f]] + if (is.function(fun)) { + action <- list( + update = function(...) { + updates <- list(...) + for (name in names(updates)) { + values <- updates[[name]] + values <- values[nzchar(values)] + if (length(values)) { + env[[name]] <- union(env[[name]], values) + } + } + }, + assign = function(symbol, value, type = get_expr_type(value)) { + if (!nzchar(symbol)) return(NULL) + + env$objects <- c(env$objects, symbol) + + expr_range <- expr_range(srcref) + env$definitions[[symbol]] <- list( + name = symbol, + type = type, + range = expr_range + ) + + doc_line1 <- detect_comments(content, expr_range$start$line) + 1 + if (doc_line1 <= expr_range$start$line) { + comment <- content[seq.int(doc_line1, expr_range$start$line)] + env$documentation[[symbol]] <- convert_comment_to_documentation(comment) + } + + if (type == "function") { + env$functs <- c(env$functs, symbol) + env$formals[[symbol]] <- value[[2L]] + env$signatures[[symbol]] <- get_signature(symbol, value) + } else { + env$nonfuncts <- c(env$nonfuncts, symbol) + } + }, + parse = function(expr) { + parse_expr(content, expr, env, srcref) + }, + parse_args = function(args) { + fn <- tryCatch(eval(expr[[1L]], globalenv()), error = function(e) NULL) + if (is.function(fn)) { + call <- match.call(fn, expr, expand.dots = FALSE) + for (arg in args) { + if (is.call(call[[arg]])) { + parse_expr(content, call[[arg]], env, srcref) + } + } + } + } + ) + tryCatch(fun(expr, action), error = function(e) NULL) } } env diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 00000000..755d697e --- /dev/null +++ b/R/zzz.R @@ -0,0 +1,5 @@ +.onLoad <- function(...) { + user_parser_hooks <- getOption("languageserver.parser_hooks") + parser_hooks[names(user_parser_hooks)] <<- user_parser_hooks + invisible() +} diff --git a/tests/testthat/test-completion.R b/tests/testthat/test-completion.R index d2f5a7d7..13beff09 100644 --- a/tests/testthat/test-completion.R +++ b/tests/testthat/test-completion.R @@ -118,6 +118,117 @@ test_that("Simple completion is case insensitive", { expect_length(result$items %>% keep(~ .$label == "mtcars"), 1) }) +test_that("Completion of attached package functions works", { + skip_on_cran() + client <- language_client() + + temp_file <- withr::local_tempfile(fileext = ".R") + writeLines( + c( + "library(jsonlite)", + "require('xml2')", + "fromJS", + "read_xm" + ), + temp_file) + + client %>% did_save(temp_file) + + result <- client %>% respond_completion(temp_file, c(2, 6), + retry_when = function(result) result$items %>% keep(~ .$label == "fromJSON") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "fromJSON"), 1) + + result <- client %>% respond_completion(temp_file, c(3, 7), + retry_when = function(result) result$items %>% keep(~ .$label == "read_xml") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "read_xml"), 1) + + temp_file <- withr::local_tempfile(fileext = ".R") + writeLines( + c( + "pacman::p_load(jsonlite, xml2)", + "fromJS", + "read_xm" + ), + temp_file) + + client %>% did_save(temp_file) + + result <- client %>% respond_completion(temp_file, c(1, 6), + retry_when = function(result) result$items %>% keep(~ .$label == "fromJSON") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "fromJSON"), 1) + + result <- client %>% respond_completion(temp_file, c(2, 7), + retry_when = function(result) result$items %>% keep(~ .$label == "read_xml") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "read_xml"), 1) +}) + +test_that("Completion of package functions attached in unscoped functions works", { + skip_on_cran() + client <- language_client() + + temp_file <- withr::local_tempfile(fileext = ".R") + writeLines( + c( + "suppressPackageStartupMessages(library(jsonlite))", + "fromJS" + ), + temp_file) + + client %>% did_save(temp_file) + + result <- client %>% respond_completion(temp_file, c(1, 6), + retry_when = function(result) result$items %>% keep(~ .$label == "fromJSON") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "fromJSON"), 1) + + writeLines( + c( + "suppressPackageStartupMessages({", + " library(jsonlite)", + " require('xml2')", + "})", + "fromJS", + "read_xm" + ), + temp_file) + + client %>% did_save(temp_file) + + result <- client %>% respond_completion(temp_file, c(4, 6), + retry_when = function(result) result$items %>% keep(~ .$label == "fromJSON") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "fromJSON"), 1) + + result <- client %>% respond_completion(temp_file, c(5, 7), + retry_when = function(result) result$items %>% keep(~ .$label == "read_xml") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "read_xml"), 1) +}) + +test_that("Completion is robust to invalid source", { + skip_on_cran() + client <- language_client() + + temp_file <- withr::local_tempfile(fileext = ".R") + writeLines( + c( + "library(jsonlite)", + "require('xml2')", + "require('')", + "require('xml2', nonexist_arg = 0)", + "fromJS", + "read_xm" + ), + temp_file) + + client %>% did_save(temp_file) + + result <- client %>% respond_completion(temp_file, c(4, 6), + retry_when = function(result) result$items %>% keep(~ .$label == "fromJSON") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "fromJSON"), 1) + + result <- client %>% respond_completion(temp_file, c(5, 7), + retry_when = function(result) result$items %>% keep(~ .$label == "read_xml") %>% length() == 0) + expect_length(result$items %>% keep(~ .$label == "read_xml"), 1) +}) + test_that("Completion of function arguments works", { skip_on_cran() client <- language_client() diff --git a/tests/testthat/test-symbol.R b/tests/testthat/test-symbol.R index f1ae8730..aa378dc5 100644 --- a/tests/testthat/test-symbol.R +++ b/tests/testthat/test-symbol.R @@ -36,7 +36,7 @@ test_that("Document Symbol works", { ) }) -test_that("Recognize symbols created by delayedAssign()/assign()/makeActiveBinding()", { +test_that("Recognize symbols created by delayedAssign/assign/makeActiveBinding", { skip_on_cran() client <- language_client() @@ -59,7 +59,7 @@ test_that("Recognize symbols created by delayedAssign()/assign()/makeActiveBindi "makeActiveBinding('a5', function() 5, .GlobalEnv)", "makeActiveBinding('a6', function() 6, new.env())", "assign(value = '1', x = 'assign1')", - "assign('assign2', 2, pos = -1L)", + "assign('assign2', 2, pos = -1)", "assign('assign3', 3, pos = environment())", "assign('assign4', 4, pos = new.env())" ), defn_file) @@ -73,6 +73,32 @@ test_that("Recognize symbols created by delayedAssign()/assign()/makeActiveBindi ) }) +test_that("Document symbols are robust to invalid source", { + skip_on_cran() + client <- language_client() + + defn_file <- withr::local_tempfile(fileext = ".R") + writeLines(c( + "'' <- 2", + "assign('', 3)", + "delayedAssign('', 1)", + "makeActiveBinding('', 2)", + "makeActiveBinding(x, 1)", + "assign('var1', 1, nonexist_arg = TRUE)", + "delayedAssign('var1', 1, nonexist_arg = TRUE)", + "makeActiveBinding('var1', 1, nonexist_arg = TRUE)", + "d1 <- 1" + ), defn_file) + + client %>% did_save(defn_file) + result <- client %>% respond_document_symbol(defn_file) + + expect_setequal( + result %>% map_chr(~ .$name), + c("d1") + ) +}) + test_that("Document section symbol works", { skip_on_cran() client <- language_client(capabilities = list(