Document <- R6::R6Class(
"Document",
public = list(
uri = NULL,
language = NULL,
version = NULL,
is_open = FALSE,
nline = 0,
content = NULL,
parse_data = NULL,
is_rmarkdown = NULL,
loaded_packages = NULL,
initialize = function(uri, language = NULL, version = NULL, content = "") {
self$uri <- uri
self$language <- language
self$version <- version
self$is_rmarkdown <- if (is.null(language)) is_rmarkdown(uri) else language == "rmd"
self$set_content(version, content)
self$loaded_packages <- character()
},
did_open = function() {
self$is_open <- TRUE
},
did_close = function() {
self$is_open <- FALSE
},
set_content = function(version, content) {
self$version <- version
self$nline <- length(content)
self$content <- content
},
update_parse_data = function(parse_data) {
self$parse_data <- parse_data
},
line = function(row) {
if (row <= self$nline) self$content[row] else ""
},
line0 = function(row) {
# row is 0-indexed
if (row < self$nline) self$content[row + 1] else ""
},
find_token = function(row, col, forward = TRUE) {
# row and col are 0-indexed
text <- self$line0(row)
text_after <- substr(text, col + 1, nchar(text))
# look forward
if (forward) {
right_token <- look_forward(text_after)$token
end <- col + nchar(right_token)
} else {
right_token <- ""
end <- col
}
matches <- look_backward(substr(text, 1, end))
return(list(
full_token = matches$full_token,
right_token = right_token,
package = empty_string_to_null(matches$package),
accessor = matches$accessor,
token = matches$token
))
},
detect_call = function(point) {
row <- point$row
col <- point$col
if (col > 0) {
fub_result <- find_unbalanced_bracket(self$content, row, col - 1)
loc <- fub_result[[1]]
bracket <- fub_result[[2]]
} else {
loc <- c(-1, -1)
bracket <- " "
}
logger$info("bracket is", bracket)
if (loc[1] < 0 || loc[2] < 0 || bracket != "(")
return(list(token = ""))
result <- self$find_token(loc[1], loc[2], forward = FALSE)
logger$info("call:", result)
list(
full_token = result$full_token,
package = result$package,
accessor = result$accessor,
token = result$token
)
},
detect_token = function(point, forward = TRUE) {
row <- point$row
col <- point$col
result <- self$find_token(row, col, forward = forward)
logger$info("token:", result)
col_end <- col + nchar(result$right_token)
col_start <- col_end - nchar(result$full_token)
list(
range = list(
start = list(row = row, col = col_start),
end = list(row = row, col = col_end)
),
full_token = result$full_token,
package = result$package,
accessor = result$accessor,
token = result$token
)
},
from_lsp_position = function(position) {
# convert UTF-16 based position to code point based position
text <- self$line0(position$line)
list(
row = position$line,
col = code_point_from_unit(text, position$character)
)
},
to_lsp_position = function(row, col) {
# convert code point based position to UTF-16 based position
text <- self$line0(row)
position(
line = row,
character = code_point_to_unit(text, col)
)
}
)
)
#' Search backwards in a document content for a specific character
#' @noRd
find_unbalanced_bracket <- function(content, row, column, skip_empty_line = FALSE) {
.Call("find_unbalanced_bracket",
PACKAGE = "languageserver",
content, row, column, skip_empty_line
)
}
#' check if a position is inside quotes
#' @noRd
enclosed_by_quotes <- function(document, point) {
text <- document$line0(point$row)
col <- point$col
.Call("enclosed_by_quotes", PACKAGE = "languageserver", text, col - 1)
}
detect_comments <- function(content, row) {
.Call("detect_comments", PACKAGE = "languageserver",
content, row)
}
#' Expression range in UTF-16 code units
#' @noRd
expr_range <- function(srcref) {
lines <- attr(srcref, "srcfile")$lines
# R is 1-indexed, language server is 0-indexed
first_line <- srcref[1] - 1
first_char <- code_point_to_unit(lines[srcref[1]], srcref[5] - 1)
last_line <- srcref[3] - 1
last_char <- code_point_to_unit(lines[srcref[3]], srcref[6])
return(
range(
start = position(first_line, first_char),
end = position(last_line, last_char)
)
)
}
get_range_text <- function(content, line1, col1, line2, col2) {
lines <- content[line1:line2]
lines[length(lines)] <- substr(lines[length(lines)], 1L, col2)
lines[1] <- substr(lines[1], col1, nchar(lines[1]))
lines
}
is_ns_call <- function(x) {
length(x) == 3L && is.symbol(x[[1L]]) && as.character(x[[1L]]) %in% c("::", ":::")
}
# 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]]))
}
# 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"
}
# 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)
}
# 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)))
}
null_function <- local(function() NULL, baseenv())
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", quietly = TRUE)) 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")
)
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)
fun <- null_function
formals(fun) <- value[[2L]]
env$functions[[symbol]] <- fun
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
}
#' Parse a document
#'
#' Build the list of called packages, functions, variables, formals and
#' signatures in the document in order to add them to the current [Workspace].
#'
#' @noRd
parse_document <- function(uri, content) {
if (length(content) == 0) {
content <- ""
}
# replace tab with a space since the width of a tab is 1 in LSP but 8 in getParseData().
content <- gsub("\t", " ", content, fixed = TRUE)
expr <- tryCatch(parse(text = content, keep.source = TRUE), error = function(e) NULL)
if (!is.null(expr)) {
parse_env <- function() {
env <- new.env(parent = .GlobalEnv)
env$packages <- character()
env$nonfuncts <- character()
env$functs <- character()
env$functions <- list()
env$signatures <- list()
env$definitions <- list()
env$documentation <- list()
env$xml_data <- NULL
env$xml_doc <- NULL
env
}
env <- parse_env()
parse_expr(content, expr, env)
env$packages <- basename(find.package(env$packages, quiet = TRUE))
env$xml_data <- xmlparsedata::xml_parse_data(expr)
env
}
}
parse_callback <- function(self, uri, version, parse_data) {
if (is.null(parse_data) || !self$workspace$documents$has(uri)) return(NULL)
logger$info("parse_callback called:", list(uri = uri, version = version))
doc <- self$workspace$documents$get(uri)
parse_data$version <- version
old_parse_data <- doc$parse_data
self$workspace$update_parse_data(uri, parse_data)
if (!identical(old_parse_data$packages, parse_data$packages)) {
self$resolve_task_manager$add_task(
uri,
resolve_task(self, uri, doc, parse_data$packages)
)
doc$loaded_packages <- parse_data$packages
self$workspace$update_loaded_packages()
}
pending_replies <- self$pending_replies$get(uri, NULL)
for (name in names(pending_replies)) {
queue <- pending_replies[[name]]
handler <- self$request_handlers[[name]]
while (queue$size()) {
item <- queue$peek()
if (is.null(version) || item$version == version) {
handler(self, item$id, item$params)
queue$pop()
} else if (item$version < version) {
self$deliver(Response$new(item$id))
queue$pop()
} else {
break
}
}
}
}
parse_task <- function(self, uri, document, delay = 0) {
version <- document$version
content <- document$content
if (document$is_rmarkdown) {
content <- purl(content)
}
create_task(
target = package_call(parse_document),
args = list(uri = uri, content = content),
callback = function(result) parse_callback(self, uri, version, result),
error = function(e) logger$info("parse_task:", e),
delay = delay
)
}
resolve_callback <- function(self, uri, version, packages) {
if (!self$workspace$documents$has(uri)) return(NULL)
logger$info("resolve_callback called:", list(uri = uri, version = version))
self$workspace$load_packages(packages)
doc <- self$workspace$documents$get(uri)
doc$loaded_packages <- packages
self$workspace$update_loaded_packages()
}
resolve_task <- function(self, uri, document, packages, delay = 0) {
version <- document$version
create_task(
target = resolve_attached_packages,
args = list(pkgs = packages),
callback = function(result) resolve_callback(self, uri, version, result),
error = function(e) logger$info("resolve_task:", e),
delay = 0
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.