spec interface for custom pals

NAMESPACE

@@ -3,6 +3,7 @@
 S3method(print,pal_response)
 export(.stash_last_pal)
 export(pal)
+export(pal_add)
 import(rlang)
 importFrom(elmer,content_image_file)
 importFrom(glue,glue)

R/addin.R

@@ -1,167 +1,101 @@
-# replace selection with refactored code
-rs_update_selection <- function(context, role) {
-  # check if pal exists
-  if (exists(paste0(".last_pal_", role))) {
-    pal <- get(paste0(".last_pal_", role))
-  } else {
-    tryCatch(
-      pal <- pal(role),
-      error = function(e) {
-        rstudioapi::showDialog("Error", "Unable to create a pal. See `?pal()`.")
-        return(NULL)
-      }
-    )
-  }
+pal_addin_append <- function(role, name, description, binding) {
+  lines <- pal_addin_read()
 
-  selection <- rstudioapi::primary_selection(context)
-
-  if (selection[["text"]] == "") {
-    rstudioapi::showDialog("Error", "No code selected. Please highlight some code first.")
-    return(NULL)
-  }
+  addin_list <- pal_addin_parse(lines)
 
-  # make the format of the "final position" consistent
-  selection <- standardize_selection(selection, context)
-  n_lines_orig <- max(selection$range$end[["row"]] - selection$range$start[["row"]], 1)
-
-  # fill selection with empty lines
-  selection <- wipe_selection(selection, context)
-
-  # start streaming
-  tryCatch(
-    stream_selection(selection, context, pal, n_lines_orig),
-    error = function(e) {
-      rstudioapi::showDialog("Error", paste("The pal ran into an issue: ", e$message))
-    }
+  addin_list[[role]] <- list(
+    Name = name,
+    Description = description,
+    Binding = binding,
+    Interactive = "false"
   )
-}
 
-standardize_selection <- function(selection, context) {
-  # if the first entry on a newline, make it the last entry on the line previous
-  if (selection$range$end[["column"]] == 1L) {
-    selection$range$end[["row"]] <- selection$range$end[["row"]] - 1
-    # also requires change to column -- see below
+  lines_new <- pal_addin_unparse(addin_list)
+
+  if (identical(lines, lines_new)) {
+    return(invisible())
   }
 
-  # ensure that models can fill in characters beyond the current selection's
-  selection$range$end[["column"]] <- Inf
+  pal_addin_write(lines_new)
 
-  rstudioapi::setSelectionRanges(selection$range, id = context$id)
+  pal_addin_source()
 
-  selection
+  invisible()
 }
 
-# fill selection with empty lines
-wipe_selection <- function(selection, context) {
-  n_lines_orig <- selection$range$end[["row"]] - selection$range$start[["row"]]
-  empty_lines <- paste0(rep("\n", n_lines_orig), collapse = "")
-  rstudioapi::modifyRange(selection$range, empty_lines, context$id)
-  rstudioapi::setCursorPosition(selection$range$start, context$id)
-  selection
+pal_addin_read <- function() {
+  readLines(system.file("rstudio/addins.dcf", package = "pal"))
 }
 
-stream_selection <- function(selection, context, pal, n_lines_orig) {
-  selection_text <- selection[["text"]]
-  output_lines <- character(0)
-  stream <- pal[[".__enclos_env__"]][["private"]]$.stream(selection_text)
-  coro::loop(for (chunk in stream) {
-    if (identical(chunk, "")) {next}
-    output_lines <- paste(output_lines, sub("\n$", "", chunk), sep = "")
-    n_lines <- nchar(gsub("[^\n]+", "", output_lines)) + 1
-    if (n_lines_orig - n_lines > 0) {
-      output_padded <-
-        paste0(
-          output_lines,
-          paste0(rep("\n", n_lines_orig - n_lines + 1), collapse = "")
-        )
-    } else {
-      output_padded <- paste(output_lines, "\n")
-    }
+pal_addin_write <- function(lines) {
+  writeLines(lines, system.file("rstudio/addins.dcf", package = "pal"))
+}
 
-    rstudioapi::modifyRange(
-      selection$range,
-      output_padded %||% output_lines,
-      context$id
-    )
-
-    # there may be more lines in the output than there are in the range
-    n_selection <- selection$range$end[[1]] - selection$range$start[[1]]
-    n_lines_res <- nchar(gsub("[^\n]+", "", output_padded %||% output_lines))
-    if (n_selection < n_lines_res) {
-      selection$range$end[["row"]] <- selection$range$start[["row"]] + n_lines_res
-    }
+pal_addin_parse <- function(lines) {
+  lines <- lines[nzchar(lines)]
 
-    # `modifyRange()` changes the cursor position to the end of the
-    # range, so manually override
-    rstudioapi::setCursorPosition(selection$range$start)
-  })
-
-  # once the generator is finished, modify the range with the
-  # unpadded version to remove unneeded newlines
-  rstudioapi::modifyRange(
-    selection$range,
-    output_lines,
-    context$id
-  )
+  result <- list()
+  current_entry <- list()
+  current_name <- NULL
 
-  # reindent the code
-  rstudioapi::setSelectionRanges(selection$range, id = context$id)
-  rstudioapi::executeCommand("reindent")
+  for (line in lines) {
 
-  rstudioapi::setCursorPosition(selection$range$start)
-}
+    parts <- strsplit(line, ": ", fixed = TRUE)[[1]]
+    key <- parts[1]
+    value <- paste(parts[-1], collapse = ": ")
 
-# prefix selection with new code -----------------------------------------------
-rs_prefix_selection <- function(context, role) {
-  # check if pal exists
-  if (exists(paste0(".last_pal_", role))) {
-    pal <- get(paste0(".last_pal_", role))
-  } else {
-    tryCatch(
-      pal <- pal(role),
-      error = function(e) {
-        rstudioapi::showDialog("Error", "Unable to create a pal. See `?pal()`.")
-        return(NULL)
+    if (key == "Name") {
+      if (!is.null(current_name)) {
+        result[[current_name]] <- current_entry
       }
-    )
+      current_entry <- list()
+      current_entry[[key]] <- value
+    } else if (key == "Binding") {
+      current_name <- sub("^rs_pal_", "", value)
+      current_entry[[key]] <- value
+    } else {
+      current_entry[[key]] <- value
+    }
   }
 
-  selection <- rstudioapi::primary_selection(context)
-
-  if (selection[["text"]] == "") {
-    rstudioapi::showDialog("Error", "No code selected. Please highlight some code first.")
-    return(NULL)
+  if (!is.null(current_name)) {
+    result[[current_name]] <- current_entry
   }
 
-  # add one blank line before the selection
-  rstudioapi::modifyRange(selection$range, paste0("\n", selection[["text"]]), context$id)
-
-  # make the "current selection" that blank line
-  first_line <- selection$range
-  first_line$start[["column"]] <- 1
-  first_line$end[["row"]] <- selection$range$start[["row"]]
-  first_line$end[["column"]] <- Inf
-  selection$range <- first_line
-  rstudioapi::setCursorPosition(selection$range$start)
-
-  # start streaming into it--will be interactively appended to if need be
-  tryCatch(
-    stream_selection(selection, context, pal, n_lines_orig = 1),
-    error = function(e) {
-      rstudioapi::showDialog("Error", paste("The pal ran into an issue: ", e$message))
-    }
-  )
+  return(result)
 }
 
-# pal-specific helpers ---------------------------------------------------------
-rs_pal_cli <- function(context = rstudioapi::getActiveDocumentContext()) {
-  rs_update_selection(context = context, role = "cli")
-}
+pal_addin_unparse <- function(parsed_list) {
+  lines <- character(0)
 
-rs_pal_testthat <- function(context = rstudioapi::getActiveDocumentContext()) {
-  rs_update_selection(context = context, role = "testthat")
+  for (entry_name in names(parsed_list)) {
+    entry <- parsed_list[[entry_name]]
+
+    for (key in names(entry)) {
+      lines <- c(lines, paste0(key, ": ", entry[[key]]))
+    }
+    lines <- c(lines, "")
+  }
+
+  if (length(lines) > 0 && lines[length(lines)] == "") {
+    lines <- lines[-length(lines)]
+  }
+
+  return(lines)
 }
 
-rs_pal_roxygen <- function(context = rstudioapi::getActiveDocumentContext()) {
-  rs_prefix_selection(context = context, role = "roxygen")
+pal_addin_source <- function() {
+  # TODO: this doesn't quite do the trick, as RStudio will only
+  # look for this flag if "devtools::load_all" is run
+  # 1) interactively and 2) from the console
+  # ref: https://github.com/rstudio/rstudio/blob/adcdcb6fe9a88fe7c16d95d54d796f799f343a6c/src/cpp/session/modules/SessionRAddins.cpp#L55-L63
+  # ref: https://github.com/rstudio/rstudio/blob/adcdcb6fe9a88fe7c16d95d54d796f799f343a6c/src/cpp/session/modules/SessionPackageProvidedExtension.cpp#L221
+  inst_pal <- pkgload::inst("pal")
+  shims_active <- "devtools_shims" %in% search()
+  if (!shims_active) {
+    do.call("attach", list(new.env(), pos = length(search()) + 1,
+                           name = "devtools_shims"))
+    withr::defer(do.call("detach", list(name = "devtools_shims")))
+  }
+  devtools::load_all(inst_pal)
 }

R/pal-add-remove.R

@@ -0,0 +1,112 @@
+#' Creating custom pals
+#'
+#' @description
+#' Users can create custom pals using the `pal_add()` function; after passing
+#' the function a role and prompt, the pal will be available on the command
+#' palette.
+#'
+#' @param role A single string giving the [pal()] role.
+# TODO: actually do this once elmer implements
+#' @param prompt A file path to a markdown file giving the system prompt or
+#' the output of [elmer::interpolate()].
+# TODO: only add prefix when not supplied one
+#' @param name A name for the command palette description; will be prefixed
+#' with "Pal: " for discoverability.
+#' @param description A longer-form description of the functionality of the pal.
+#' @param interface One of `"replace"`, `"prefix"`, or `"suffix"`, describing
+#' how the pal will interact with the selection. For example, the
+#' [cli pal][pal_cli] `"replace"`s the selection, while the
+#' [roxygen pal][pal_roxygen] `"prefixes"` the selected code with documentation.
+#'
+#' @details
+#' `pal_add()` will register the add-in as coming from the pal package
+#' itself—because of this, custom pals will be deleted when the pal
+#' package is reinstalled. Include `pal_add()` code in your `.Rprofile` or
+#' make a pal extension package using `pal_add(package = TRUE)` to create
+#' persistent custom pals.
+#'
+#' @returns
+#' The pal, invisibly. Called for its side effect: an add-in with name
+#' "Pal: `name`" is registered with RStudio.
+#'
+#' @export
+pal_add <- function(
+    role,
+    prompt = NULL,
+    shortcut = NULL,
+    name = NULL,
+    description = NULL,
+    interface = c("replace", "prefix", "suffix")
+) {
+  # TODO: need to check that there are no spaces (or things that can't be
+  # included in a variable name)
+  check_string(role, allow_empty = FALSE)
+  # TODO: make this an elmer interpolate or an .md file
+  #prompt <- check_prompt(prompt)
+  prompt <- .stash_prompt(prompt, role)
+  name <- paste0("Pal: ", name %||% role)
+  description <- description %||% name
+  binding <- parse_interface(interface, role)
+
+  # add a description of the pal to addins.dcf
+  pal_addin_append(
+    role = role,
+    name = name,
+    description = description,
+    binding = binding
+  )
+
+  invisible()
+}
+
+# TODO: fn to remove the addin associated with the role
+pal_remove <- function(role) {
+  invisible()
+}
+
+supported_interfaces <- c("replace", "prefix", "suffix")
+
+# given an interface and role, attaches a function binding in pal's namespace
+# for that role so that the addin can be provided a function.
+parse_interface <- function(interface, role) {
+  if (isTRUE(identical(interface, supported_interfaces))) {
+    interface <- interface[1]
+  }
+  if (isTRUE(
+    length(interface) != 1 ||
+    !interface %in% supported_interfaces
+  )) {
+    cli::cli_abort(
+      "{.arg interface} should be one of {.or {.val {supported_interfaces}}}."
+    )
+  }
+
+  if (interface == "suffix") {
+    # TODO: implement suffixing
+    cli::cli_abort("Suffixing not implemented yet.")
+  }
+
+  .stash_binding(
+    role,
+    function(context = rstudioapi::getActiveDocumentContext()) {
+      do.call(
+        paste0("rs_", interface, "_selection"),
+        args = list(context = context, role = role)
+      )
+    }
+  )
+
+  paste0("rs_pal_", role)
+}
+
+.stash_binding <- function(role, fn) {
+  pal_env <- as.environment("pkg:pal")
+  pal_env[[paste0("rs_pal_", role)]] <- fn
+  invisible(NULL)
+}
+
+.stash_prompt <- function(prompt, role) {
+  pal_env <- as.environment("pkg:pal")
+  pal_env[[paste0("system_prompt_", role)]] <- prompt
+  invisible(NULL)
+}

R/pal-class.R

@@ -7,9 +7,10 @@ Pal <- R6::R6Class(
       default_args <- getOption(".pal_args", default = list())
       args <- modifyList(default_args, args)
 
-      # TODO: make this an environment initialized on onLoad that folks can
-      # register dynamically
-      args$system_prompt <- get(paste0(role, "_system_prompt"), envir = ns_env("pal"))
+      args$system_prompt <- get(
+        paste0("system_prompt_", role),
+        envir = search_envs()[["pkg:pal"]]
+      )
 
       Chat <- rlang::eval_bare(rlang::call2(fn, !!!args, .ns = .ns))
       private$Chat <- Chat

R/pal.R

@@ -51,7 +51,8 @@ pal <- function(
     role = NULL, keybinding = NULL,
     fn = getOption(".pal_fn", default = "chat_claude"), ..., .ns = "elmer"
   ) {
-  check_role(role)
+  # TODO: figure out how to reinstate this check
+  #check_role(role)
 
   Pal$new(
     role = role,