WIP: Tool calling UI

DESCRIPTION

@@ -26,6 +26,7 @@ Imports:
     jsonlite,
     promises (>= 1.3.2),
     rlang,
+    S7,
     shiny (>= 1.10.0)
 Suggests:
     later,

NAMESPACE

@@ -7,6 +7,7 @@ export(chat_clear)
 export(chat_mod_server)
 export(chat_mod_ui)
 export(chat_ui)
+export(contents_shinychat)
 export(markdown_stream)
 export(output_markdown_stream)
 import(rlang)

R/chat.R

@@ -472,6 +472,10 @@ rlang::on_load(
 
       res$add(msg)
 
+      if (S7::S7_inherits(msg, ellmer::Content)) {
+        msg <- contents_shinychat(msg)
+      }
+
       chat_append_message(
         id,
         list(role = role, content = msg),

R/chat_app.R

@@ -106,14 +106,7 @@ chat_mod_ui <- function(id, ..., client = NULL, messages = NULL) {
   if (!is.null(client)) {
     check_ellmer_chat(client)
 
-    client_msgs <- map(client$get_turns(), function(turn) {
-      content <- ellmer::contents_markdown(turn)
-      if (is.null(content) || identical(content, "")) {
-        return(NULL)
-      }
-      list(role = turn@role, content = content)
-    })
-    client_msgs <- compact(client_msgs)
+    client_msgs <- contents_shinychat(client)
 
     if (length(client_msgs)) {
       if (!is.null(messages)) {
@@ -125,10 +118,22 @@ chat_mod_ui <- function(id, ..., client = NULL, messages = NULL) {
     }
   }
 
-  shinychat::chat_ui(
-    shiny::NS(id, "chat"),
-    messages = messages,
-    ...
+  shiny::tagList(
+    shinychat::chat_ui(
+      shiny::NS(id, "chat"),
+      messages = messages,
+      ...
+    ),
+    shiny::includeCSS(system.file(
+      "tools",
+      "tool-request.css",
+      package = "shinychat"
+    )),
+    shiny::includeScript(system.file(
+      "tools",
+      "tool-request.js",
+      package = "shinychat"
+    ))
   )
 }
 
@@ -139,12 +144,27 @@ chat_mod_server <- function(id, client) {
 
   append_stream_task <- shiny::ExtendedTask$new(
     function(client, ui_id, user_input) {
-      promises::then(
-        promises::promise_resolve(client$stream_async(user_input)),
-        function(stream) {
-          chat_append(ui_id, stream)
-        }
+      clear_on_tool_result <- client$on_tool_result(function(result) {
+        session <- shiny::getDefaultReactiveDomain()
+        if (is.null(session)) return()
+        session$sendCustomMessage(
+          "shinychat-hide-tool-request",
+          result@request@id
+        )
+      })
+
+      stream <- client$stream_async(
+        user_input,
+        stream = "content"
       )
+
+      p <- promises::promise_resolve(stream)
+      p <- promises::then(p, function(stream) {
+        chat_append(ui_id, stream)
+      })
+      promises::finally(p, function() {
+        clear_on_tool_result()
+      })
     }
   )
 

R/contents_shinychat.R

@@ -0,0 +1,165 @@
+#' Format ellmer content for shinychat
+#'
+#' @param content An [`ellmer::Content`] object.
+#' @param ... Additional arguments passed to underlying methods.
+#'
+#' @return Returns text or HTML formatted for use in `chat_ui()`.
+#'
+#' @export
+contents_shinychat <- S7::new_generic("contents_shinychat", "content")
+
+S7::method(contents_shinychat, ellmer::Content) <- function(content, ...) {
+  # Fall back to html or markdown
+  html <- ellmer::contents_html(content)
+  if (!is.null(html)) shiny::HTML(html) else ellmer::contents_markdown(content)
+}
+
+S7::method(contents_shinychat, ellmer::ContentText) <- function(content) {
+  content@text
+}
+
+S7::method(contents_shinychat, ellmer::ContentToolRequest) <- function(
+  content,
+  ...
+) {
+  call <- format(content, show = "call")
+  if (length(call) > 1) {
+    call <- sprintf("%s()", content@name)
+  }
+  shiny::HTML(sprintf(
+    '\n\n<p class="shiny-tool-request" data-tool-call-id="%s">Running <code>%s</code></p>\n\n',
+    content@id,
+    call
+  ))
+}
+
+S7::method(contents_shinychat, ellmer::ContentToolResult) <- function(
+  content,
+  ...
+) {
+  pre_code <- function(x) {
+    x <- gsub("`", "&#96;", x, fixed = TRUE)
+    x <- gsub("<", "&lt;", x, fixed = TRUE)
+    x <- gsub(">", "&gt;", x, fixed = TRUE)
+    sprintf("<pre><code>%s</code></pre>", paste(x, collapse = "\n"))
+  }
+
+  if (!is.null(content@error)) {
+    class <- "shiny-tool-result failed"
+    summary_text <- "Failed to call"
+    tool_result <- sprintf(
+      "<strong>Error</strong>%s",
+      pre_code(strip_ansi(content@error))
+    )
+  } else {
+    class <- "shiny-tool-result"
+    summary_text <- "Result from"
+    tool_result <- sprintf(
+      '<strong>Tool Result</strong>%s',
+      pre_code(content@value)
+    )
+  }
+
+  if (!is.null(content@request@tool)) {
+    if (!is.null(content@request@tool@annotations$title)) {
+      # Use the tool title if available
+      tool_name <- content@request@tool@annotations$title
+      summary_text <- ""
+    } else {
+      # Fallback to tool name
+      tool_name <- content@request@tool@name
+    }
+  } else {
+    tool_name <- "unknown tool"
+  }
+
+  intent <- ""
+  if (!is.null(content@request@arguments$intent)) {
+    intent <- sprintf(
+      ' | <span class="intent">%s</span>',
+      content@request@arguments$intent
+    )
+  }
+
+  tool_call <-
+    details_open <- sprintf(
+      '<details class="%s" id="%s">',
+      class,
+      content@request@id
+    )
+
+  summary <- sprintf(
+    '<summary>%s <span class="function-name">%s</span>%s</summary>',
+    summary_text,
+    tool_name,
+    intent
+  )
+
+  tool_call <- sprintf(
+    '<strong>Tool Call</strong>%s',
+    pre_code(format(content@request, show = "call"))
+  )
+
+  body <- sprintf(
+    '<p>%s</p><p>%s</p></details>\n\n',
+    tool_call,
+    tool_result
+  )
+
+  return(shiny::HTML(paste0(details_open, summary, body)))
+}
+
+S7::method(contents_shinychat, ellmer::Turn) <- function(content) {
+  lapply(content@contents, contents_shinychat)
+}
+
+S7::method(contents_shinychat, S7::new_S3_class(c("Chat", "R6"))) <- function(
+  content,
+  ...
+) {
+  # Consolidate tool calls into assistant turns. This currently assumes that
+  # tool calls are always returned in user turns that have at least one
+  # proceeding assistant turn.
+  turns <- map(content$get_turns(), function(turn) {
+    if (
+      all(map_lgl(turn@contents, S7::S7_inherits, ellmer::ContentToolResult))
+    ) {
+      turn@role <- "assistant"
+    }
+    is_tool_request <- map_lgl(
+      turn@contents,
+      S7::S7_inherits,
+      ellmer::ContentToolRequest
+    )
+    turn@contents <- turn@contents[!is_tool_request]
+    turn
+  })
+  turns <- reduce(turns, .init = list(), function(turns, turn) {
+    if (length(turns) == 0) {
+      return(list(turn))
+    }
+
+    # consolidate turns with adjacent roles
+    last_turn <- turns[[length(turns)]]
+    if (identical(last_turn@role, turn@role)) {
+      turns[[length(turns)]]@contents <- c(last_turn@contents, turn@contents)
+      return(turns)
+    }
+
+    c(turns, list(turn))
+  })
+
+  messages <- map(turns, function(turn) {
+    content <- compact(contents_shinychat(turn))
+    if (is.null(content) || identical(content, "")) {
+      return(NULL)
+    }
+    if (every(content, is.character)) {
+      # TODO: Fix chat_ui() to handle lists of strings
+      content <- paste(unlist(content), collapse = "\n\n")
+    }
+    list(role = turn@role, content = content)
+  })
+
+  compact(messages)
+}

R/shinychat-package.R

@@ -11,6 +11,7 @@ NULL
 ignore_unused_imports <- function() {
   jsonlite::fromJSON
   fastmap::fastqueue
+  ellmer::contents_html
 }
 
 release_bullets <- function() {

R/zzz.R

@@ -1,5 +1,6 @@
 .onLoad <- function(libname, pkgname) {
   rlang::run_on_load()
+  S7::methods_register()
 }
 
 as_generator <- function(x) {

inst/tools/tool-request.css

@@ -0,0 +1,108 @@
+.shiny-tool-request {
+    margin: 0;
+    border-radius: var(--bs-border-radius);
+    overflow: hidden;
+    padding: 0.5em;
+    font-size: 0.8em;
+    color: var(--bs-secondary);
+    font-weight: 400;
+    display: block;
+    align-items: center;
+    user-select: none;
+}
+
+.shiny-tool-request::before {
+    content: "\2B05";
+    color: var(--bs-primary);
+    display: inline-block;
+    margin-right: 0.5em;
+    font-size: 1em;
+    transform-origin: center;
+    transform: rotateY(180deg);
+}
+
+.shiny-tool-request:not(:first-child),
+.shiny-tool-result:not(:first-child) {
+    margin-top: 1em;
+}
+
+.shiny-tool-request:first-child + .shiny-tool-result {
+    margin-top: 0;
+}
+
+.shiny-tool-request:not(:last-child),
+.shiny-tool-result:not(:last-child) {
+    margin-bottom: 1em;
+}
+
+.shiny-tool-result + .shiny-tool-result,
+.shiny-tool-request + .shiny-tool-request,
+.shiny-tool-request + .shiny-tool-result,
+.shiny-tool-result + .shiny-tool-request {
+    margin-top: -1rem;
+}
+
+.shiny-tool-result {
+    margin: 0;
+    border-radius: var(--bs-border-radius);
+    overflow: hidden;
+    padding: 0.5em;
+    font-size: 0.8em;
+}
+
+.shiny-tool-result summary {
+    padding: 1em;
+    margin: -0.5em;
+    margin-left: -1em;
+    margin-top: -1em;
+    color: var(--bs-secondary);
+    font-weight: 400;
+    cursor: pointer;
+    display: block;
+    align-items: center;
+    user-select: none;
+}
+
+.shiny-tool-result summary::before {
+    content: "\2714";
+    color: var(--bs-success);
+    display: inline-block;
+    margin-right: 0.5em;
+    font-size: 1em;
+}
+
+.shiny-tool-result.failed summary::before {
+    content: "\2718";
+    color: var(--bs-danger);
+}
+
+.shiny-tool-result[open] summary {
+    margin-bottom: 1em;
+    border-bottom: 1px solid var(--bs-border-color);
+}
+
+.shiny-tool-result summary::marker,
+.shiny-tool-result summary::-webkit-details-marker {
+    display: none;
+}
+
+.shiny-tool-result summary::after {
+    display: inline-block;
+    content: "\25C0";
+    margin-left: 0.5em;
+    font-size: 1em;
+    transition: transform 0.2s;
+}
+
+.shiny-tool-result[open] summary::after {
+    transform: rotate(-90deg);
+}
+
+.shiny-tool-result summary .function-name {
+    font-weight: bold;
+}
+
+.shiny-tool-result summary .intent {
+    color: var(--bs-secondary);
+    font-style: italic;
+}

inst/tools/tool-request.js

@@ -0,0 +1,13 @@
+Shiny.addCustomMessageHandler('shinychat-hide-tool-request', function (id) {
+    let styleSheet = document.getElementById('shinychat-hidden-tool-requests');
+
+    if (!styleSheet) {
+        styleSheet = document.createElement('style');
+        styleSheet.id = 'shinychat-hidden-tool-requests';
+        document.head.appendChild(styleSheet);
+    }
+
+    // Add the rule to the stylesheet
+    const rule = `[data-tool-call-id=\"${id}\"] { display: none !important; }`;
+    styleSheet.sheet.insertRule(rule, styleSheet.sheet.cssRules.length);
+})