# ?Syntax
# : can indicate :: :::
# - can indicate <-
# > can indicate |>
binary_opts <- c(
":", "\\$", "@", "\\^",
"%[^#]*%", "\\+", "-", "\\*", "/",
"<", ">", "=", "!", "&", "\\|", "~",
"\\?"
)
binary_opts_regex <- paste0(binary_opts, collapse = "|")
binary_opts_ending_regex <- paste0("^[^#]*(", binary_opts_regex, ")\\s*(#.*)?$")
incomplete_ending_regex <- paste0("^[^#]*(", binary_opts_regex, "|,)\\s*(#.*)?$")
is_binary_line <- function(line) {
grepl(binary_opts_ending_regex, line, perl = TRUE)
}
is_incomplete_line <- function(line) {
grepl(incomplete_ending_regex, line, perl = TRUE)
}
#' Merge two lists
#'
#' @noRd
merge_list <- function(x, y) {
x[names(y)] <- y
x
}
#' tryCatch with stack captured
#'
#' @noRd
tryCatchStack <- function(expr, ...) {
expr <- substitute(expr)
env <- parent.frame()
capture_calls <- function(e) {
calls <- sys.calls()
ncalls <- length(calls)
e$calls <- calls[-c(seq_len(frame + 7), ncalls - 1, ncalls)]
class(e) <- c("errorWithStack", class(e))
signalCondition(e)
}
frame <- sys.nframe()
tryCatch(withCallingHandlers(eval(expr, env), error = capture_calls), ...)
}
print.errorWithStack <- function(x, ...) {
cat("Error: ", conditionMessage(x), "\n", sep = "")
call <- conditionCall(x)
if (!is.null(call)) {
cat("Call: ")
print(call)
}
if (length(x$calls)) {
cat("Stack trace:\n")
rev_calls <- rev(x$calls)
for (i in seq_along(rev_calls)) {
cat(i, ": ", sep = "")
print(rev_calls[[i]])
}
}
invisible(x)
}
tryCatchTimeout <- function(expr, timeout = Inf, ...) {
expr <- substitute(expr)
envir <- parent.frame()
setTimeLimit(timeout, transient = TRUE)
on.exit(setTimeLimit())
tryCatch(eval(expr, envir), ...)
}
capture_print <- function(x) {
paste0(utils::capture.output(print(x)), collapse = "\n")
}
get_expr_type <- function(expr) {
if (is.call(expr)) {
func <- deparse(expr[[1]], nlines = 1)
if (func == "function") {
"function"
} else if (func %in% c("c", "matrix", "array")) {
"array"
} else if (func == "list") {
"list"
} else if (grepl("(R6:::?)?R6Class", func)) {
"class"
} else {
"variable"
}
} else {
typeof(expr)
}
}
uri_escape_unicode <- function(uri) {
if (length(uri) == 0) {
return(character())
}
if (.Platform$OS.type == "windows") {
uri <- utils::URLdecode(uri)
Encoding(uri) <- "UTF-8"
utils::URLencode(uri)
} else {
utils::URLencode(uri)
}
}
#' Paths and uris
#' @noRd
path_from_uri <- function(uri) {
if (length(uri) == 0) {
return(character())
}
if (startsWith(uri, "file:///")) {
start_char <- if (.Platform$OS.type == "windows") 9 else 8
path <- substr(uri, start_char, nchar(uri))
} else if (startsWith(uri, "vscode-notebook-cell:")) {
# Windows: vscode-notebook-cell:/c:/Users/Username/Documents/Notebooks/MyNotebook.ipynb#MyCellId
# Unix: vscode-notebook-cell:/home/username/Documents/Notebooks/MyNotebook.ipynb#MyCellId
# WSL: vscode-notebook-cell://wsl+ubuntu-20.04/home/username/Documents/Notebooks/MyNotebook.ipynb#MyCellId
if (.Platform$OS.type == "windows") {
path <- sub("^vscode-notebook-cell:/(.+)#.*$", "\\1", uri)
} else {
path <- sub("^vscode-notebook-cell:(.+)#.*$", "\\1", uri)
if (startsWith(path, "//")) {
path <- sub("^//[^/]+(/.+)$", "\\1", path)
}
}
} else {
return("")
}
# URLdecode gives unknown encoding, we need to mark them as UTF-8
path <- utils::URLdecode(path)
Encoding(path) <- "UTF-8"
path
}
#' @noRd
#' @rdname path_from_uri
path_to_uri <- function(path) {
if (length(path) == 0) {
return(character())
}
path <- path.expand(path)
if (.Platform$OS.type == "windows") {
prefix <- "file:///"
path <- gsub("\\", "/", path, fixed = TRUE)
} else {
prefix <- "file://"
}
paste0(prefix, utils::URLencode(path))
}
path_has_parent <- function(x, y) {
if (.Platform$OS.type == "windows") {
tryCatch(
# https://github.com/REditorSupport/languageserver/issues/279
fs::path_has_parent(x, y),
error = function(e) {
# try encode to native encoding
fs::path_has_parent(enc2native(x), enc2native(y))
}
)
} else {
fs::path_has_parent(x, y)
}
}
with_wd <- function(wd, expr) {
if (is.null(wd)) {
wd <- getwd()
}
oldwd <- setwd(wd)
on.exit(setwd(oldwd))
expr
}
equal_position <- function(x, y) {
x$line == y$line && x$character == y$character
}
equal_range <- function(x, y) {
equal_position(x$start, y$start) && equal_position(x$end, y$end)
}
equal_definition <- function(x, y) {
x$uri == y$uri && equal_range(x$range, y$range)
}
#' Check if a file is an RMarkdown file
#' @noRd
is_rmarkdown <- function(uri) {
filename <- path_from_uri(uri)
endsWith(tolower(filename), ".rmd") || endsWith(tolower(filename), ".rmarkdown")
}
#' Check if a token is in a R code block in an Rmarkdown file
#'
#' In an RMarkdown document, tokens can be either inside an R code block or
#' in the text. This function will return `FALSE` if the token is in the text
#' and `TRUE` if it is in a code block. For any other files, it always returns `TRUE`.
#'
#' @noRd
check_scope <- function(uri, document, point) {
if (document$is_rmarkdown) {
row <- point$row
flags <- startsWith(document$content[1:(row + 1)], "```")
if (any(flags)) {
last_match <- document$content[max(which(flags))]
stringi::stri_detect_regex(last_match, "```+\\s*\\{[rR][ ,\\}]") &&
!identical(sum(flags) %% 2, 0) &&
!enclosed_by_quotes(document, point)
} else {
FALSE
}
} else {
!enclosed_by_quotes(document, point)
}
}
match_with <- function(x, token) {
pattern <- gsub(".", "\\.", token, fixed = TRUE)
grepl(pattern, x, ignore.case = TRUE)
}
fuzzy_find <- function(x, pattern) {
subsequence_regex <- gsub("(.)", "\\1.*", pattern)
grepl(subsequence_regex, x, ignore.case = TRUE)
}
#' Safer version of `seq` which returns empty vector if b < a
#' @noRd
seq_safe <- function(a, b) {
seq(a, b, length = max(0, b - a + 1))
}
#' Extract the R code blocks of a Rmarkdown file
#' @noRd
extract_blocks <- function(content) {
begins_or_ends <- which(stringi::stri_detect_fixed(content, "```"))
begins <- which(stringi::stri_detect_regex(content, "```+\\s*\\{[rR][ ,\\}]"))
ends <- setdiff(begins_or_ends, begins)
blocks <- list()
for (begin in begins) {
z <- which(ends > begin)
if (length(z) == 0) break
end <- ends[min(z)]
lines <- seq_safe(begin + 1, end - 1)
if (length(lines) > 0) {
blocks[[length(blocks) + 1]] <- list(lines = lines, text = content[lines])
}
}
blocks
}
get_signature <- function(symbol, expr) {
signature <- format(expr[1:2])
signature <- paste0(trimws(signature, which = "left"), collapse = "")
signature <- gsub("^function\\s*", symbol, signature)
signature <- gsub("\\s*NULL$", "", signature)
signature
}
#' Strip out all the non R blocks in a R markdown file
#' @param content a character vector
#' @noRd
purl <- function(content) {
blocks <- extract_blocks(content)
rmd_content <- rep("", length(content))
for (block in blocks) {
rmd_content[block$lines] <- content[block$lines]
}
rmd_content
}
#' Calculate character offset based on the protocol
#' @noRd
ncodeunit <- function(s) {
lengths(iconv(s, from = "UTF-8", to = "UTF-16BE", toRaw = TRUE)) / 2
}
#' Determine code points given code units
#'
#' @param line a character of text
#' @param units 0-indexed code points
#'
#' @noRd
code_point_from_unit <- function(line, units) {
if (!nzchar(line)) return(units)
offsets <- cumsum(ncodeunit(strsplit(line, "")[[1]]))
loc_map <- match(seq_len(utils::tail(offsets, 1)), offsets)
result <- c(0, loc_map)[units + 1]
n <- nchar(line)
result[units > length(loc_map)] <- n
result[is.infinite(units)] <- n
result
}
#' Determine code units given code points
#'
#' @param line a character of text
#' @param units 0-indexed code units
#'
#' @noRd
code_point_to_unit <- function(line, pts) {
pts[pts < 0] <- 0
if (!nzchar(line)) return(pts)
offsets <- c(0, cumsum(ncodeunit(strsplit(line, "")[[1]])))
result <- offsets[pts + 1]
n <- length(offsets)
m <- offsets[n]
result[pts >= n] <- m
result[!is.finite(pts)] <- m
result
}
#' Check if a path is a directory
#' @noRd
is_directory <- function(path) {
is_dir <- file.info(path)$isdir
!is.na(is_dir) && is_dir
}
#' Find the root package folder
#'
#' This function searches backwards in the folder structure until it finds
#' a DESCRIPTION file or it reaches the top-level directory.
#'
#' @noRd
find_package <- function(path = getwd()) {
start_path <- getwd()
on.exit(setwd(start_path))
if (!file.exists(path)) {
return(NULL)
}
setwd(path)
prev_path <- ""
while (!file.exists(file.path(prev_path, "DESCRIPTION"))) {
if (identical(prev_path, getwd())) {
return(NULL)
}
prev_path <- getwd()
setwd("..")
}
normalizePath(prev_path)
}
#' check if a path is a package folder
#'
#' @param rootPath a character representing a path
#'
#' @noRd
is_package <- function(rootPath) {
file <- file.path(rootPath, "DESCRIPTION")
length(file) && file.exists(file) && !dir.exists(file)
}
get_root_path_for_uri <- function(uri, rootPath) {
if (length(rootPath)) {
# valid workspace folder
rootPath
} else if (nzchar(path <- path_from_uri(uri))) {
# null workspace folder
dirname(path)
} else {
# untitled document
getwd()
}
}
#' read a character from stdin
#'
#' @noRd
stdin_read_char <- function(n) {
.Call("stdin_read_char", PACKAGE = "languageserver", n)
}
#' read a line from stdin
#'
#' @noRd
stdin_read_line <- function() {
.Call("stdin_read_line", PACKAGE = "languageserver")
}
#' check if the current process becomes an orphan
#'
#' @noRd
process_is_detached <- function() {
.Call("process_is_detached", PACKAGE = "languageserver")
}
#' throttle a function execution
#'
#' Execute a function if the last execution time is older than a specified
#' value.
#'
#' @param fun the function to execute
#' @param t an integer, the threshold in seconds
#'
#' @noRd
throttle <- function(fun, t = 1) {
last_execution_time <- 0
function(...) {
if (Sys.time() - last_execution_time > t) {
last_execution_time <<- Sys.time()
fun(...)
}
}
}
#' sanitize package objects names
#'
#' Remove unwanted objects, _e.g._ `names<-`, `%>%`, `.__C_` etc.
#'
#' @noRd
sanitize_names <- function(objects) {
objects[stringi::stri_detect_regex(objects, "^([^\\W_]|\\.(?!_))(\\w|\\.)*$")]
}
na_to_empty_string <- function(x) if (is.na(x)) "" else x
empty_string_to_null <- function(x) if (nzchar(x)) x else NULL
look_forward <- function(text) {
matches <- stringi::stri_match_first_regex(text, "^(?:[^\\W]|\\.)*\\b")[1]
list(
token = na_to_empty_string(matches[1])
)
}
look_backward <- function(text) {
matches <- stringi::stri_match_first_regex(
text, "(?<!\\$)(?:\\b|(?=\\.))(?:([a-zA-Z][a-zA-Z0-9.]+)(:::?))?((?:[^\\W_]|\\.)(?:[^\\W]|\\.)*)?$")
list(
full_token = na_to_empty_string(matches[1]),
package = na_to_empty_string(matches[2]),
accessor = na_to_empty_string(matches[3]),
token = na_to_empty_string(matches[4])
)
}
str_trunc <- function(string, width, ellipsis = "...") {
trunc <- !is.na(string) && nchar(string) > width
if (trunc) {
width2 <- width - nchar(ellipsis)
paste0(substr(string, 1, width2), ellipsis)
} else {
string
}
}
uncomment <- function(x) gsub("^\\s*#+'?\\s*", "", x)
convert_comment_to_documentation <- function(comment) {
result <- NULL
roxy <- tryCatch(roxygen2::parse_text(c(
comment,
"NULL"
), env = NULL), error = function(e) NULL)
if (length(roxy)) {
result <- list(
title = NULL,
description = NULL,
arguments = list(),
markdown = NULL
)
items <- lapply(roxy[[1]]$tags, function(item) {
if (item$tag == "title") {
result$title <<- item$val
} else if (item$tag == "description") {
result$description <<- item$val
} else if (item$tag == "param") {
result$arguments[[item$val$name]] <<- item$val$description
}
format_roxy_tag(item)
})
if (is.null(result$description)) {
result$description <- result$title
}
result$markdown <- paste0(items, collapse = "\n")
}
if (is.null(result)) {
result <- paste0(uncomment(comment), collapse = " \n")
}
result
}
format_roxy_tag <- function(item) {
if (item$tag %in% c("title", "description")) {
tag <- ""
content <- format_roxy_text(item$val)
} else {
tag <- sprintf("`@%s` ", item$tag)
content <- if (item$tag %in% c("usage", "example", "examples", "eval", "evalRd")) {
sprintf("\n```r\n%s\n```", trimws(item$raw))
} else if (is.character(item$val) && length(item$val) > 1) {
paste0(sprintf("`%s`", item$val), collapse = " ")
} else if (is.list(item$val)) {
sprintf("`%s` %s", item$val$name, format_roxy_text(item$val$description))
} else {
format_roxy_text(item$raw)
}
}
paste0(tag, content, " \n")
}
format_roxy_text <- function(text) {
gsub("\n", " \n", text, fixed = TRUE)
}
find_doc_item <- function(doc, tag) {
for (item in doc) {
if (attr(item, "Rd_tag") == tag) {
return(item)
}
}
}
get_help_rd <- function(hfile) {
getNamespace("utils")$.getHelpFile(hfile)
}
get_help <- function(hfile, format = c("html", "text")) {
format <- match.arg(format)
rd <- get_help_rd(hfile)
paths <- as.character(hfile)
if (length(paths) == 0) {
return(NULL)
}
pkgname <- basename(dirname(dirname(paths[[1]])))
if (format == "html") {
result <- paste0(utils::capture.output(
tools::Rd2HTML(rd, package = pkgname, outputEncoding = "UTF-8")
), collapse = "\n")
result <- gsub(".*<body>\n*(.*)\n*</body>.*", "\\1", result)
} else if (format == "text") {
result <- paste0(utils::capture.output(
tools::Rd2txt(rd, package = pkgname, outputEncoding = "UTF-8")
), collapse = "\n")
} else {
stop("Invalid format")
}
enc2utf8(result)
}
convert_doc_to_markdown <- function(doc) {
unlist(lapply(doc, function(item) {
tag <- attr(item, "Rd_tag")
if (is.null(tag)) {
if (length(item)) {
convert_doc_to_markdown(item)
}
} else if (tag == "\\R") {
"**R**"
} else if (tag == "\\dots") {
"..."
} else if (tag %in% c("\\code", "\\env", "\\eqn")) {
sprintf("`%s`", paste0(convert_doc_to_markdown(item), collapse = ""))
} else if (tag %in% c("\\ifelse", "USERMACRO")) {
""
} else if (is.character(item)) {
trimws(item)
} else if (length(item)) {
convert_doc_to_markdown(item)
}
}))
}
convert_doc_string <- function(doc) {
paste0(convert_doc_to_markdown(doc), collapse = " ")
}
glue <- function(.x, ...) {
param <- list(...)
for (key in names(param)) {
.x <- gsub(paste0("{", key, "}"), param[[key]], .x, fixed = TRUE)
}
.x
}
xdoc_find_enclosing_scopes <- function(x, line, col, top = FALSE) {
if (top) {
xpath <- "/exprlist | //expr[(@line1 < {line} or (@line1 = {line} and @col1 <= {col})) and
(@line2 > {line} or (@line2 = {line} and @col2 >= {col}-1))]"
} else {
xpath <- "//expr[(@line1 < {line} or (@line1 = {line} and @col1 <= {col})) and
(@line2 > {line} or (@line2 = {line} and @col2 >= {col}-1))]"
}
xpath <- glue(xpath, line = line, col = col)
xml_find_all(x, xpath)
}
xdoc_find_token <- function(x, line, col) {
xpath <- glue("//*[not(*)][(@line1 < {line} or (@line1 = {line} and @col1 <= {col})) and (@line2 > {line} or (@line2 = {line} and @col2 >= {col}-1))]",
line = line, col = col)
xml_find_first(x, xpath)
}
xml_single_quote <- function(x) {
x <- gsub("'", "'", x, fixed = TRUE)
x
}
html_to_markdown <- function(html) {
html_file <- file.path(tempdir(), "temp.html")
md_file <- file.path(tempdir(), "temp.md")
logger$info("Converting html to markdown using", html_file, md_file)
stringi::stri_write_lines(html, html_file)
result <- tryCatch({
pandoc_version <- rmarkdown::pandoc_version()
format <- if (pandoc_version >= "2.0") "gfm" else "markdown_github"
options <- if (pandoc_version >= "2.11") c("--lua-filter", system.file(package = "languageserver", "lua/html-to-markdown.lua"))
rmarkdown::pandoc_convert(html_file, to = format, output = md_file, options = options)
paste0(stringi::stri_read_lines(md_file, encoding = "utf-8"), collapse = "\n")
}, error = function(e) {
logger$info("html_to_markdown failed: ", conditionMessage(e))
NULL
})
result
}
format_file_size <- function(bytes) {
obj_size <- structure(bytes, class = "object_size")
format(obj_size, units = "auto")
}
is_text_file <- function(path, n = 1000) {
bin <- readBin(path, "raw", n = n)
is_utf8 <- stringi::stri_enc_isutf8(bin)
if (is_utf8) {
return(TRUE)
} else {
result <- stringi::stri_enc_detect(bin)[[1]]
conf <- result$Confidence[1]
if (identical(conf, 1)) {
return(TRUE)
}
}
return(FALSE)
}
compare_position <- function(position1, position2) {
if (position1$line < position2$line ||
(position1$line == position2$line &&
position1$character < position2$character)) {
-1L
} else if (position1$line > position2$line ||
(position1$line == position2$line &&
position1$character > position2$character)) {
1L
} else {
0L
}
}
range_overlap <- function(range1, range2) {
!(compare_position(range1$end, range2$start) < 0 ||
compare_position(range1$start, range2$end) > 0 ||
compare_position(range2$end, range1$start) < 0 ||
compare_position(range2$start, range1$end) > 0)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.