R/completion.R

In ManuelHentschel/vscDebugger: Support for Visual Studio Code Debugger

# type CompletionItemType = 'method' | 'function' | 'constructor' | 'field' | 'variable' |
#   'class' | 'interface' | 'module' | 'property' | 'unit' | 'value' | 'enum' |
#   'keyword' | 'snippet' | 'text' | 'color' | 'file' | 'reference' | 'customcolor';



completionsRequest <- function(response, args, request) {
  # args
  frameIdVsc <- lget(args, 'frameId', 0)
  text <- lget(args, 'text', '')
  column <- lget(args, 'column', 0)
  line <- lget(args, 'line', 1)

  # do stuff
  targets <- list()
  if(getOption('vsc.completionsFromVscDebugger', TRUE)){
    # use our completion tools
    targets <- c(targets, .vsc.getCompletion(frameIdVsc, text, column, line))
  }
  if(getOption('vsc.completionsFromUtils', FALSE)){
    # use the completion tools from package utils
    targets <- c(targets, getCompletionsFromUtils(text, column, line))
  }

  # use only unique labels
  labels <- sapply(targets, function(target) target$label)
  uniqueInd <- !duplicated(labels)
  targets <- targets[uniqueInd]

  # return
  response$body <- list(
    targets = targets
  )
  sendResponse(response)
}

# This function retrieves the input completions generated by utils::XXX
# Is the same as used when e.g. pressing 2xTAB in the console
# Is a bit hacky, but seems to work fine
# Currently has some advantages over 'our' version, which should be fixed in the future
getCompletionsFromUtils <- function(text, column, line){
  # prepare text
  text <- gsub('\r\n', '\n', text) # clean newLines
  lines <- strsplit2(text, '\n') # split into lines
  text <- lines[line] # select correct line

  if(column>1){
    text <- substr(text, 1, column-1)
  }

  # assign current text and cursor position to (utils:::.CompletionEnv)
  utils:::.assignLinebuffer(text)
  utils:::.assignEnd(column)

  # call completion functions
  # arguments were assigned to env beforehand
  token <- utils:::.guessTokenFromLine()
  utils:::.completeToken()
  completions <- utils:::.retrieveCompletions()

  # logCat('Token: ', token, ' - end: ', column, ' - text: ', text, ' - completions:', length(completions), '\n', sep='')

  # return
  # (moving function parameters, e.g. 'a=' to the top of the sorted list)
  targets <- lapply(completions, function(comp){
    sortText <- comp
    lastChar <- substr(comp, nchar(comp), nchar(comp))
    if(nchar(lastChar)>0 && lastChar=='='){
      sortText <- paste0(' ', sortText)
    }
    list(
      label = comp,
      length = nchar(token),
      sortText = sortText
    )
  })
  return(targets)
}
strsplit2 <- function(x, split){
    # add arbitrary character to the end:
    if(split=='_'){
        x <- paste0(x, '*')
    } else{
        x <- paste0(x, '_')
    }
    # apply strsplit:
    v <- strsplit(x, split)[[1]]
    # remove last character:
    w <- v[length(v)]
    w <- substr(w, 1, nchar(w)-1)
    v[length(v)] <- w
    # return:
    v
}


constants <- c("TRUE", "FALSE", "NULL",
  "NA", "NA_integer_", "NA_real_", "NA_complex_", "NA_character_",
  "Inf", "NaN")

getLazyDataFromNamespace <- function(ns) {
  as.character(names(.getNamespaceInfo(ns, "lazydata")))
}

getAttachedPackages <- function() {
  pkgs <- search()
  pkgs <- pkgs[startsWith(pkgs, "package:")]
  pkgs <- gsub("package:", "", pkgs, fixed = TRUE)
  return(pkgs)
}

getInstalledPackages <- function() {
  .packages(all.available = TRUE)
}

.vsc.getCompletion <- function(frameIdVsc, text, column = 0, line = 1, id = 0, onlyGlobalEnv = FALSE) {
  if (column > 1) {
    text <- substring(text, 1, column - 1)
  }
  if (onlyGlobalEnv || !isCalledFromBrowser()) {
    firstenv <- globalenv()
  } else {
    frameId <- convertFrameId(vsc = frameIdVsc)
    if(is.null(frameId)) frameId <- 0
    firstenv <- sys.frame(frameId)
  }
  lastenv <- globalenv()
  envs <- getScopeEnvs(firstenv = firstenv, lastenv = lastenv)

  pattern0 <- "(\\$|\\[\\[|\\[|\\@|:::|::|:)$"
  ind <- regexpr(pattern0, text)
  if (ind != -1) {
    text1 <- substring(text = text, first = 1, last = ind - 1)
    text2 <- substring(text = text, first = ind)
  } else {
    text1 <- text
    text2 <- ""
  }

  var <- getLastVar(text1)

  if (var == "" && text2 != "") {
    # only "$", "[", or "[[" --> no matches
    targets <- list()
  } else if (text2 == "") {
    const_targets <- lapply(constants[startsWith(constants, var)], function(s) list(
      label = s,
      type = 'value'
    ))

    pkgs <- getInstalledPackages()
    pkgs_targets <- lapply(pkgs[startsWith(pkgs, var)], function(s) list(
      label = paste0(s, '::'),
      type = 'module'
    ))

    pattern = paste0("^", var)
    env_targets <- lapply(envs, function(env) {
      names <- ls(env, all.names = TRUE, pattern = pattern, sorted = FALSE)
      lapply(names, function(s) list(
        label = s,
        type = if (isPromise(s, env)) 'variable' else if (is.function(env[[s]])) 'function' else 'variable'
      ))
    })
    env_targets <- unlist(env_targets, recursive = FALSE, use.names = FALSE)

    att_pkgs <- getAttachedPackages()
    att_targets <- lapply(att_pkgs, function(pkg) {
      ns <- getNamespace(pkg)
      exports <- getNamespaceExports(ns)
      lazydata <- getLazyDataFromNamespace(ns)
      c(
        lapply(exports[startsWith(exports, var)], function(s) list(
          label = s,
          type = if (is.function(ns[[s]])) 'function' else 'field'
        )),
        lapply(lazydata[startsWith(lazydata, var)], function(s) list(
          label = s,
          type = 'field'
        ))
      )
    })
    att_targets <- unlist(att_targets, recursive = FALSE, use.names = FALSE)

    targets <- c(const_targets, pkgs_targets, env_targets, att_targets)
  } else {
    # find all children of the last variable
    targets <- getCompletionList(var, text2, envs)
  }
  invisible(targets)
}

getLastVar <- function(text) {
  pattern1 <- "((?:[a-zA-Z]|\\.[a-zA-Z_])[a-zA-Z\\._0-9]*|\\.)$" # matches the beggining of the last valid variable name
  ind <- regexpr(pattern1, text)
  if (ind == -1) {
    return("")
  } else {
    return(substring(text, ind))
  }
}

getCompletionList <- function(var, accessor, envs) {
  targets <- list()
  if (accessor %in% c('[', '[[', '$', '@')) {
    for (env in envs) {
      if (exists(var, env, inherits = FALSE)) {
        if (isPromise(var, env)) {
          if (getOption('vsc.previewPromises', FALSE)) {
            promise <- getPromiseVar(var, env)
            obj <- eval(promise$promiseExpr, promise$promiseEnv)
          } else {
            obj <- NULL
          }
        } else {
          obj <- env[[var]]
        }

        use_bracket <- accessor %in% c('[', '[[')
        use_dollar <- accessor == '$' && is.recursive(obj)
        use_at <- accessor == '@' && isS4(obj)

        if (use_bracket || use_dollar || use_at) {
          if (use_at) {
            names <- slotNames(obj)
          } else {
            names <- names(obj)
          }
          get_label <- if (use_bracket) function(s) paste0('"', s, '"') else identity
          if (is.environment(obj)) {
            targets <- lapply(names, function(s) list(
              label = get_label(s),
              type = if (isPromise(s, obj)) 'variable' else if (is.function(obj[[s]])) 'function' else 'variable'
            ))
          } else if (isS4(obj)) {
            targets <- lapply(names, function(s) list(
              label = get_label(s),
              type = if (is.function(slot(obj, s))) 'function' else 'field'
            ))
          } else if (is.list(obj)) {
            targets <- lapply(names, function(s) list(
              label = get_label(s),
              type = if (is.function(obj[[s]])) 'function' else 'variable'
            ))
          } else {
            targets <- lapply(names, function(s) list(
              label = get_label(s),
              type = 'variable'
            ))
          }
        }
        break
      }
    }
  } else if (accessor == '::') {
    ns <- getNamespace(var)
    exports <- getNamespaceExports(ns)
    lazydata <- getLazyDataFromNamespace(ns)
    targets <- c(
      lapply(exports, function(s) list(
        label = s,
        type = if (is.function(ns[[s]])) 'function' else 'field'
      )),
      lapply(lazydata, function(s) list(
        label = s,
        type = 'field'
      ))
    )
  } else if (accessor == ':::') {
    ns <- getNamespace(var)
    names <- ls(ns)
    targets <- lapply(names, function(s) list(
      label = s,
      type = if (is.function(ns[[s]])) 'function' else 'field'
    ))
  }
  targets
}