interface for custom pals (simonpcouch#26)

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/gadget.R

@@ -0,0 +1,51 @@
+.pal <- function() {
+  pal_fn <- .pal_app()
+  if (is.null(pal_fn) || identical(pal_fn, "rs_pal_")) {
+    return(NULL)
+  }
+  try_fetch(
+    do.call(pal_fn, args = list()),
+    error = function(e) {
+      cli::cli_abort("Unable to locate the requested pal.")
+    }
+  )
+}
+
+.pal_app <- function() {
+  pal_choices <- list_pals()
+
+  ui <- miniUI::miniPage(
+    miniUI::miniContentPanel(
+      shiny::selectizeInput("pal", "Select a pal:",
+                            choices = NULL,
+                            selected = NULL,
+                            multiple = FALSE
+      ),
+      shiny::verbatimTextOutput("result"),
+      shiny::tags$script(shiny::HTML("
+        $(document).on('keyup', function(e) {
+          if(e.key == 'Enter'){
+            Shiny.setInputValue('done', true, {priority: 'event'});
+          }
+        });
+      "))
+    )
+  )
+
+  server <- function(input, output, session) {
+    shiny::updateSelectizeInput(
+      session, 'pal',
+      choices = pal_choices,
+      server = TRUE
+    )
+    shiny::observeEvent(input$done, {
+      shiny::stopApp(returnValue = paste0("rs_pal_", input$pal))
+    })
+    shiny::onStop(function() {
+      shiny::stopApp(returnValue = NULL)
+    })
+  }
+
+  viewer <- shiny::dialogViewer("Pal", width = 300, height = 10)
+  shiny::runGadget(ui, server, viewer = viewer)
+}

R/pal-add-remove.R

@@ -0,0 +1,84 @@
+#' 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 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
+#' `NULL`, invisibly. Called for its side effect: a pal with role `role`
+#' is registered with the pal package.
+#'
+#' @export
+pal_add <- function(
+    role,
+    prompt = 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 <- .stash_prompt(prompt, role)
+  binding <- parse_interface(interface, role)
+
+  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
+# additional search env
+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)
+}

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
@@ -51,3 +52,8 @@ Pal <- R6::R6Class(
     }
   )
 )
+
+#' @export
+print.pal_response <- function(x, ...) {
+  cat(x)
+}

R/pal.R

@@ -7,11 +7,9 @@
 #' some code, press the keyboard shortcut you've chosen and watch your code
 #' be rewritten.
 #'
-#' @param role The identifier for a pal prompt. Currently one
-#' of `r glue::glue_collapse(paste0("[", glue::double_quote(supported_roles), "]", "[pal_", supported_roles, "]"), ", ", last = " or ")`.
-#' @param keybinding A key binding for the pal. **Currently unused.**
-#' Keybdings have to be registered in the usual way (via Tools >
-#' Modify Keyboard Shortcuts), for now.
+#' @param role The identifier for a pal prompt. By default one
+#' of `r glue::glue_collapse(paste0("[", glue::double_quote(default_roles), "]", "[pal_", supported_roles, "]"), ", ", last = " or ")`.
+#' Add custom pals with [pal_add()].
 #' @param fn A `new_*()` function, likely from the elmer package. Defaults
 #'   to [elmer::chat_claude()]. To set a persistent alternative default,
 #'   set the `.pal_fn` option; see examples below.
@@ -48,10 +46,18 @@
 #' )
 #' @export
 pal <- function(
-    role = NULL, keybinding = NULL,
-    fn = getOption(".pal_fn", default = "chat_claude"), ..., .ns = "elmer"
+    role = NULL,
+    fn = getOption(".pal_fn", default = "chat_claude"),
+    ...,
+    .ns = "elmer"
   ) {
-  check_role(role)
+  check_string(role, allow_empty = FALSE)
+  if (!role %in% list_pals()) {
+    cli::cli_abort(c(
+      "No pals with role {.arg {role}} registered.",
+      "i" = "See {.fn pal_add}."
+    ))
+  }
 
   Pal$new(
     role = role,
@@ -62,4 +68,4 @@ pal <- function(
   )
 }
 
-supported_roles <- c("cli", "testthat", "roxygen")
+default_roles <- c("cli", "testthat", "roxygen")

R/addin.R → R/rstudioapi.R

@@ -1,5 +1,5 @@
 # replace selection with refactored code
-rs_update_selection <- function(context, role) {
+rs_replace_selection <- function(context, role) {
   # check if pal exists
   if (exists(paste0(".last_pal_", role))) {
     pal <- get(paste0(".last_pal_", role))
@@ -155,11 +155,11 @@ rs_prefix_selection <- function(context, role) {
 
 # pal-specific helpers ---------------------------------------------------------
 rs_pal_cli <- function(context = rstudioapi::getActiveDocumentContext()) {
-  rs_update_selection(context = context, role = "cli")
+  rs_replace_selection(context = context, role = "cli")
 }
 
 rs_pal_testthat <- function(context = rstudioapi::getActiveDocumentContext()) {
-  rs_update_selection(context = context, role = "testthat")
+  rs_replace_selection(context = context, role = "testthat")
 }
 
 rs_pal_roxygen <- function(context = rstudioapi::getActiveDocumentContext()) {

R/utils.R

@@ -1,59 +1,63 @@
-#' Save most recent results to search path
-#'
-#' @param x A pal.
-#'
-#' @return NULL, invisibly.
-#'
-#' @details The function will assign `x` to `.last_pal` and put it in
-#' the search path.
-#'
-#' @export
-#' @keywords internal
+# helpers for the pal environment ----------------------------------------------
 .stash_last_pal <- function(x) {
-  if (!"pkg:pal" %in% search()) {
-    do.call("attach", list(new.env(), pos = length(search()),
-                           name = "pkg:pal"))
-  }
-  env <- as.environment("pkg:pal")
-  env[[paste0(".last_pal_", x$role)]] <- x
-  env[[".last_pal"]] <- x
+  pal_env <- pal_env()
+  pal_env[[paste0(".last_pal_", x$role)]] <- x
+  pal_env[[".last_pal"]] <- x
   invisible(NULL)
 }
 
-#' @export
-print.pal_response <- function(x, ...) {
-  cat(x)
+.stash_binding <- function(role, fn) {
+  pal_env <- pal_env()
+  pal_env[[paste0("rs_pal_", role)]] <- fn
+  invisible(NULL)
 }
 
-check_role <- function(role, call = caller_env()) {
-  if (is_missing(role) ||
-      is.null(role) ||
-      !role %in% supported_roles
-  ) {
-    cli::cli_abort(
-      "{.arg role} must be one of {.or {.val {supported_roles}}}.",
-      call = call
-    )
-  }
+.stash_prompt <- function(prompt, role) {
+  pal_env <- pal_env()
+  pal_env[[paste0("system_prompt_", role)]] <- prompt
+  invisible(NULL)
 }
 
-last_pal <- function(pal, call = caller_env()) {
-  if (!is.null(pal)) {
-    return(pal)
+pal_env <- function() {
+  if (!"pkg:pal" %in% search()) {
+    do.call(
+      "attach",
+      list(new.env(), pos = length(search()), name = "pkg:pal")
+    )
   }
+  as.environment("pkg:pal")
+}
 
-  pal_role <- pal$role
+list_pals <- function() {
+  pal_env <- pal_env()
+  pal_env_names <- names(pal_env)
+  prompt_names <- grep("system_prompt_", names(pal_env), value = TRUE)
+  gsub("system_prompt_", "", prompt_names)
+}
 
-  if (exists(paste0(".last_pal_", pal_role))) {
-    return(get(paste0(".last_pal_", pal_role)))
+# ad-hoc check functions -------------------------------------------------------
+check_prompt <- function(prompt, call = caller_env()) {
+  if (inherits(prompt, "pal_prompt")) {
+    return(prompt)
   }
 
-  if (exists(".last_pal")) {
-    return(.last_pal)
+  if (is_markdown_file(prompt)) {
+    if (file.exists(prompt)) {
+      cli::cli_abort(
+        "The markdown file supplied as {.arg prompt} does not exist.",
+        call = call
+      )
+    }
+    prompt <- readLines(prompt)
   }
 
   cli::cli_abort(
-    "Create a pal with {.fn pal} to use this function.",
+    "{.arg prompt} should either be a {.code .md} file or
+     the output of {.fn .pal_prompt}.",
     call = call
   )
 }
+
+is_markdown_file <- function(x) {
+  grepl("\\.(md|markdown)$", x, ignore.case = TRUE)
+}

R/zzz.R

@@ -1,13 +1,17 @@
 # nocov start
 
 .onLoad <- function(libname, pkgname) {
+  pal_env <- pal_env()
+
   prompts <- list.files(system.file("prompts", package = "pal"), full.names = TRUE)
-  for (prompt in prompts) {
-    id <- gsub(".md", "", basename(prompt))
-    rlang::env_bind(
-      rlang::ns_env("pal"),
-      !!paste0(id, "_system_prompt") := paste0(readLines(prompt), collapse = "\n")
-    )
+  roles_and_interfaces <- gsub(".md", "", basename(prompts))
+  roles_and_interfaces <- strsplit(roles_and_interfaces, "-")
+  for (idx in seq_along(prompts)) {
+    role <- roles_and_interfaces[[idx]][1]
+    prompt <- paste0(readLines(prompts[idx]), collapse = "\n")
+    interface <- roles_and_interfaces[[idx]][2]
+
+    pal_add(role = role, prompt = prompt, interface = interface)
   }
 }
 

inst/rstudio/addins.dcf

@@ -1,14 +1,4 @@
-Name: Pal: convert to cli
-Description: Replaces selected erroring code with a version adapted to cli
-Binding: rs_pal_cli
-Interactive: false
-
-Name: Pal: convert to testthat
-Description: Replaces selected unit testing code with a version adapted to testthat 3
-Binding: rs_pal_testthat
-Interactive: false
-
-Name: Pal: template roxygen documentation
-Description: Prefixes selected function with templated roxygen2 documentation
-Binding: rs_pal_roxygen
+Name: Pal
+Description: LLM assistants for R
+Binding: .pal
 Interactive: false