@@ -6,15 +6,14 @@
|
||||
`:source-paths`) because those are genuinely needed client-side.
|
||||
|
||||
The page's own chatbot's system prompt is a separate, server-only concern: it lives in
|
||||
tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`,
|
||||
`work-it-out`, `tic-tac-toe-rules` and `examples` from here rather than duplicating them, so the
|
||||
wording stays shared without the chatbot's own instructions being bundled into the browser.
|
||||
tbd.agent.instructions (`src/`, never on the UI's classpath), which reuses `act`, `work-it-out`
|
||||
and `examples` from here rather than duplicating them, so the wording stays shared without the
|
||||
chatbot's own instructions being bundled into the browser.
|
||||
|
||||
It is about acting. A model that is only asked to be helpful answers a request for action with
|
||||
an offer of help, so the text says: call the tool in the same turn, chain the calls, say little
|
||||
afterwards, and the few cases where not to. It is short and concrete on purpose, with examples:
|
||||
the models behind LM Studio follow that better than a long list of rules."
|
||||
(:require [clojure.string :as str]))
|
||||
the models behind LM Studio follow that better than a long list of rules.")
|
||||
|
||||
(def act
|
||||
"Shared with tbd.agent.instructions/chat, the in-page chatbot's own system prompt."
|
||||
@@ -34,18 +33,13 @@
|
||||
" and cannot tell what.\n"
|
||||
chain
|
||||
"- The page changes between messages: the user clicks and types too. A tool result is only what the\n"
|
||||
" page held when it ran, and results from an earlier message are marked out of date. Before you\n"
|
||||
" answer from the page or act on it (a board, a list, an id), read it again with a tool. When the\n"
|
||||
" user says it changed or that you are wrong, read it again first: never go by an earlier result\n"
|
||||
" or by what you said before.\n"
|
||||
"- A call fails: read the error, fix the arguments or read the state, and try once more. No\n"
|
||||
" apologies, no explanation of what went wrong unless it still fails.\n"
|
||||
"\n"))
|
||||
|
||||
(def tic-tac-toe-rules
|
||||
"Shared with tbd.agent.instructions/chat."
|
||||
(str "Tic-tac-toe: check whose turn it is, move only for your own side, one move, then stop and let the\n"
|
||||
"person play theirs.\n"
|
||||
" page held when it ran, so an earlier one may no longer hold. Before you answer from the page or\n"
|
||||
" act on it (a board, a list, an id), get what it holds now — current state if you have it, else\n"
|
||||
" read it again with a tool. When the user says it changed or that you are wrong, check again\n"
|
||||
" first: never go by an earlier result or by what you said before.\n"
|
||||
"- A call fails: the result still comes back to you, with what went wrong. Read it, fix the\n"
|
||||
" arguments or read the state, and try once more. No apologies, no explanation of what went\n"
|
||||
" wrong unless it still fails.\n"
|
||||
"\n"))
|
||||
|
||||
(defn examples
|
||||
@@ -61,8 +55,7 @@
|
||||
"\"untick all my todos\" -> " (when reads? "list_todos -> ") "ONE set_todo_done with every todo in \"todos\" -> "
|
||||
"\"Unticked them all.\"\n"
|
||||
"\"add milk and eggs\" -> ONE create_todo with both titles in \"todos\" -> \"Added both.\"\n"
|
||||
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\"\n"
|
||||
"\"play tic tac toe, you're O\" -> " (when reads? "get_tic_tac_toe -> ") "it is X's turn -> \"You're up, X starts.\""))
|
||||
"\"what's 19 and 4?\" -> add{\"x\":19,\"y\":4} -> \"23.\""))
|
||||
|
||||
;; --- An MCP client outside the page (Claude, Codex) ---
|
||||
|
||||
@@ -90,7 +83,6 @@
|
||||
"was done only if a tool result says it was. Not being logged in is the user's to fix, on the page:\n"
|
||||
"tell them so.\n"
|
||||
"\n"
|
||||
tic-tac-toe-rules
|
||||
(examples true)))
|
||||
|
||||
(defn task
|
||||
@@ -103,17 +95,13 @@
|
||||
(str "The user's request: " request)
|
||||
"Ask the user what they want done in the app, in a sentence, and do that.")))
|
||||
|
||||
(defn tic-tac-toe
|
||||
"The prompt of a game of tic-tac-toe with the person at the page, for an outside agent playing
|
||||
`side`: \"x\" or \"o\" (anything else is \"o\": X goes first, so the person, who has the board in
|
||||
front of them, starts)."
|
||||
[side]
|
||||
(let [side (if (contains? #{"x" "o"} side) side "o")]
|
||||
(str "You are playing tic-tac-toe on the app's page against the person who has it open, as "
|
||||
(str/upper-case side) ". The tools are get_tic_tac_toe, move_tic_tac_toe and new_tic_tac_toe_game.\n"
|
||||
"\n"
|
||||
"Read the game with get_tic_tac_toe. If it is your side's turn, make one move with\n"
|
||||
"move_tic_tac_toe and stop: never move for the other side, that is the person's, made on the\n"
|
||||
"page. If it is not your side's turn, say so in a few words and wait for the person to tell\n"
|
||||
"you they have moved; don't poll. Then read the game again and go on. When it is over, say\n"
|
||||
"who won, or that it is a draw, and don't start another game unless asked.")))
|
||||
(def tic-tac-toe
|
||||
"The prompt of a game of tic-tac-toe with the person at the page, for an outside agent. Names
|
||||
only the tools: get_tic_tac_toe, move_tic_tac_toe and their descriptions carry the rest — whose
|
||||
turn it is, which side is whose, what a move is refused for — so the agent drives from those and
|
||||
the game's state, and works out which side it plays from how the conversation started, rather
|
||||
than the prompt assigning one. Starting over is the person's: their page has its own New game
|
||||
button, no tool for it."
|
||||
(str "You are playing tic-tac-toe with the person on the app's page. The tools are get_tic_tac_toe "
|
||||
"and move_tic_tac_toe. Starting a new game is the person's to do, on the page: there is no "
|
||||
"tool for it."))
|
||||
|
||||
+95
-38
@@ -20,7 +20,10 @@
|
||||
the caller's job.
|
||||
|
||||
Every turn is traced (see tbd.chat.trace): what was asked, how the reply went, and whether the
|
||||
model looks stuck in a loop. The config's `:trace` says where that goes."
|
||||
model looks stuck in a loop. The config's `:trace` says where that goes. A turn that does loop is
|
||||
not just left running (a model that loops keeps generating, so it is never silent long enough for
|
||||
a timeout to catch it) nor simply failed: `pump` cancels it and retries once, nudged to answer, an
|
||||
error only if that loops too — see `pump`."
|
||||
(:require [clojure.string :as str]
|
||||
[tbd.agent.json-schema :as json-schema]
|
||||
[tbd.chat.trace :as trace])
|
||||
@@ -152,6 +155,19 @@
|
||||
(println (cond-> (str "[tbd] chat: " text) detail (str " (" detail ")")))
|
||||
text))
|
||||
|
||||
(defn- loop-abort-text
|
||||
"What the user is told when a retried turn (see `pump`) still loops."
|
||||
[{:keys [kind]}]
|
||||
(case kind
|
||||
:repeated-thinking "the model got stuck repeating itself, and the reply was stopped"
|
||||
:long-reasoning "the model's reasoning went on without end, and the reply was stopped"))
|
||||
|
||||
(def ^:private loop-nudge
|
||||
"Appended to the system prompt for the one retry `pump` gives a turn that loops (see its
|
||||
docstring): blunt, since reasoning that has not converged in thousands of characters is not
|
||||
going to be talked into converging gently."
|
||||
"\n\nYou have been reasoning for a long time without answering. Stop reasoning now: give your final answer immediately, or call the tool you need.")
|
||||
|
||||
(defn- streaming-handler
|
||||
"A StreamingChatResponseHandler that pushes every callback onto `queue` as a map: {:content s},
|
||||
{:thinking s}, {:tool-call {:id :name :arguments}} (once a call is fully assembled — LangChain4j
|
||||
@@ -195,14 +211,40 @@
|
||||
(defn- finish-reason-of [^ChatResponse response]
|
||||
(some-> (.finishReason response) str str/lower-case))
|
||||
|
||||
(defn- send-request!
|
||||
"Sends `system-text`/`messages`/`tools`, and waits (up to `timeout-seconds`) for the first sign of
|
||||
life: {:ok {:queue :handle-atom :first-item}}, or {:error text :detail text} for an LLM that is
|
||||
down, refuses, or stays silent too long — so that is a clean error instead of one inside a stream
|
||||
that has already begun. Used for the turn's first attempt (see `start`) and, unlike it, for the
|
||||
retry `pump` sends after a turn that loops."
|
||||
[config system-text messages tools timeout-seconds]
|
||||
(try
|
||||
(let [queue (LinkedBlockingQueue.)
|
||||
handle-atom (atom nil)
|
||||
handler (streaming-handler queue #(reset! handle-atom %))]
|
||||
(.chat (chat-model config) (chat-request system-text messages tools) handler)
|
||||
(if-let [first-item (.poll queue (long timeout-seconds) TimeUnit/SECONDS)]
|
||||
(if (:error first-item)
|
||||
{:error "the LLM server can't be reached or refused" :detail (exception-detail (:error first-item))}
|
||||
{:ok {:queue queue :handle-atom handle-atom :first-item first-item}})
|
||||
{:error "the LLM server took too long to answer" :detail (str timeout-seconds "s of silence")}))
|
||||
(catch Exception e
|
||||
{:error "the LLM server can't be reached" :detail (exception-detail e)})))
|
||||
|
||||
(defn- pump
|
||||
"Drains `queue`, starting from the already-polled `first-item` (see `start`, which peeks one item
|
||||
before deciding {:ok}/{:error}), calling `emit` with each event (see the ns docstring).
|
||||
`timeout-seconds` of silence between items is an error, closing the stream via `handle-atom` (a
|
||||
StreamingHandle, once one has arrived). An exception from `emit` (the client went away, say) ends
|
||||
it too, closing the stream, and is rethrown. `tracer` (see tbd.chat.trace) sees everything the
|
||||
LLM says, and how the turn ended, before the client is told."
|
||||
[^LinkedBlockingQueue queue handle-atom timeout-seconds emit tracer first-item]
|
||||
"Drains `queue`, starting from the already-polled `first-item` (see `start`/`send-request!`, which
|
||||
peek one item before deciding {:ok}/{:error}), calling `emit` with each event (see the ns
|
||||
docstring). `timeout-seconds` of silence between items is an error, closing the stream via
|
||||
`handle-atom` (a StreamingHandle, once one has arrived).
|
||||
|
||||
A model stuck in a loop is never silent, so that timeout never catches it; `tracer` (see
|
||||
tbd.chat.trace/observe!) watches for it instead. The first time a turn loops (`retried?` false),
|
||||
the stream is cancelled and sent again — same `system-text`, with `loop-nudge` appended, same
|
||||
`messages`/`tools` — as a fresh, separately traced attempt; a caller only sees this as a pause; a
|
||||
turn that loops again on the retry, or that fails to even start it, is an error. An exception from
|
||||
`emit` (the client went away, say) ends the attempt too, closing the stream, and is rethrown."
|
||||
[config system-text messages tools timeout-seconds emit tracer
|
||||
^LinkedBlockingQueue queue handle-atom first-item retried?]
|
||||
(let [timer (atom nil)
|
||||
timed-out? (atom false)
|
||||
cancel-stream! (fn []
|
||||
@@ -212,7 +254,20 @@
|
||||
(some-> ^ScheduledFuture @timer (.cancel false))
|
||||
(reset! timer (.schedule ^ScheduledThreadPoolExecutor @watchdog
|
||||
^Runnable (fn [] (reset! timed-out? true) (cancel-stream!))
|
||||
(long timeout-seconds) TimeUnit/SECONDS)))]
|
||||
(long timeout-seconds) TimeUnit/SECONDS)))
|
||||
retry! (fn []
|
||||
(cancel-stream!)
|
||||
(some-> ^ScheduledFuture @timer (.cancel false))
|
||||
(let [nudged-text (str system-text loop-nudge)
|
||||
tracer' (trace/begin! (:trace config) {:messages messages :tools tools :model (:model config)
|
||||
:system-text nudged-text})
|
||||
{:keys [ok error detail]} (send-request! config nudged-text messages tools timeout-seconds)]
|
||||
(if error
|
||||
(let [text (fail error detail)]
|
||||
(trace/finish! tracer' {:outcome :upstream-error :error text :detail detail})
|
||||
(emit {:error text}))
|
||||
(pump config nudged-text messages tools timeout-seconds emit tracer'
|
||||
(:queue ok) (:handle-atom ok) (:first-item ok) true))))]
|
||||
(arm!)
|
||||
(try
|
||||
(loop [item first-item
|
||||
@@ -254,12 +309,23 @@
|
||||
(emit {:error text}))))
|
||||
|
||||
:else
|
||||
(do (arm!)
|
||||
(trace/observe! tracer (select-keys item [:content :thinking]))
|
||||
(when-let [out (not-empty (select-keys item [:content :thinking]))] (emit out))
|
||||
(recur (.take queue)
|
||||
(or replied? (contains? item :content))
|
||||
(cond-> calls (:tool-call item) (conj (:tool-call item)))))))
|
||||
(let [abort (trace/observe! tracer (select-keys item [:content :thinking]))]
|
||||
(when-let [out (not-empty (select-keys item [:content :thinking]))] (emit out))
|
||||
(cond
|
||||
(and abort (not retried?))
|
||||
(do (trace/finish! tracer {:outcome :looped}) (retry!))
|
||||
|
||||
abort
|
||||
(let [text (fail (loop-abort-text abort))]
|
||||
(trace/finish! tracer {:outcome :error :error text})
|
||||
(cancel-stream!)
|
||||
(emit {:error text}))
|
||||
|
||||
:else
|
||||
(do (arm!)
|
||||
(recur (.take queue)
|
||||
(or replied? (contains? item :content))
|
||||
(cond-> calls (:tool-call item) (conj (:tool-call item)))))))))
|
||||
(finally
|
||||
(trace/finish! tracer {:outcome :aborted})
|
||||
(some-> ^ScheduledFuture @timer (.cancel false))
|
||||
@@ -271,29 +337,20 @@
|
||||
(the agent's own system prompt, see tbd.agent.instructions — composed by the caller, not the
|
||||
browser). Waits for the first sign of life from the model (a piece of its reply, or an error) so
|
||||
that an LLM that is down or refuses is still a clean {:error text :kind :unavailable|:upstream},
|
||||
not an error inside a stream that has already begun — the same contract the old hand-rolled HTTP
|
||||
client gave, adapted to LangChain4j's async callbacks (which have no separate \"got the HTTP
|
||||
response\" moment to block on the way a blocking HTTP client's `.send()` did). Otherwise {:ok
|
||||
pump}: `(pump emit)` blocks until the reply is complete, calling `emit` with its events (see the
|
||||
ns docstring). If `emit` throws, the request to the LLM is closed (which stops it generating) and
|
||||
the exception is rethrown."
|
||||
not an error inside a stream that has already begun. Otherwise {:ok pump}: `(pump emit)` blocks
|
||||
until the reply is complete (retrying once, on its own, if the model loops — see `pump`), calling
|
||||
`emit` with its events (see the ns docstring). If `emit` throws, the request to the LLM is closed
|
||||
(which stops it generating) and the exception is rethrown."
|
||||
[{:keys [timeout-seconds trace] :as config} system-text messages tools]
|
||||
(if-not (configured? config)
|
||||
{:error "chat is not configured" :kind :unavailable}
|
||||
(let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)})
|
||||
upstream-error (fn [text detail]
|
||||
(fail text detail)
|
||||
(trace/finish! tracer {:outcome :upstream-error :error text :detail detail})
|
||||
{:error text :kind :upstream})]
|
||||
(try
|
||||
(let [queue (LinkedBlockingQueue.)
|
||||
handle-atom (atom nil)
|
||||
handler (streaming-handler queue #(reset! handle-atom %))]
|
||||
(.chat (chat-model config) (chat-request system-text messages tools) handler)
|
||||
(if-let [first-item (.poll queue (long timeout-seconds) TimeUnit/SECONDS)]
|
||||
(if (:error first-item)
|
||||
(upstream-error "the LLM server can't be reached or refused" (exception-detail (:error first-item)))
|
||||
{:ok (fn [emit] (pump queue handle-atom timeout-seconds emit tracer first-item))})
|
||||
(upstream-error "the LLM server took too long to answer" (str timeout-seconds "s of silence"))))
|
||||
(catch Exception e
|
||||
(upstream-error "the LLM server can't be reached" (exception-detail e)))))))
|
||||
(let [tracer (trace/begin! trace {:messages messages :tools tools :model (:model config)
|
||||
:system-text system-text})
|
||||
{:keys [ok error detail]} (send-request! config system-text messages tools timeout-seconds)]
|
||||
(if error
|
||||
(do (fail error detail)
|
||||
(trace/finish! tracer {:outcome :upstream-error :error error :detail detail})
|
||||
{:error error :kind :upstream})
|
||||
{:ok (fn [emit]
|
||||
(pump config system-text messages tools timeout-seconds emit tracer
|
||||
(:queue ok) (:handle-atom ok) (:first-item ok) false))}))))
|
||||
|
||||
@@ -4,8 +4,8 @@
|
||||
on purpose: unlike tbd.agent.prompt (a .cljc the browser bundle also needs, for WebMCP's
|
||||
`guide`/`task`/`tic-tac-toe`), this ns is never on ui/shadow-cljs.edn's `:source-paths`, so the
|
||||
chatbot's own instructions can never end up in the compiled UI. It reuses the wording that is
|
||||
genuinely shared (`act`, `work-it-out`, `tic-tac-toe-rules`, `examples`) from tbd.agent.prompt
|
||||
rather than duplicating it."
|
||||
genuinely shared (`act`, `work-it-out`, `examples`) from tbd.agent.prompt rather than
|
||||
duplicating it."
|
||||
(:require [clojure.string :as str]
|
||||
[jsonista.core :as json]
|
||||
[tbd.agent.prompt :as prompt]))
|
||||
@@ -30,7 +30,6 @@
|
||||
"Answer those in a sentence or two, with no tool call. Asked what you can do, say it plainly from\n"
|
||||
"the tools you have. Think briefly before you act.\n"
|
||||
"\n"
|
||||
prompt/tic-tac-toe-rules
|
||||
(prompt/examples false)))
|
||||
|
||||
(defn chat-system-message
|
||||
@@ -47,9 +46,9 @@
|
||||
" tools: " (str/join ", " (map :name tools))
|
||||
". The tools of other pages are offered once you navigate there.")
|
||||
(seq state) (str "\n\nCurrent state of the page (JSON), refreshed on every message you get, so it is\n"
|
||||
"always current, more current than anything said earlier in this conversation, a tool\n"
|
||||
"result marked out of date, or what you said before — never call a tool just to read it,\n"
|
||||
"only to act:\n" (json/write-value-as-string state))))
|
||||
"always current — more current than anything said earlier in this conversation, any\n"
|
||||
"tool result in it, or what you said before. Go by this, not an earlier result:\n"
|
||||
"never call a tool just to read it, only to act:\n" (json/write-value-as-string state))))
|
||||
|
||||
(defn a2a
|
||||
"The A2A server's system prompt: an outside agent calling this app directly, not through a
|
||||
|
||||
+24
-4
@@ -112,11 +112,26 @@
|
||||
than max-messages, since this is scrollback for the user, not context for the LLM."
|
||||
100)
|
||||
|
||||
(def max-history-content-length
|
||||
"The longest tool result, or reply's reasoning, /api/chat/history stores: far over
|
||||
`max-message-length` (what the LLM is sent), since the stored conversation is the whole log for
|
||||
\"Expand tool use\"/\"Show reasoning\" to show after a reload, not context for the LLM."
|
||||
100000)
|
||||
|
||||
(def max-history-length
|
||||
"How long the stored conversation may be, printed, all told (see tbd.ui.events/storable, which
|
||||
drops its oldest messages to stay within it)."
|
||||
1000000)
|
||||
|
||||
(defn- small-history? [{:keys [messages]}]
|
||||
(<= (count (pr-str messages)) max-history-length))
|
||||
|
||||
(def HistoryMessage
|
||||
"A message as the browser's own :chat :messages keeps it (see tbd.ui.db), not AG-UI's wire
|
||||
Message: /api/chat/history is this app's own addition, not part of the AG-UI run protocol, so it
|
||||
round-trips the client's fields as-is (kebab-case, and a tool result's :name/:error? for
|
||||
display, which AG-UI's Message has no place for) instead of forcing them through Message's shape."
|
||||
round-trips the client's fields as-is (kebab-case, a tool result's :name/:error?, and an
|
||||
assistant reply's :thinking, for display, which AG-UI's Message has no place for) instead of
|
||||
forcing them through Message's shape."
|
||||
[:multi {:dispatch :role}
|
||||
["user" [:map
|
||||
[:role [:= "user"]]
|
||||
@@ -125,6 +140,9 @@
|
||||
[:map
|
||||
[:role [:= "assistant"]]
|
||||
[:content {:optional true} [:string {:max max-message-length}]]
|
||||
[:thinking {:optional true} [:string {:max max-history-content-length}]]
|
||||
;; the user halted the reply before it was over (see tbd.ui.events/::chat-halt)
|
||||
[:halted? {:optional true} :boolean]
|
||||
[:tool-calls {:optional true}
|
||||
[:vector {:max max-tool-calls}
|
||||
[:map
|
||||
@@ -136,12 +154,14 @@
|
||||
[:role [:= "tool"]]
|
||||
[:tool-call-id Id]
|
||||
[:name {:optional true} [:string {:max 200}]]
|
||||
[:content [:string {:min 1 :max max-message-length}]]
|
||||
[:content [:string {:min 1 :max max-history-content-length}]]
|
||||
[:error? {:optional true} :boolean]]]])
|
||||
|
||||
(def History
|
||||
"The body of a PUT to /api/chat/history: the browser's whole conversation, oldest first."
|
||||
[:map [:messages [:vector {:max max-history-messages} HistoryMessage]]])
|
||||
[:and
|
||||
[:map [:messages [:vector {:max max-history-messages} HistoryMessage]]]
|
||||
[:fn small-history?]])
|
||||
|
||||
(defn page-of
|
||||
"The `page` context entry's value, or nil."
|
||||
|
||||
+44
-14
@@ -14,17 +14,21 @@
|
||||
conversation each request carries.
|
||||
|
||||
Every turn is one `tracer`: `begin!` when the request goes out (logs `:turn-start`), `observe!` for
|
||||
each event of the reply (logs a `:loop-suspect` when one of the above trips), `finish!` when it ends
|
||||
(logs `:turn-end`, with the outcome, timings, sizes and flags). A tracer is for one thread, the one
|
||||
that reads the reply.
|
||||
each event of the reply (logs a `:loop-suspect` when one of the above trips, and, past
|
||||
`repeat-abort-count`/`long-reasoning-abort-chars`, tells the caller to stop the turn — a model
|
||||
that loops keeps generating, so it never goes silent long enough for a timeout to catch it),
|
||||
`finish!` when it ends (logs `:turn-end`, with the outcome, timings, sizes and flags). A tracer is
|
||||
for one thread, the one that reads the reply.
|
||||
|
||||
Turns are correlated by `req` (one per turn) and `run` (a hash of the user's last message, the same
|
||||
for every turn of the tool loop it started), with `step` counting the turns of the run from 0.
|
||||
|
||||
Entries are maps that go to a `sink`. `sink` prints each as one `[tbd] chat <event> k=v ...` line and,
|
||||
if given a file, appends it there as JSON. Only the file has the text of the reasoning and the reply
|
||||
(`:reasoning`, `:reply`) and the run's messages (`:input`): they are what you read to see why a
|
||||
model is looping, and they are the user's words, so they are off unless a file is asked for
|
||||
(`:reasoning`, `:reply`), the run's messages (`:input`), and the turn's system prompt (`:system-text`,
|
||||
the \"Current state of the page\" it was told included — see tbd.agent.instructions/chat-system-message):
|
||||
they are what you read to see why a model is looping, or confused about the state it was acting on,
|
||||
and they are the user's words (or the app's data), so they are off unless a file is asked for
|
||||
(CHAT_TRACE_FILE, see tbd.agent.core/env-config)."
|
||||
(:require [clojure.java.io :as io]
|
||||
[clojure.string :as str]
|
||||
@@ -48,6 +52,17 @@
|
||||
"The same tool called with the same arguments this many times in one run is a `:repeated-call`."
|
||||
3)
|
||||
|
||||
(def repeat-abort-count
|
||||
"A sentence said this many times is not a false positive anymore: `observe!` says to stop the
|
||||
turn. A milestone of `repeat-warn-count` (see `repeat-milestone?`), so it is always hit exactly,
|
||||
not stepped over."
|
||||
64)
|
||||
|
||||
(def long-reasoning-abort-chars
|
||||
"Reasoning still going, without an answer or a call, at this many characters: `observe!` says to
|
||||
stop the turn. A milestone of `reasoning-warn-chars` (each doubling), for the same reason."
|
||||
32000)
|
||||
|
||||
(def ^:private max-distinct-sentences 5000)
|
||||
(def ^:private max-pending-chars 1000)
|
||||
(def ^:private max-args-length 500)
|
||||
@@ -162,7 +177,7 @@
|
||||
|
||||
(def ^:private heavy-fields
|
||||
"What only the trace file gets."
|
||||
#{:reasoning :reply :input})
|
||||
#{:reasoning :reply :input :system-text})
|
||||
|
||||
(defn- render-field [k v]
|
||||
(str (name k) "="
|
||||
@@ -220,9 +235,12 @@
|
||||
|
||||
(defn begin!
|
||||
"Starts tracing a turn, and logs `:turn-start`; `messages`, `tools` and `page` are the request's, and
|
||||
`model` the LLM's, if the config names one. `trace` is a config of `config-for`, or nil for
|
||||
`default-config`. Returns the tracer."
|
||||
[trace {:keys [messages tools page model]}]
|
||||
`model` the LLM's, if the config names one. `system-text` is the turn's system prompt (see
|
||||
tbd.agent.instructions/chat-system-message) — with `full-text?` on, it goes to the trace file too,
|
||||
since it is the only place the page's state (whose turn it is, a board, a list) as the model was
|
||||
actually told it, rather than as the model later recalls it in its reasoning, is ever recorded.
|
||||
`trace` is a config of `config-for`, or nil for `default-config`. Returns the tracer."
|
||||
[trace {:keys [messages tools page model system-text]}]
|
||||
(let [{:keys [sink full-text?]} (or trace default-config)
|
||||
{:keys [run step run-calls top-call input]} (run-summary messages)
|
||||
tracer {:sink sink :full-text? full-text?
|
||||
@@ -234,27 +252,39 @@
|
||||
(cond-> {:page page :model model :messages (count messages) :tools (count tools)
|
||||
:prompt-chars (transduce (map #(count (:content %))) + 0 messages)
|
||||
:run-calls run-calls}
|
||||
full-text? (assoc :input input)))
|
||||
full-text? (assoc :input input :system-text system-text)))
|
||||
(when (and top-call (>= (:count top-call) repeated-call-warn-count))
|
||||
(log! tracer :loop-suspect {:kind :repeated-call :tool (:tool top-call) :count (:count top-call)
|
||||
:args (truncate (:args top-call) sample-length)}))
|
||||
tracer))
|
||||
|
||||
(defn- abortable [alert]
|
||||
(case (:kind alert)
|
||||
:repeated-thinking (when (>= (:count alert) repeat-abort-count) alert)
|
||||
:long-reasoning (when (>= (:chars alert) long-reasoning-abort-chars) alert)
|
||||
nil))
|
||||
|
||||
(defn observe!
|
||||
"Takes one event of the LLM's reply (see tbd.agent.core, whose pump calls this: :content, :thinking,
|
||||
or, at the end of a turn, :finish-reason and :usage), logging a `:loop-suspect` if the reasoning has
|
||||
gone on for long, or is repeating itself."
|
||||
gone on for long, or is repeating itself. Returns the alert to stop the turn over (see
|
||||
`repeat-abort-count`/`long-reasoning-abort-chars`), or nil to keep going: a model that repeats
|
||||
itself, or reasons on forever, does so at every following event too, so the caller does not have
|
||||
to wait for the silence-timeout that a model still actively (if uselessly) generating never trips."
|
||||
[{:keys [state full-text?] :as tracer} event]
|
||||
(let [[state' alerts] (advance @state event (now-ms) full-text?)]
|
||||
(reset! state (update state' :flags into (map :kind) alerts))
|
||||
(doseq [alert alerts]
|
||||
(log! tracer :loop-suspect alert))))
|
||||
(log! tracer :loop-suspect alert))
|
||||
(some abortable alerts)))
|
||||
|
||||
(defn finish!
|
||||
"Ends the turn, logging `:turn-end`; only the first call does anything, so it is safe to call
|
||||
again in a `finally`. `outcome` is a map: {:outcome :done | :tool-calls | :error | :upstream-error
|
||||
| :aborted, :calls [{:name :arguments}] for :tool-calls, :error text and :detail text for the
|
||||
failures}. :aborted is a turn that just stopped (the client went away, or something threw)."
|
||||
| :looped | :aborted, :calls [{:name :arguments}] for :tool-calls, :error text and :detail text
|
||||
for the failures}. :aborted is a turn that just stopped (the client went away, or something
|
||||
threw); :looped is one tbd.agent.core/pump cut short and retried because it was stuck (see
|
||||
`observe!`) — the retry is a turn of its own, with its own `:turn-start`/`:turn-end`."
|
||||
[{:keys [state full-text?] :as tracer} {:keys [outcome calls error detail]}]
|
||||
(let [s @state]
|
||||
(when-not (:finished? s)
|
||||
|
||||
@@ -1,7 +1,13 @@
|
||||
(ns tbd.agent.core-test
|
||||
(:require [clojure.test :refer [deftest is testing]]
|
||||
[tbd.agent.core :as agent]
|
||||
[tbd.agent.test-support :as ts]))
|
||||
[tbd.agent.test-support :as ts]
|
||||
[tbd.chat.trace :as trace])
|
||||
(:import (dev.langchain4j.data.message AiMessage SystemMessage)
|
||||
(dev.langchain4j.model.chat.request ChatRequest)
|
||||
(dev.langchain4j.model.chat.response PartialResponse PartialResponseContext
|
||||
PartialThinking PartialThinkingContext)
|
||||
(dev.langchain4j.model.output FinishReason)))
|
||||
|
||||
(defn- turn! [config messages tools]
|
||||
(let [{:keys [ok error kind]} (agent/start config "system prompt" messages tools)]
|
||||
@@ -53,6 +59,47 @@
|
||||
(is (= {:error "chat is not configured" :kind :unavailable} (turn! config [] nil)))
|
||||
(is (zero? @calls)))))
|
||||
|
||||
(deftest a-loop-is-retried-once-then-recovers
|
||||
(testing "a turn that repeats itself is cut short and sent again, nudged to answer; the retry's
|
||||
reply is what the caller sees, not a failure"
|
||||
(let [calls (atom 0)
|
||||
reqs (atom [])
|
||||
sentence "Wait, let me check the board again. "
|
||||
model (ts/model-of
|
||||
(fn [req handler]
|
||||
(swap! reqs conj req)
|
||||
(let [h (ts/fake-handle)]
|
||||
(if (= 1 (swap! calls inc))
|
||||
(dotimes [_ trace/repeat-abort-count]
|
||||
(.onPartialThinking handler (PartialThinking. ^String sentence) (PartialThinkingContext. h)))
|
||||
(do (.onPartialResponse handler (PartialResponse. "ok") (PartialResponseContext. h))
|
||||
(ts/complete handler (AiMessage/from "ok") FinishReason/STOP [10 5]))))))
|
||||
{:keys [events]} (turn! (ts/config model) [{:role "user" :content "hi"}] nil)]
|
||||
(is (= 2 @calls) "the model is asked again, once, after the loop")
|
||||
(is (= [{:content "ok"} {:done true}] (take-last 2 events))
|
||||
"the retry's reply is what the caller ends up seeing")
|
||||
(is (= trace/repeat-abort-count (count (filter #(= {:thinking sentence} %) events)))
|
||||
"the caller still sees what the model was thinking before it was cut off")
|
||||
(is (not-any? :error events) "a loop that recovers is not shown to the user as a failure")
|
||||
(is (not (re-find #"Stop reasoning now" (.text ^SystemMessage (first (.messages ^ChatRequest (first @reqs))))))
|
||||
"the first attempt's prompt is unchanged")
|
||||
(is (re-find #"Stop reasoning now" (.text ^SystemMessage (first (.messages ^ChatRequest (second @reqs)))))
|
||||
"the retry's prompt has the nudge appended"))))
|
||||
|
||||
(deftest a-loop-that-does-not-recover-is-an-error
|
||||
(testing "only one retry is made: a turn that loops again on the retry is finally an error"
|
||||
(let [calls (atom 0)
|
||||
sentence "Wait, let me check the board again. "
|
||||
model (ts/model-of
|
||||
(fn [_ handler]
|
||||
(swap! calls inc)
|
||||
(let [h (ts/fake-handle)]
|
||||
(dotimes [_ trace/repeat-abort-count]
|
||||
(.onPartialThinking handler (PartialThinking. ^String sentence) (PartialThinkingContext. h))))))
|
||||
{:keys [events]} (turn! (ts/config model) [{:role "user" :content "hi"}] nil)]
|
||||
(is (= 2 @calls) "the retry itself is not retried again")
|
||||
(is (= {:error "the model got stuck repeating itself, and the reply was stopped"} (last events))))))
|
||||
|
||||
(deftest conversation-history-round-trips
|
||||
(testing "assistant messages with tool calls, and their tool-role results, reach the model
|
||||
without error (see tbd.agent.core/llm-message)"
|
||||
|
||||
@@ -15,7 +15,6 @@
|
||||
(is (str/includes? text "in this same turn"))
|
||||
(is (str/includes? text "Work it out yourself:"))
|
||||
(is (str/includes? text "Say something was done only if a tool result says it was"))
|
||||
(is (str/includes? text "Tic-tac-toe: check whose turn it is"))
|
||||
(is (str/includes? text "Examples: "))))
|
||||
|
||||
(deftest chat-is-framed-as-the-in-page-chatbot
|
||||
|
||||
@@ -14,10 +14,9 @@
|
||||
(is (str/includes? text "in this same turn"))
|
||||
(is (str/includes? text "Work it out yourself:"))
|
||||
(is (str/includes? text "Chain calls without stopping"))
|
||||
(is (str/includes? text "results from an earlier message are marked out of date"))
|
||||
(is (str/includes? text "an earlier one may no longer hold"))
|
||||
(is (str/includes? text "never go by an earlier result"))
|
||||
(is (str/includes? text "Say something was done only if a tool result says it was"))
|
||||
(is (str/includes? text "Tic-tac-toe: check whose turn it is"))
|
||||
(is (str/includes? text "Examples: "))
|
||||
(is (not (str/includes? text "navigate there, then")) "an outside agent is offered every tool")))
|
||||
|
||||
@@ -31,19 +30,15 @@
|
||||
(deftest examples-differ-by-reads
|
||||
(testing "an outside agent (no state channel) is shown reading first"
|
||||
(is (str/includes? (prompt/examples true) "list_todos -> set_todo_done"))
|
||||
(is (str/includes? (prompt/examples true) "list_todos -> ONE set_todo_done"))
|
||||
(is (str/includes? (prompt/examples true) "get_tic_tac_toe -> it is X's turn")))
|
||||
(testing "the chatbot (state already in view) is not, since it has no list_todos or get_tic_tac_toe"
|
||||
(is (not (str/includes? (prompt/examples false) "list_todos")))
|
||||
(is (not (str/includes? (prompt/examples false) "get_tic_tac_toe"))))
|
||||
(is (str/includes? (prompt/examples true) "list_todos -> ONE set_todo_done")))
|
||||
(testing "the chatbot (state already in view) is not, since it has no list_todos"
|
||||
(is (not (str/includes? (prompt/examples false) "list_todos"))))
|
||||
(testing "the rest is the same either way"
|
||||
(doseq [text [(prompt/examples true) (prompt/examples false)]]
|
||||
(is (str/includes? text "create_todo{\"todos\":[{\"title\":\"buy milk\"}]} -> \"Added.\""))
|
||||
(is (str/includes? text "add{\"x\":19,\"y\":4} -> \"23.\"")))))
|
||||
|
||||
(deftest tic-tac-toe-prompt
|
||||
(is (str/includes? (prompt/tic-tac-toe "x") "as X."))
|
||||
(is (str/includes? (prompt/tic-tac-toe "o") "as O."))
|
||||
(doseq [other [nil "" "z" :x]]
|
||||
(is (str/includes? (prompt/tic-tac-toe other) "as O.") (pr-str other)))
|
||||
(is (str/includes? (prompt/tic-tac-toe "x") "never move for the other side")))
|
||||
(is (str/includes? prompt/tic-tac-toe "get_tic_tac_toe and move_tic_tac_toe"))
|
||||
(is (not (str/includes? prompt/tic-tac-toe "as X")) "no side is assigned by the prompt")
|
||||
(is (not (str/includes? prompt/tic-tac-toe "as O")) "no side is assigned by the prompt"))
|
||||
|
||||
@@ -26,7 +26,11 @@
|
||||
(reify StreamingChatModel
|
||||
(doChat [_ req handler] (script req handler) nil)))
|
||||
|
||||
(defn- complete [handler ai-message finish-reason usage]
|
||||
(defn complete
|
||||
"Finishes a fake model's call: sends `handler` an onCompleteResponse of `ai-message`, with
|
||||
`finish-reason` and `usage` ([prompt completion], or nil for neither) — for a test whose fake
|
||||
model needs more control than text-model/tool-call-model/etc give."
|
||||
[handler ai-message finish-reason usage]
|
||||
(.onCompleteResponse handler
|
||||
(-> (ChatResponse/builder)
|
||||
(.aiMessage ai-message)
|
||||
|
||||
@@ -58,12 +58,14 @@
|
||||
(is (= {:event :turn-start :page "todos" :model "qwen" :messages 1 :tools 2 :prompt-chars 5 :step 0}
|
||||
(select-keys start [:event :page :model :messages :tools :prompt-chars :step])))
|
||||
(is (re-matches #"[0-9a-f]{8}" (:req start)))
|
||||
(is (not (contains? start :input))))))
|
||||
(testing "with the full text on, it has the run's messages"
|
||||
(is (not (contains? start :input)))
|
||||
(is (not (contains? start :system-text))))))
|
||||
(testing "with the full text on, it has the run's messages and the system prompt it was sent"
|
||||
(let [entries (atom [])
|
||||
messages [{:role "user" :content "old"} {:role "assistant" :content "reply"} {:role "user" :content "new"}]]
|
||||
(trace/begin! (collecting entries :full-text? true) {:messages messages})
|
||||
(is (= [{:role "user" :content "new"}] (:input (first @entries))))))
|
||||
(trace/begin! (collecting entries :full-text? true) {:messages messages :system-text "You are..."})
|
||||
(is (= [{:role "user" :content "new"}] (:input (first @entries))))
|
||||
(is (= "You are..." (:system-text (first @entries))))))
|
||||
(testing "every turn has its own req id"
|
||||
(let [entries (atom [])]
|
||||
(dotimes [_ 3] (trace/begin! (collecting entries) {:messages [{:role "user" :content "x"}]}))
|
||||
|
||||
+12
-4
@@ -30,19 +30,26 @@
|
||||
;; A message is one of
|
||||
;; {:role "user" :content "..."}
|
||||
;; {:role "assistant" :content "..."}, with :tool-calls [{:id :name :arguments "{...}"}] when
|
||||
;; the LLM asked for tools of the page to be called (:content may then be empty)
|
||||
;; the LLM asked for tools of the page to be called (:content may then be empty), and
|
||||
;; :thinking "..." with the reasoning behind it, when the model did any (see
|
||||
;; ::events/chat-event); shown only with "Show reasoning" on.
|
||||
;; {:role "tool" :tool-call-id "..." :name "..." :content "..." :error? bool}: the result of
|
||||
;; one such call.
|
||||
;; :size is what the panel was dragged to, in px: its :width and the :height of the conversation
|
||||
;; in it (the rest of the panel is the same at any size).
|
||||
;; :tools-expanded? is whether the tool calls and results show whole (wrapped) or, as they do by
|
||||
;; default, each cut to one line ending in "…" when it doesn't fit.
|
||||
;; The other two are for a reply that is still coming or being answered: :pending-calls are the
|
||||
;; calls it has asked for so far, :tool-calls-used how many calls this turn has made.
|
||||
;; :reasoning-expanded? is whether each reply's reasoning shows in full, or not at all (the
|
||||
;; default) — unlike tool use, there is no cut-down middle ground for it.
|
||||
;; The other three are for a reply that is still coming or being answered: :pending-calls are the
|
||||
;; calls it has asked for so far, :tool-calls-used how many calls this turn has made, and
|
||||
;; :tools-used-this-turn the names of the once-per-turn tools (tbd.ui.model-context/once-per-turn-names)
|
||||
;; it has already run, so the turn can neither offer nor run one of them again.
|
||||
;; :thinking-at is when (ms since the epoch) the last piece of the model's reasoning came, or nil.
|
||||
:chat {:open? false
|
||||
:size {:width 320 :height 256}
|
||||
:tools-expanded? false
|
||||
:reasoning-expanded? false
|
||||
:input ""
|
||||
:messages []
|
||||
:status :idle
|
||||
@@ -52,7 +59,8 @@
|
||||
;; toolCallId, until each is complete and moves into :pending-calls.
|
||||
:tool-call-buffer {}
|
||||
:thinking-at nil
|
||||
:tool-calls-used 0}
|
||||
:tool-calls-used 0
|
||||
:tools-used-this-turn #{}}
|
||||
;; Tic-tac-toe, entirely client side: the board (see tbd.ui.tictactoe) and whose turn it is.
|
||||
:ttt {:board tictactoe/new-board
|
||||
:turn :x}})
|
||||
|
||||
+282
-84
@@ -9,10 +9,12 @@
|
||||
[tbd.ui.tictactoe :as tictactoe]))
|
||||
|
||||
;; A `js/fetch` of `uri` (GET unless `method` is given). A `body` is sent as EDN.
|
||||
(defn- fetch-request [{:keys [uri method body]}]
|
||||
(js/fetch uri (clj->js (cond-> {:method (or method "GET")}
|
||||
body (assoc :headers {"Content-Type" "application/edn"}
|
||||
:body (pr-str body))))))
|
||||
;; A `signal` (an AbortSignal) lets the request be aborted.
|
||||
(defn- fetch-request [{:keys [uri method body signal]}]
|
||||
(js/fetch uri (cond-> (clj->js (cond-> {:method (or method "GET")}
|
||||
body (assoc :headers {"Content-Type" "application/edn"}
|
||||
:body (pr-str body))))
|
||||
signal (doto (aset "signal" signal)))))
|
||||
|
||||
(defn- response-map [resp text]
|
||||
{:ok? (.-ok resp) :status (.-status resp) :body text})
|
||||
@@ -45,18 +47,22 @@
|
||||
"Dispatches `(conj on-event event)` for each AG-UI event (see tbd.ui.sse, tbd.chat.routes) in the
|
||||
body read by `reader`, as they arrive. A body that ends without a RUN_FINISHED or RUN_ERROR event
|
||||
(the connection dropped) is a RUN_ERROR event of its own, so whoever waits for the end always
|
||||
gets one."
|
||||
[reader on-event]
|
||||
gets one — unless `signal` was aborted (see ::abort-stream): then nothing more is dispatched at
|
||||
all, since whoever aborted it has stopped waiting, and may have started another stream since."
|
||||
[reader on-event ^js signal]
|
||||
(let [decoder (js/TextDecoder. "utf-8")
|
||||
ended? (atom false)
|
||||
lost! #(when-not @ended?
|
||||
aborted? #(.-aborted signal)
|
||||
lost! #(when-not (or @ended? (aborted?))
|
||||
(reset! ended? true)
|
||||
(rf/dispatch (conj on-event connection-lost)))
|
||||
step (fn step [pending]
|
||||
(-> (.read reader)
|
||||
(.then (fn [^js chunk]
|
||||
(if (.-done chunk)
|
||||
(lost!)
|
||||
(cond
|
||||
(aborted?) (some-> (.-cancel reader) (.call reader) (.catch (fn [_] nil)))
|
||||
(.-done chunk) (lost!)
|
||||
:else
|
||||
(let [[events pending] (sse/parse (str pending (.decode decoder (.-value chunk)
|
||||
#js {:stream true})))]
|
||||
(doseq [event events]
|
||||
@@ -66,19 +72,37 @@
|
||||
(.catch (fn [_] (lost!)))))]
|
||||
(step "")))
|
||||
|
||||
;; The AbortController of the stream ::fetch-stream last started, for ::abort-stream. There is only
|
||||
;; ever one in flight (the chat sends one message at a time).
|
||||
(defonce ^:private stream-controller (atom nil))
|
||||
|
||||
;; Effect: like ::fetch, for a response that is a stream of server-sent events. While it comes in,
|
||||
;; `(conj on-event event)` is dispatched for each event, as a map (see read-events!). When the
|
||||
;; request fails instead (a network error or a status that isn't 2xx: no stream came),
|
||||
;; `(conj on-response {:ok? false :status int-or-nil :body string})` is dispatched, as ::fetch does.
|
||||
;; After ::abort-stream, nothing more is dispatched for it.
|
||||
(rf/reg-fx
|
||||
::fetch-stream
|
||||
(fn [{:keys [on-event on-response] :as request}]
|
||||
(-> (fetch-request request)
|
||||
(.then (fn [resp]
|
||||
(if (.-ok resp)
|
||||
(read-events! (.getReader (.-body resp)) on-event)
|
||||
(.then (.text resp) #(rf/dispatch (conj on-response (response-map resp %)))))))
|
||||
(.catch #(rf/dispatch (conj on-response {:ok? false :status nil :body (.-message %)}))))))
|
||||
(let [controller (js/AbortController.)
|
||||
signal (.-signal controller)
|
||||
respond! #(when-not (.-aborted signal) (rf/dispatch (conj on-response %)))]
|
||||
(reset! stream-controller controller)
|
||||
(-> (fetch-request (assoc request :signal signal))
|
||||
(.then (fn [resp]
|
||||
(if (.-ok resp)
|
||||
(read-events! (.getReader (.-body resp)) on-event signal)
|
||||
(.then (.text resp) #(respond! (response-map resp %))))))
|
||||
(.catch #(respond! {:ok? false :status nil :body (.-message %)}))))))
|
||||
|
||||
;; Effect: abort the stream ::fetch-stream last started, if it is still going. The connection
|
||||
;; closing is what tells the server to stop the LLM (see tbd.chat.routes/event-stream).
|
||||
(rf/reg-fx
|
||||
::abort-stream
|
||||
(fn [_]
|
||||
(when-let [controller @stream-controller]
|
||||
(reset! stream-controller nil)
|
||||
(.abort controller))))
|
||||
|
||||
;; Coeffect: the URL's fragment, which says which page to start on.
|
||||
(rf/reg-cofx
|
||||
@@ -92,6 +116,50 @@
|
||||
(fn [cofx _]
|
||||
(assoc cofx :now (js/Date.now))))
|
||||
|
||||
;; localStorage key the chat widget's :open? and :size are kept under (see ::persist-chat-ui and
|
||||
;; ::initialize), so a reload leaves the panel showing (or hidden) and sized as it was left.
|
||||
(def ^:private chat-ui-storage-key "tbd.chat-ui")
|
||||
|
||||
;; Coeffect: the chat widget's :open? and :size as they were last left, or nil if nothing was ever
|
||||
;; saved (or what's there can't be read, e.g. it was hand-edited into garbage).
|
||||
(rf/reg-cofx
|
||||
::chat-ui-storage
|
||||
(fn [cofx _]
|
||||
(assoc cofx ::chat-ui
|
||||
(try
|
||||
(some-> (.getItem js/localStorage chat-ui-storage-key)
|
||||
reader/read-string
|
||||
(select-keys [:open? :size]))
|
||||
(catch :default _ nil)))))
|
||||
|
||||
;; Effect: remembers the chat widget's :open? and :size in localStorage, across reloads.
|
||||
(rf/reg-fx
|
||||
::persist-chat-ui
|
||||
(fn [chat-ui]
|
||||
(.setItem js/localStorage chat-ui-storage-key (pr-str chat-ui))))
|
||||
|
||||
;; localStorage key the tic-tac-toe board and whose turn it is are kept under (see ::persist-ttt
|
||||
;; and ::initialize), so a reload finds the game as it was left instead of starting over.
|
||||
(def ^:private ttt-storage-key "tbd.ttt")
|
||||
|
||||
;; Coeffect: the tic-tac-toe :board and :turn as they were last left, or nil if nothing was ever
|
||||
;; saved (or what's there can't be read, e.g. it was hand-edited into garbage).
|
||||
(rf/reg-cofx
|
||||
::ttt-storage
|
||||
(fn [cofx _]
|
||||
(assoc cofx ::ttt
|
||||
(try
|
||||
(some-> (.getItem js/localStorage ttt-storage-key)
|
||||
reader/read-string
|
||||
(select-keys [:board :turn]))
|
||||
(catch :default _ nil)))))
|
||||
|
||||
;; Effect: remembers the tic-tac-toe :board and :turn in localStorage, across reloads.
|
||||
(rf/reg-fx
|
||||
::persist-ttt
|
||||
(fn [ttt]
|
||||
(.setItem js/localStorage ttt-storage-key (pr-str ttt))))
|
||||
|
||||
;; Effect: show the page the URL names whenever it changes (a link was followed, or Back and
|
||||
;; Forward were pressed). Only one listener is ever installed, however often this runs.
|
||||
(defonce ^:private hash-listener (atom nil))
|
||||
@@ -112,9 +180,11 @@
|
||||
|
||||
(rf/reg-event-fx
|
||||
::initialize
|
||||
[(rf/inject-cofx ::hash)]
|
||||
(fn [{:keys [hash]} _]
|
||||
{:db (assoc db/default-db :page (pages/hash->page hash))
|
||||
[(rf/inject-cofx ::hash) (rf/inject-cofx ::chat-ui-storage) (rf/inject-cofx ::ttt-storage)]
|
||||
(fn [{:keys [hash ::chat-ui ::ttt]} _]
|
||||
{:db (cond-> (assoc db/default-db :page (pages/hash->page hash))
|
||||
chat-ui (update :chat merge chat-ui)
|
||||
ttt (update :ttt merge ttt))
|
||||
::listen-for-hash true
|
||||
:dispatch [::load-user]}))
|
||||
|
||||
@@ -191,7 +261,8 @@
|
||||
(defn- reset-chat
|
||||
"An empty conversation, in a panel that is as open (or closed), and as big, as it was."
|
||||
[db]
|
||||
(assoc db :chat (merge (:chat db/default-db) (select-keys (:chat db) [:open? :size :tools-expanded?]))))
|
||||
(assoc db :chat (merge (:chat db/default-db)
|
||||
(select-keys (:chat db) [:open? :size :tools-expanded? :reasoning-expanded?]))))
|
||||
|
||||
(rf/reg-event-db
|
||||
::logout-response
|
||||
@@ -308,15 +379,20 @@
|
||||
|
||||
(def ^:private truncated " … (truncated)")
|
||||
|
||||
(defn- fit-result
|
||||
"A tool's result text as the content of a message: never empty, and no longer than the server
|
||||
takes."
|
||||
(defn- display-text
|
||||
"A tool's result text as kept in memory and shown in the chat log: never empty. Not cut down —
|
||||
the browser keeps the whole thing for as long as the tab is open, so \"Expand tool use\" has
|
||||
something to expand to; only what leaves the tab (to the LLM, or to /api/chat/history) is fit to
|
||||
the server's limit, by `fit-result`."
|
||||
[text]
|
||||
(cond
|
||||
(str/blank? text) "(no output)"
|
||||
(> (count text) max-tool-result-length) (str (subs text 0 (- max-tool-result-length (count truncated)))
|
||||
truncated)
|
||||
:else text))
|
||||
(if (str/blank? text) "(no output)" text))
|
||||
|
||||
(defn- fit-result
|
||||
"`text`, no longer than the server takes, for a tool result about to leave the tab."
|
||||
[text]
|
||||
(if (> (count text) max-tool-result-length)
|
||||
(str (subs text 0 (- max-tool-result-length (count truncated))) truncated)
|
||||
text))
|
||||
|
||||
(defonce ^:private id-counter (atom 0))
|
||||
|
||||
@@ -328,10 +404,11 @@
|
||||
|
||||
(defn- wire-message
|
||||
"A message of the conversation as AG-UI's Message has it (see tbd.chat.schema/Message: user,
|
||||
assistant with `toolCalls`, or tool)."
|
||||
assistant with `toolCalls`, or tool). A tool result is fit to the server's limit here, on the
|
||||
way out — the browser's own copy, in `db`, stays whole."
|
||||
[{:keys [role content tool-calls tool-call-id]}]
|
||||
(cond-> {:id (next-id) :role role}
|
||||
(= "tool" role) (assoc :toolCallId tool-call-id :content content)
|
||||
(= "tool" role) (assoc :toolCallId tool-call-id :content (fit-result content))
|
||||
(not= "tool" role) (assoc :content content)
|
||||
(seq tool-calls) (assoc :toolCalls (mapv (fn [{:keys [id name arguments]}]
|
||||
{:id id :type "function"
|
||||
@@ -356,12 +433,52 @@
|
||||
since this is scrollback for the user to read, not context sent to the LLM."
|
||||
100)
|
||||
|
||||
(def ^:private max-stored-content-length
|
||||
"The longest tool result, or reply's reasoning, that is saved
|
||||
(tbd.chat.schema/max-history-content-length): the saved conversation is the whole log, for
|
||||
\"Expand tool use\"/\"Show reasoning\" to show after a reload, so it is not cut down to what the
|
||||
LLM is sent."
|
||||
100000)
|
||||
|
||||
(def ^:private max-stored-length
|
||||
"How long the saved conversation may be, printed, all told (tbd.chat.schema/max-history-length)."
|
||||
1000000)
|
||||
|
||||
(declare only-reasoning?)
|
||||
|
||||
(defn- fit-stored
|
||||
"`text`, no longer than /api/chat/history takes for a tool result or reasoning."
|
||||
[text]
|
||||
(if (> (count text) max-stored-content-length)
|
||||
(str (subs text 0 (- max-stored-content-length (count truncated))) truncated)
|
||||
text))
|
||||
|
||||
(defn- storable
|
||||
"The most recent `max-stored-messages` of `messages`, as /api/chat/history's PUT wants them: the
|
||||
browser's own internal shape (see tbd.ui.db), not AG-UI's wire Message — that endpoint is this
|
||||
app's own addition, not part of an AG-UI run, so nothing is lost translating to and from it."
|
||||
app's own addition, not part of an AG-UI run, so nothing is lost translating to and from it.
|
||||
Tool results and reasoning are saved whole (up to `max-stored-content-length`), not fit to what
|
||||
the LLM is sent, so a reload restores the full log; when the whole is over `max-stored-length`,
|
||||
the oldest turns go instead. A reply halted before it said anything (see ::chat-halt) isn't
|
||||
saved: the server keeps no message that says nothing."
|
||||
[messages]
|
||||
(windowed max-stored-messages messages))
|
||||
(let [fitted (into []
|
||||
(comp (remove only-reasoning?)
|
||||
(map (fn [message]
|
||||
(cond-> message
|
||||
(= "tool" (:role message)) (update :content fit-stored)
|
||||
(:thinking message) (update :thinking fit-stored)))))
|
||||
(windowed max-stored-messages messages))
|
||||
sizes (mapv #(inc (count (pr-str %))) fitted)]
|
||||
(loop [messages fitted
|
||||
size (reduce + 2 sizes)
|
||||
sizes sizes]
|
||||
(if (and (> size max-stored-length) (seq messages))
|
||||
;; The oldest turn goes whole, up to the next message of the user's: nothing is left
|
||||
;; stranded, a result without its call or a reply without its question.
|
||||
(let [n (inc (count (take-while #(not= "user" (:role %)) (rest messages))))]
|
||||
(recur (subvec messages n) (- size (reduce + (take n sizes))) (subvec sizes n)))
|
||||
messages))))
|
||||
|
||||
;; Effect: best-effort save of the conversation so far, for /api/chat/history to hand back on the
|
||||
;; next login. Never blocks anything: on failure the next natural save point (the next message
|
||||
@@ -380,25 +497,6 @@
|
||||
(-> db (assoc :user {:status :anonymous}) reset-chat)
|
||||
db)))
|
||||
|
||||
(def ^:private stale-result
|
||||
"What the LLM is sent in place of a result from before the user's last message."
|
||||
"(out of date: this was read on an earlier turn and the page may have changed since. Use \"Current state of the page\" below, if there is one, or call the tool again, for what it shows now.)")
|
||||
|
||||
(defn- without-stale-results
|
||||
"`messages` with the content of the tool results from before the user's last message replaced by
|
||||
`stale-result`. A result is a snapshot of the page when the tool ran, and the user can change the
|
||||
page between messages, by hand or on another page; a model that is still shown the old snapshot
|
||||
goes by it, even when told it is wrong. What it did stays (its calls, its own words), only what
|
||||
it read goes. The results of this turn stay: a chain of calls goes on from the ones before
|
||||
(list, then act on an id)."
|
||||
[messages]
|
||||
(let [last-user (or (last (keep-indexed (fn [i {:keys [role]}] (when (= "user" role) i)) messages)) 0)]
|
||||
(into [] (map-indexed (fn [i message]
|
||||
(cond-> message
|
||||
(and (< i last-user) (= "tool" (:role message)))
|
||||
(assoc :content stale-result))))
|
||||
messages)))
|
||||
|
||||
(defn- wire-tool
|
||||
"A tool as AG-UI's Tool has it (see tbd.chat.schema/Tool): `parameters`, not MCP's `inputSchema`."
|
||||
[{:keys [name description inputSchema]}]
|
||||
@@ -410,14 +508,23 @@
|
||||
;; the LLM, and its current state (`state`, see tbd.ui.model-context/current-state and
|
||||
;; tbd.chat.schema/RunAgentInput) — what a read-only tool would have told it, so it never has to
|
||||
;; spend a call finding out. All three are read from the db every time, so a conversation that
|
||||
;; moves between pages (the LLM's own `navigate`, say) always tells the LLM where it is now.
|
||||
;; moves between pages (the LLM's own `navigate`, say) always tells the LLM where it is now. Old
|
||||
;; tool results are sent as they are (nothing here marks them stale): the state is always
|
||||
;; refreshed and current, and the system prompt tells the model to go by that over anything said
|
||||
;; earlier, so there is nothing an old result could mislead it into believing.
|
||||
(defn- chat-request [db messages]
|
||||
(let [tools (model-context/definitions (:page db))
|
||||
state (model-context/current-state (:page db))]
|
||||
(let [page (:page db)
|
||||
once (model-context/once-per-turn-names page)
|
||||
used (get-in db [:chat :tools-used-this-turn])
|
||||
tools (remove (comp #(and (once %) (used %)) :name) (model-context/definitions page))
|
||||
state (model-context/current-state page)
|
||||
;; A reply halted (see ::chat-halt) before it said anything stays on screen, with whatever
|
||||
;; reasoning it had, but there is nothing in it for the LLM (which refuses it).
|
||||
messages (remove only-reasoning? messages)]
|
||||
{:uri "/api/chat" :method "POST"
|
||||
:body (cond-> {:threadId (next-id) :runId (next-id)
|
||||
:messages (mapv wire-message (without-stale-results (recent messages)))
|
||||
:context [{:description "page" :value (name (:page db))}]}
|
||||
:messages (mapv wire-message (recent messages))
|
||||
:context [{:description "page" :value (name page)}]}
|
||||
(seq tools) (assoc :tools (mapv wire-tool tools))
|
||||
(seq state) (assoc :state state))
|
||||
:on-event [::chat-event]
|
||||
@@ -438,17 +545,23 @@
|
||||
(assoc-in db [:chat :messages] (:messages (reader/read-string body)))
|
||||
db)))
|
||||
|
||||
(rf/reg-event-db
|
||||
;; Whether the chat widget is open persists (see ::persist-chat-ui) so a reload leaves it as the
|
||||
;; user left it.
|
||||
(rf/reg-event-fx
|
||||
::chat-toggle
|
||||
(fn [db _]
|
||||
(update-in db [:chat :open?] not)))
|
||||
(fn [{:keys [db]} _]
|
||||
(let [db (update-in db [:chat :open?] not)]
|
||||
{:db db
|
||||
::persist-chat-ui (select-keys (:chat db) [:open? :size])})))
|
||||
|
||||
;; The panel is dragged to `width` px wide and its conversation `height` px high (the view keeps
|
||||
;; them within the window).
|
||||
(rf/reg-event-db
|
||||
;; them within the window). The size persists (see ::persist-chat-ui) so a reload keeps it.
|
||||
(rf/reg-event-fx
|
||||
::chat-resize
|
||||
(fn [db [_ width height]]
|
||||
(assoc-in db [:chat :size] {:width width :height height})))
|
||||
(fn [{:keys [db]} [_ width height]]
|
||||
(let [db (assoc-in db [:chat :size] {:width width :height height})]
|
||||
{:db db
|
||||
::persist-chat-ui (select-keys (:chat db) [:open? :size])})))
|
||||
|
||||
;; Whether the tool calls and results show whole, or each cut to one line.
|
||||
(rf/reg-event-db
|
||||
@@ -456,6 +569,12 @@
|
||||
(fn [db _]
|
||||
(update-in db [:chat :tools-expanded?] not)))
|
||||
|
||||
;; Whether each reply's reasoning shows in full, or not at all.
|
||||
(rf/reg-event-db
|
||||
::chat-toggle-reasoning
|
||||
(fn [db _]
|
||||
(update-in db [:chat :reasoning-expanded?] not)))
|
||||
|
||||
(rf/reg-event-db
|
||||
::chat-set-input
|
||||
(fn [db [_ input]]
|
||||
@@ -470,7 +589,7 @@
|
||||
(when (and (not= :loading status) (seq content))
|
||||
(let [messages (conj messages {:role "user" :content content})
|
||||
db (update db :chat assoc :messages messages :input "" :status :loading :error nil
|
||||
:tool-calls-used 0)]
|
||||
:tool-calls-used 0 :tools-used-this-turn #{})]
|
||||
{:db db
|
||||
::fetch-stream (chat-request db messages)
|
||||
::persist-chat (save-chat-fx db)})))))
|
||||
@@ -523,6 +642,17 @@
|
||||
(str content (if (str/blank? content) (str/triml text) text))))
|
||||
(conj messages {:role "assistant" :content (str/triml text)})))))
|
||||
|
||||
(defn- append-reasoning
|
||||
"The conversation's assistant message being written, with `text` added to its reasoning — kept
|
||||
apart from `:content` (see append-to-reply) so \"Show reasoning\" can reveal it, in full, for
|
||||
whichever reply it belongs to; hidden otherwise."
|
||||
[db text]
|
||||
(update-in db [:chat :messages]
|
||||
(fn [messages]
|
||||
(if (= "assistant" (:role (peek messages)))
|
||||
(update messages (dec (count messages)) update :thinking str text)
|
||||
(conj messages {:role "assistant" :content "" :thinking text})))))
|
||||
|
||||
(defn- with-tool-calls
|
||||
"The conversation with the calls the LLM asked for: on the reply's text (the message it
|
||||
started), or on a message of their own when it said nothing."
|
||||
@@ -534,12 +664,30 @@
|
||||
(defn- tool-message [{:keys [id name content error?]}]
|
||||
{:role "tool" :tool-call-id id :name name :content content :error? (boolean error?)})
|
||||
|
||||
(defn- blocked-calls
|
||||
"`calls`, each marked `:blocked?` when it names a tool in `once` (see
|
||||
tbd.ui.model-context/once-per-turn-names) that `used` (the names already spent earlier this
|
||||
turn) already has, or an earlier call of this same batch does — the model asking twice in one
|
||||
reply is blocked exactly like asking again after the results of the first came back."
|
||||
[once used calls]
|
||||
(first (reduce (fn [[marked seen] {:keys [name] :as call}]
|
||||
(let [counts? (once name)]
|
||||
[(conj marked (cond-> call (and counts? (or (used name) (seen name))) (assoc :blocked? true)))
|
||||
(cond-> seen counts? (conj name))]))
|
||||
[[] #{}] calls)))
|
||||
|
||||
(defn- finish-reply
|
||||
"The reply is complete. Without calls that is all; with them, they are made (see ::call-tools)
|
||||
and the conversation goes on when they are done, unless this turn has used all the calls it may."
|
||||
"The reply is complete. Without calls that is all; with them, they are made (see ::call-tools) —
|
||||
except a call to a once-per-turn tool already spent this turn (`blocked-calls`), which is
|
||||
refused without running — and the conversation goes on when they are done, unless this turn has
|
||||
used all the calls it may."
|
||||
[db]
|
||||
(let [{:keys [pending-calls tool-calls-used]} (:chat db)
|
||||
used (+ (or tool-calls-used 0) (count pending-calls))
|
||||
page (:page db)
|
||||
once (model-context/once-per-turn-names page)
|
||||
calls (blocked-calls once (get-in db [:chat :tools-used-this-turn]) pending-calls)
|
||||
newly-used (into #{} (comp (remove :blocked?) (map :name) (filter once)) calls)
|
||||
db (update db :chat assoc :pending-calls nil :thinking-at nil)]
|
||||
(cond
|
||||
(empty? pending-calls)
|
||||
@@ -561,8 +709,9 @@
|
||||
:else
|
||||
{:db (-> db
|
||||
(update-in [:chat :messages] with-tool-calls pending-calls)
|
||||
(update-in [:chat :tools-used-this-turn] into newly-used)
|
||||
(assoc-in [:chat :tool-calls-used] used))
|
||||
::call-tools {:page (:page db) :calls pending-calls :on-results [::chat-tool-results]}})))
|
||||
::call-tools {:page page :calls calls :on-results [::chat-tool-results]}})))
|
||||
|
||||
(defn- text? [x]
|
||||
(and (string? x) (seq x)))
|
||||
@@ -582,11 +731,12 @@
|
||||
;; One AG-UI event of the reply (see tbd.chat.routes, https://docs.ag-ui.com): TEXT_MESSAGE_CONTENT
|
||||
;; ({:delta "..."}) for the next piece of the reply (the first starts the assistant's message, the
|
||||
;; rest are added to it), REASONING_MESSAGE_CONTENT for the next piece of the model's reasoning
|
||||
;; (which is not kept: the user only sees that the model is thinking, and for as long as pieces
|
||||
;; keep coming, which :thinking-at, the time the last one came, is for),
|
||||
;; TOOL_CALL_START/TOOL_CALL_ARGS/TOOL_CALL_END as it asks for tools to be called (accumulated in
|
||||
;; :tool-call-buffer until each call is complete), and last RUN_FINISHED or RUN_ERROR. Events
|
||||
;; nobody is waiting for (the conversation was reset since) are dropped.
|
||||
;; (added to that same message's own :thinking, apart from :content — see append-reasoning; the
|
||||
;; user only sees "Thinking…" while it comes in, and, if "Show reasoning" is on, the whole of it
|
||||
;; once it's there; while it's still coming, :thinking-at, the time the last piece came, is for
|
||||
;; that), TOOL_CALL_START/TOOL_CALL_ARGS/TOOL_CALL_END as it asks for tools to be called
|
||||
;; (accumulated in :tool-call-buffer until each call is complete), and last RUN_FINISHED or
|
||||
;; RUN_ERROR. Events nobody is waiting for (the conversation was reset since) are dropped.
|
||||
(rf/reg-event-fx
|
||||
::chat-event
|
||||
[(rf/inject-cofx ::now)]
|
||||
@@ -598,6 +748,8 @@
|
||||
(cond
|
||||
(not loading?) {:db db}
|
||||
(= "TEXT_MESSAGE_CONTENT" type) {:db (append-to-reply db (:delta event))}
|
||||
(= "REASONING_MESSAGE_CONTENT" type)
|
||||
{:db (cond-> db (text? (:delta event)) (append-reasoning (:delta event)))}
|
||||
(= "TOOL_CALL_START" type) {:db (start-tool-call db event)}
|
||||
(= "TOOL_CALL_ARGS" type) {:db (append-tool-call-args db event)}
|
||||
(= "TOOL_CALL_END" type) {:db (end-tool-call db event)}
|
||||
@@ -606,17 +758,24 @@
|
||||
{:db db ::persist-chat (save-chat-fx db)})
|
||||
:else {:db db}))))
|
||||
|
||||
(def ^:private blocked-message
|
||||
"The result of a call `blocked-calls` marked: a once-per-turn tool, already spent this turn."
|
||||
"not run: this only runs once per message, and already has this turn — answer instead of calling it again")
|
||||
|
||||
(defn- call-all
|
||||
"A promise of the results of `calls`, in order, as {:id :name :content :error?}. One after the
|
||||
other: the tools work on the same page (one may need the page the last one opened). Only the
|
||||
tools `page` offers can be called."
|
||||
tools `page` offers can be called; a call `finish-reply` marked `:blocked?` (see `blocked-calls`)
|
||||
never reaches the page at all."
|
||||
[page calls]
|
||||
(reduce (fn [results {:keys [id name arguments]}]
|
||||
(reduce (fn [results {:keys [id name arguments blocked?]}]
|
||||
(.then results
|
||||
(fn [done]
|
||||
(.then (model-context/call! page name arguments)
|
||||
(fn [{:keys [text error?]}]
|
||||
(conj done {:id id :name name :content (fit-result text) :error? error?}))))))
|
||||
(if blocked?
|
||||
(conj done {:id id :name name :content blocked-message :error? true})
|
||||
(.then (model-context/call! page name arguments)
|
||||
(fn [{:keys [text error?]}]
|
||||
(conj done {:id id :name name :content (display-text text) :error? error?})))))))
|
||||
(js/Promise.resolve [])
|
||||
calls))
|
||||
|
||||
@@ -648,6 +807,40 @@
|
||||
{:db db
|
||||
::fetch-stream (chat-request db (get-in db [:chat :messages]))}))))
|
||||
|
||||
;; The user halts the reply mid-way, to steer it with their next message: the stream stops (and the
|
||||
;; LLM with it, see ::abort-stream), and what has come of the reply so far stays, marked :halted? —
|
||||
;; its reasoning and words, but not tool calls it was still asking for, which are never made. If
|
||||
;; the tools it asked for are running, their results no longer go to the LLM (see answers?); each
|
||||
;; is answered with `halted-result` instead, since the LLM refuses a call left unanswered.
|
||||
(def ^:private halted-result
|
||||
"(halted by the user before the result came back: this call may or may not have taken effect)")
|
||||
|
||||
(defn- halt-reply [messages]
|
||||
(let [{:keys [role tool-calls]} (peek messages)]
|
||||
(cond
|
||||
(not= "assistant" role)
|
||||
(conj messages {:role "assistant" :content "" :halted? true})
|
||||
|
||||
(seq tool-calls)
|
||||
(into (update messages (dec (count messages)) assoc :halted? true)
|
||||
(for [{:keys [id name]} tool-calls]
|
||||
(tool-message {:id id :name name :error? true :content halted-result})))
|
||||
|
||||
:else (update messages (dec (count messages)) assoc :halted? true))))
|
||||
|
||||
(rf/reg-event-fx
|
||||
::chat-halt
|
||||
(fn [{:keys [db]} _]
|
||||
(if-not (= :loading (get-in db [:chat :status]))
|
||||
{:db db}
|
||||
(let [db (-> db
|
||||
(update-in [:chat :messages] halt-reply)
|
||||
(update :chat assoc :status :idle :error nil :pending-calls nil
|
||||
:tool-call-buffer {} :thinking-at nil))]
|
||||
{:db db
|
||||
::abort-stream true
|
||||
::persist-chat (save-chat-fx db)}))))
|
||||
|
||||
;; Starts a new session: not while a reply is on its way (it would land in the new one), and the
|
||||
;; stored history goes with it, so a reload doesn't bring the old conversation back.
|
||||
(rf/reg-event-fx
|
||||
@@ -687,16 +880,21 @@
|
||||
|
||||
;; --- Tic-tac-toe ---
|
||||
|
||||
;; An illegal move (taken cell, game over) changes nothing.
|
||||
(rf/reg-event-db
|
||||
;; An illegal move (taken cell, game over) changes nothing. The board persists (see ::persist-ttt)
|
||||
;; so a reload finds the game where it was left.
|
||||
(rf/reg-event-fx
|
||||
::ttt-move
|
||||
(fn [db [_ i]]
|
||||
(fn [{:keys [db]} [_ i]]
|
||||
(let [{:keys [board turn]} (:ttt db)]
|
||||
(if-let [board' (tictactoe/move board turn i)]
|
||||
(assoc db :ttt {:board board' :turn (tictactoe/next-player turn)})
|
||||
db))))
|
||||
(let [ttt {:board board' :turn (tictactoe/next-player turn)}]
|
||||
{:db (assoc db :ttt ttt)
|
||||
::persist-ttt ttt})
|
||||
{:db db}))))
|
||||
|
||||
(rf/reg-event-db
|
||||
(rf/reg-event-fx
|
||||
::ttt-reset
|
||||
(fn [db _]
|
||||
(assoc db :ttt (:ttt db/default-db))))
|
||||
(fn [{:keys [db]} _]
|
||||
(let [ttt (:ttt db/default-db)]
|
||||
{:db (assoc db :ttt ttt)
|
||||
::persist-ttt ttt})))
|
||||
|
||||
@@ -0,0 +1,189 @@
|
||||
(ns tbd.ui.markdown
|
||||
"Turns a chat message's Markdown into Reagent hiccup, for `chat-bubble` to show as blocks
|
||||
(headings, lists, code, blockquotes, tables) and inline formatting (bold, italic, code, links)
|
||||
instead of flat text. Hand-rolled rather than an npm library: not full CommonMark (no nested
|
||||
lists, and a table or list has to start right after a blank line, not mid-paragraph), but
|
||||
covers what a chat message actually uses.
|
||||
|
||||
No HTML is ever built as a string and injected (no :dangerouslySetInnerHTML, so nothing to run
|
||||
a sanitizer library over either): every leaf here is a plain Clojure string, which Reagent
|
||||
turns into a text node the same way any other hiccup content is, so it can never be read back
|
||||
as markup. The one place a message's text becomes an attribute rather than a text node is a
|
||||
link's `href`, which `safe-href` checks by hand."
|
||||
(:require [clojure.string :as str]))
|
||||
|
||||
;; --- Block matchers (tested against a left-trimmed line) ---
|
||||
|
||||
(def ^:private fence-re #"^```\s*(\S*)\s*$")
|
||||
(def ^:private fence-close-re #"^\s*```\s*$")
|
||||
(def ^:private heading-re #"^(#{1,6})\s+(.*)$")
|
||||
(def ^:private hr-re #"^(?:-{3,}|\*{3,}|_{3,})\s*$")
|
||||
(def ^:private quote-re #"^>\s?(.*)$")
|
||||
(def ^:private ul-re #"^[-*+]\s+(.*)$")
|
||||
(def ^:private ol-re #"^\d+[.)]\s+(.*)$")
|
||||
(def ^:private table-sep-re #"^\|?\s*:?-+:?\s*(\|\s*:?-+:?\s*)*\|?\s*$")
|
||||
|
||||
(defn- block-starter?
|
||||
"Whether `line` begins a block of its own, so a paragraph reading lines one at a time stops
|
||||
before it even without a blank line in between."
|
||||
[line]
|
||||
(let [l (str/triml line)]
|
||||
(boolean (or (str/blank? l) (re-find fence-re l) (re-find heading-re l) (re-find hr-re l)
|
||||
(re-find quote-re l) (re-find ul-re l) (re-find ol-re l)))))
|
||||
|
||||
;; --- Inline formatting ---
|
||||
|
||||
(def ^:private allowed-schemes #{"http" "https" "mailto" "tel"})
|
||||
|
||||
(defn- safe-href
|
||||
"`url` if it's fine to put in an href (no scheme, i.e. relative, or one of `allowed-schemes`),
|
||||
else nil: the model can write a `javascript:` link too, whether it means to or not (quoting one
|
||||
from a tool result), and React itself won't stop that from running on a click."
|
||||
[url]
|
||||
(let [scheme (second (re-find #"^([A-Za-z][A-Za-z0-9+.-]*):" url))]
|
||||
(when (or (nil? scheme) (contains? allowed-schemes (str/lower-case scheme)))
|
||||
url)))
|
||||
|
||||
(defn- flanked?
|
||||
"Whether `s` is a fit inside for an emphasis/strong span: not empty, and not padded with a
|
||||
space, which is usually a stray `*` or `_` doing something else (\"3 * 4 * 5\") rather than
|
||||
marking emphasis."
|
||||
[s]
|
||||
(and (seq s) (not (str/starts-with? s " ")) (not (str/ends-with? s " "))))
|
||||
|
||||
(def ^:private link-re #"^\[([^\]]*)\]\(([^)\s]+)(?:\s+\"[^\"]*\")?\)")
|
||||
|
||||
(defn- flush-text
|
||||
"`out` with the literal text `s[from, to)` appended, if there is any."
|
||||
[out s from to]
|
||||
(if (< from to) (conj out (subs s from to)) out))
|
||||
|
||||
(defn- inline-line->hiccup
|
||||
"One line's worth of inline Markdown (no newlines: see `inline->hiccup` for those) as a vector
|
||||
of hiccup children: plain strings and `:code`/`:strong`/`:em`/`:a` elements."
|
||||
[s]
|
||||
(let [n (count s)]
|
||||
(loop [i 0, flush 0, out []]
|
||||
(if (>= i n)
|
||||
(flush-text out s flush n)
|
||||
(let [c (subs s i (inc i))
|
||||
two (when (<= (+ i 2) n) (subs s i (+ i 2)))]
|
||||
(cond
|
||||
(= c "`")
|
||||
(if-let [j (str/index-of s "`" (inc i))]
|
||||
(recur (inc j) (inc j) (conj (flush-text out s flush i) [:code (subs s (inc i) j)]))
|
||||
(recur (inc i) flush out))
|
||||
|
||||
(contains? #{"**" "__"} two)
|
||||
(let [j (str/index-of s two (+ i 2))
|
||||
inner (when j (subs s (+ i 2) j))]
|
||||
(if (flanked? inner)
|
||||
(recur (+ j 2) (+ j 2)
|
||||
(conj (flush-text out s flush i) (into [:strong] (inline-line->hiccup inner))))
|
||||
(recur (inc i) flush out)))
|
||||
|
||||
(contains? #{"*" "_"} c)
|
||||
(let [j (str/index-of s c (inc i))
|
||||
inner (when j (subs s (inc i) j))]
|
||||
(if (flanked? inner)
|
||||
(recur (inc j) (inc j)
|
||||
(conj (flush-text out s flush i) (into [:em] (inline-line->hiccup inner))))
|
||||
(recur (inc i) flush out)))
|
||||
|
||||
(= c "[")
|
||||
(if-let [[whole label url] (re-find link-re (subs s i))]
|
||||
(let [href (safe-href url)
|
||||
label-pieces (inline-line->hiccup label)
|
||||
node (if href
|
||||
(into [:a {:href href :target "_blank" :rel "noopener noreferrer"}] label-pieces)
|
||||
(into [:span] label-pieces))]
|
||||
(recur (+ i (count whole)) (+ i (count whole)) (conj (flush-text out s flush i) node)))
|
||||
(recur (inc i) flush out))
|
||||
|
||||
:else (recur (inc i) flush out)))))))
|
||||
|
||||
(defn- inline->hiccup
|
||||
"`text` (possibly several lines: a paragraph's or a blockquote line's own soft-wrapped lines)
|
||||
as hiccup children, a `:br` between each line, the way a bare newline reads in a chat message
|
||||
someone typed without Markdown's blank-line-between-paragraphs convention in mind."
|
||||
[text]
|
||||
(vec (apply concat (interpose [[:br]] (map inline-line->hiccup (str/split text #"\n"))))))
|
||||
|
||||
;; --- Blocks ---
|
||||
|
||||
(defn- code-block [lang lines]
|
||||
[:pre [:code (if (seq lang) {:class (str "language-" lang)} {}) (str/join "\n" lines)]])
|
||||
|
||||
(defn- table-cells [line]
|
||||
(->> (-> (str/trim line)
|
||||
(str/replace #"^\|" "")
|
||||
(str/replace #"\|$" "")
|
||||
(str/split #"\|"))
|
||||
(mapv str/trim)))
|
||||
|
||||
(defn- table [header-line body-lines]
|
||||
(let [header (table-cells header-line)
|
||||
rows (mapv table-cells body-lines)]
|
||||
[:table
|
||||
[:thead (into [:tr] (map #(into [:th] (inline-line->hiccup %)) header))]
|
||||
(into [:tbody] (map (fn [row] (into [:tr] (map #(into [:td] (inline-line->hiccup %)) row))) rows))]))
|
||||
|
||||
(declare parse-blocks)
|
||||
|
||||
(defn- parse-blocks
|
||||
"`text`'s block-level structure, as a vector of hiccup elements."
|
||||
[text]
|
||||
(loop [lines (vec (str/split text #"\n")), out []]
|
||||
(if (empty? lines)
|
||||
out
|
||||
(let [line (first lines)
|
||||
trimmed (str/triml line)]
|
||||
(cond
|
||||
(str/blank? trimmed) (recur (subvec lines 1) out)
|
||||
|
||||
(re-find fence-re trimmed)
|
||||
(let [lang (second (re-find fence-re trimmed))
|
||||
rest-lines (subvec lines 1)
|
||||
close (first (keep-indexed #(when (re-find fence-close-re %2) %1) rest-lines))
|
||||
end (or close (count rest-lines))]
|
||||
(recur (subvec rest-lines (min (count rest-lines) (inc end)))
|
||||
(conj out (code-block lang (subvec rest-lines 0 end)))))
|
||||
|
||||
(re-find heading-re trimmed)
|
||||
(let [[_ hashes content] (re-find heading-re trimmed)]
|
||||
(recur (subvec lines 1)
|
||||
(conj out (into [(keyword (str "h" (count hashes)))] (inline-line->hiccup content)))))
|
||||
|
||||
(re-find hr-re trimmed) (recur (subvec lines 1) (conj out [:hr]))
|
||||
|
||||
(re-find quote-re trimmed)
|
||||
(let [quoted (take-while #(re-find quote-re (str/triml %)) lines)
|
||||
inner (str/join "\n" (map #(second (re-find quote-re (str/triml %))) quoted))]
|
||||
(recur (subvec lines (count quoted)) (conj out (into [:blockquote] (parse-blocks inner)))))
|
||||
|
||||
(re-find ul-re trimmed)
|
||||
(let [items (take-while #(re-find ul-re (str/triml %)) lines)]
|
||||
(recur (subvec lines (count items))
|
||||
(conj out (into [:ul] (map #(into [:li] (inline-line->hiccup (second (re-find ul-re (str/triml %)))))
|
||||
items)))))
|
||||
|
||||
(re-find ol-re trimmed)
|
||||
(let [items (take-while #(re-find ol-re (str/triml %)) lines)]
|
||||
(recur (subvec lines (count items))
|
||||
(conj out (into [:ol] (map #(into [:li] (inline-line->hiccup (second (re-find ol-re (str/triml %)))))
|
||||
items)))))
|
||||
|
||||
(and (str/includes? trimmed "|") (> (count lines) 1)
|
||||
(re-find table-sep-re (str/triml (second lines))))
|
||||
(let [body (->> (subvec lines 2) (take-while #(str/includes? (str/triml %) "|")))]
|
||||
(recur (subvec lines (+ 2 (count body))) (conj out (table trimmed body))))
|
||||
|
||||
:else
|
||||
(let [para (take-while (complement block-starter?) lines)]
|
||||
(recur (subvec lines (count para))
|
||||
(conj out (into [:p] (inline->hiccup (str/join "\n" (map str/trim para))))))))))))
|
||||
|
||||
(defn render
|
||||
"`text` (Markdown, possibly blank) as a Reagent fragment, ready to use as a hiccup child."
|
||||
[text]
|
||||
(into [:<>] (parse-blocks (str/trim (or text "")))))
|
||||
@@ -65,6 +65,14 @@
|
||||
description (assoc :description description)))))
|
||||
@registry))
|
||||
|
||||
(defn once-per-turn-names
|
||||
"The names of the tools offered on `page` that do something only one message's worth of
|
||||
chaining can call for (like a game move — the person asking again is what asks for another one,
|
||||
not the model on its own): tbd.ui.events stops offering, and stops running, one of these again
|
||||
once it has run once in the current turn."
|
||||
[page]
|
||||
(into #{} (comp (filter #(offered? page %)) (filter :once-per-turn?) (map :name)) @registry))
|
||||
|
||||
(defn register-state!
|
||||
"Replaces what the page offers as state with `providers` ({:pages :provide}, see this ns's
|
||||
docstring). Unlike `register!`'s tools (registered piecemeal, by name, from more than one
|
||||
|
||||
+98
-17
@@ -3,6 +3,7 @@
|
||||
[reagent.core :as r]
|
||||
[re-frame.core :as rf]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.markdown :as markdown]
|
||||
[tbd.ui.pages :as pages]
|
||||
[tbd.ui.subs :as subs]
|
||||
[tbd.ui.webmcp :as webmcp]))
|
||||
@@ -178,14 +179,40 @@
|
||||
|
||||
(def ^:private chat-green "#28a745")
|
||||
|
||||
;; What Markdown blocks (tbd.ui.markdown) look like inside a bubble: :white-space "pre-wrap" (the
|
||||
;; bubble's old way of keeping line breaks without any markup) is gone, since the hiccup now
|
||||
;; carries its own paragraphs, lists and code blocks; this fills in the spacing and borders
|
||||
;; browsers don't give those elements by default, and a low-alpha black overlay for code and
|
||||
;; rules, which reads on both the green and the grey bubble. Global, not scoped to one bubble,
|
||||
;; but "chat-markdown" is specific enough not to collide with anything else on the page.
|
||||
(defn- chat-markdown-style []
|
||||
[:style "
|
||||
.chat-markdown > :first-child { margin-top: 0; }
|
||||
.chat-markdown > :last-child { margin-bottom: 0; }
|
||||
.chat-markdown p, .chat-markdown ul, .chat-markdown ol, .chat-markdown pre,
|
||||
.chat-markdown blockquote, .chat-markdown table, .chat-markdown h1, .chat-markdown h2,
|
||||
.chat-markdown h3 { margin: 0 0 0.5em; }
|
||||
.chat-markdown ul, .chat-markdown ol { padding-left: 1.25em; }
|
||||
.chat-markdown li { margin: 0.15em 0; }
|
||||
.chat-markdown pre { padding: 0.5em; overflow-x: auto; background: rgba(0,0,0,0.08); border-radius: 0.35em; }
|
||||
.chat-markdown code { font-family: monospace; font-size: 0.85em; }
|
||||
.chat-markdown pre code { background: none; padding: 0; }
|
||||
.chat-markdown :not(pre) > code { background: rgba(0,0,0,0.1); padding: 0.1em 0.3em; border-radius: 0.25em; }
|
||||
.chat-markdown blockquote { padding-left: 0.6em; border-left: 2px solid currentColor; opacity: 0.85; }
|
||||
.chat-markdown table { border-collapse: collapse; }
|
||||
.chat-markdown th, .chat-markdown td { border: 1px solid currentColor; padding: 0.2em 0.5em; }
|
||||
.chat-markdown a { color: inherit; text-decoration: underline; }
|
||||
"])
|
||||
|
||||
(defn- chat-bubble [{:keys [role content]}]
|
||||
(let [user? (= "user" role)]
|
||||
[:div {:style {:align-self (if user? "flex-end" "flex-start")
|
||||
[:div {:class "chat-markdown"
|
||||
:style {:align-self (if user? "flex-end" "flex-start")
|
||||
:max-width "85%" :padding "0.4rem 0.6rem" :border-radius "0.5rem"
|
||||
:white-space "pre-wrap" :overflow-wrap "anywhere"
|
||||
:overflow-wrap "anywhere"
|
||||
:background (if user? chat-green "#f1f1f1")
|
||||
:color (if user? "white" "#222")}}
|
||||
content]))
|
||||
(markdown/render content)]))
|
||||
|
||||
(defn- chat-tool-line
|
||||
"A tool the assistant calls, or what came of it, apart from what is said, and in smaller print.
|
||||
@@ -208,22 +235,52 @@
|
||||
(defn- result-text [{:keys [name content error?]}]
|
||||
(str name (if error? " failed: " " → ") content))
|
||||
|
||||
(defn- chat-reasoning-block
|
||||
"A reply's reasoning, whole (never cut down, unlike a tool line): shown only with \"Show
|
||||
reasoning\" on, and then all of it, for whichever reply it belongs to."
|
||||
[text]
|
||||
[:div {:data-reasoning true
|
||||
:style {:align-self "flex-start" :max-width "85%" :flex-shrink 0
|
||||
:overflow-wrap "anywhere" :white-space "pre-wrap"
|
||||
:font-family "monospace" :font-size "12px" :font-style "italic" :color "#777"}}
|
||||
text])
|
||||
|
||||
(defn- chat-message
|
||||
"What was said, as a bubble, and the tool calls the assistant made with it, and their results,
|
||||
as lines between the bubbles."
|
||||
[tools-expanded? {:keys [role content tool-calls] :as message}]
|
||||
as lines between the bubbles. The reasoning behind a reply, if any, shows above it, whole, only
|
||||
when `reasoning-expanded?`."
|
||||
[tools-expanded? reasoning-expanded? {:keys [role content tool-calls thinking halted?] :as message}]
|
||||
(if (= "tool" role)
|
||||
[chat-tool-line tools-expanded? (result-text message) message]
|
||||
[:<>
|
||||
(when (and reasoning-expanded? (not (str/blank? thinking))) [chat-reasoning-block thinking])
|
||||
(when-not (str/blank? content) [chat-bubble message])
|
||||
(for [call tool-calls]
|
||||
^{:key (:id call)} [chat-tool-line tools-expanded? (call-text call) nil])]))
|
||||
^{:key (:id call)} [chat-tool-line tools-expanded? (call-text call) nil])
|
||||
(when halted?
|
||||
[:div {:data-halted true
|
||||
:style {:align-self "flex-start" :font-size "12px" :font-style "italic" :color "#777"}}
|
||||
"Stopped"])]))
|
||||
|
||||
(defn- tool-use?
|
||||
"Whether the conversation has any tool call or result."
|
||||
[messages]
|
||||
(some #(or (= "tool" (:role %)) (seq (:tool-calls %))) messages))
|
||||
|
||||
(defn- reasoning-use?
|
||||
"Whether the conversation has any reasoning to show."
|
||||
[messages]
|
||||
(some (comp not str/blank? :thinking) messages))
|
||||
|
||||
(defn- reply-pending?
|
||||
"Whether `message` (the last of the conversation) has yet to become the reply: it isn't the
|
||||
assistant's yet, or, now that reasoning joins the conversation as it comes (see
|
||||
::events/chat-event), it is an assistant message that is still only that reasoning — no content
|
||||
said, no tool calls asked for. \"Thinking…\" shows for as long as this holds."
|
||||
[{:keys [role content tool-calls]}]
|
||||
(or (not= "assistant" role)
|
||||
(and (str/blank? content) (empty? tool-calls))))
|
||||
|
||||
(def ^:private chat-min-width 260)
|
||||
(def ^:private chat-min-height 96)
|
||||
;; What the panel has besides the conversation (header, form, padding, and the gap under the
|
||||
@@ -252,22 +309,38 @@
|
||||
timer (js/setInterval #(reset! clock (js/Date.now)) thinking-tick-ms)]
|
||||
(let [now @clock
|
||||
live? (and thinking-at (< (- now thinking-at) thinking-live-ms))]
|
||||
;; The dots sit in a box of their own fixed width, so what follows (the stop button) stays put
|
||||
;; however many there are.
|
||||
[:div {:role "status" :style {:color "#777"}}
|
||||
(if live?
|
||||
(str "Thinking" (apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) ".")))
|
||||
"Thinking…")])
|
||||
"Thinking"
|
||||
[:span {:style {:display "inline-block" :width "1.2em"}}
|
||||
(if live?
|
||||
(apply str (repeat (inc (mod (quot now thinking-frame-ms) 3)) "."))
|
||||
"…")]])
|
||||
(finally (js/clearInterval timer))))
|
||||
|
||||
(defn- halt-button
|
||||
"The little square that stops the reply (see ::events/chat-halt), so the next message can steer it."
|
||||
[]
|
||||
[:button {:type "button" :aria-label "Stop" :title "Stop the reply"
|
||||
:on-click #(rf/dispatch [::events/chat-halt])
|
||||
:style {:display "inline-flex" :align-items "center" :justify-content "center"
|
||||
:width "1.25rem" :height "1.25rem" :padding 0 :cursor "pointer"
|
||||
:border "1px solid #bbb" :border-radius "50%" :background "white"}}
|
||||
[:span {:style {:width "0.5rem" :height "0.5rem" :background "#777" :border-radius "1px"}}]])
|
||||
|
||||
(defn- chat-log
|
||||
"The conversation, which follows its end (as the pieces of a reply come in) for as long as it is
|
||||
scrolled to it. Scroll up to read back and it stays where it is, until you send a message or
|
||||
scroll down to the end again (a message sent is among the ones that came since the last render,
|
||||
which may also hold the first of the reply). \"Thinking…\" shows from the sending until the reply's first piece
|
||||
(animated while the model's reasoning is coming in); what the model reasons is not shown."
|
||||
(animated while the model's reasoning is coming in), and a stop button beside it, for as long as
|
||||
the reply is on its way; what the model reasons shows, in full, only
|
||||
with \"Show reasoning\" on (see chat-reasoning-block)."
|
||||
[_chat _size]
|
||||
(let [stuck? (atom true)
|
||||
seen (atom 0)]
|
||||
(fn [{:keys [messages status thinking-at tools-expanded?]} {:keys [height]}]
|
||||
(fn [{:keys [messages status thinking-at tools-expanded? reasoning-expanded?]} {:keys [height]}]
|
||||
[:div {:role "log" :aria-live "polite"
|
||||
:ref (fn [el]
|
||||
(when el
|
||||
@@ -283,9 +356,12 @@
|
||||
(if (and (empty? messages) (not= :loading status))
|
||||
[:p {:style {:color "#777" :margin 0}} "Ask me anything."]
|
||||
(for [[i message] (map-indexed vector messages)]
|
||||
^{:key i} [chat-message tools-expanded? message]))
|
||||
(when (and (= :loading status) (not= "assistant" (:role (peek messages))))
|
||||
[thinking-line thinking-at])])))
|
||||
^{:key i} [chat-message tools-expanded? reasoning-expanded? message]))
|
||||
(when (= :loading status)
|
||||
[:div {:data-pending true
|
||||
:style {:display "flex" :align-items "center" :gap "0.4rem" :flex-shrink 0}}
|
||||
(when (reply-pending? (peek messages)) [thinking-line thinking-at])
|
||||
[halt-button]])])))
|
||||
|
||||
(defn- chat-form [{:keys [input status]}]
|
||||
(let [loading? (= :loading status)]
|
||||
@@ -293,9 +369,10 @@
|
||||
(.preventDefault e)
|
||||
(rf/dispatch [::events/chat-send]))
|
||||
:style {:display "flex" :gap "0.4rem"}}
|
||||
;; Read-only while waiting (rather than disabled) so it keeps the focus.
|
||||
;; Not disabled or read-only while waiting, so you can type the next message ahead of the
|
||||
;; reply; ::chat-send itself ignores a submit while a reply is still loading.
|
||||
[:input {:type "text" :name "message" :aria-label "Message" :placeholder "Message"
|
||||
:auto-focus true :auto-complete "off" :read-only loading?
|
||||
:auto-focus true :auto-complete "off"
|
||||
:style {:flex 1 :min-width 0}
|
||||
:value input
|
||||
:on-change #(rf/dispatch [::events/chat-set-input (.. % -target -value)])}]
|
||||
@@ -344,7 +421,7 @@
|
||||
:cursor "nesw-resize" :touch-action "none"
|
||||
:background "linear-gradient(225deg, #bbb 0 2px, transparent 2px 5px, #bbb 5px 7px, transparent 7px)"}}])
|
||||
|
||||
(defn- chat-panel [{:keys [messages status size tools-expanded?] :as chat} user]
|
||||
(defn- chat-panel [{:keys [messages status size tools-expanded? reasoning-expanded?] :as chat} user]
|
||||
[:div {:role "dialog" :aria-label "Chat"
|
||||
:style {:position "absolute" :bottom "40px" :left 0 :box-sizing "border-box"
|
||||
:width (str (:width size) "px")
|
||||
@@ -356,6 +433,9 @@
|
||||
(when (tool-use? messages)
|
||||
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-tools])}
|
||||
(if tools-expanded? "Collapse tool use" "Expand tool use")])
|
||||
(when (reasoning-use? messages)
|
||||
[link-button {:on-click #(rf/dispatch [::events/chat-toggle-reasoning])}
|
||||
(if reasoning-expanded? "Hide reasoning" "Show reasoning")])
|
||||
(when (and (seq messages) (not= :loading status))
|
||||
[link-button {:on-click #(rf/dispatch [::events/chat-clear])} "Clear"])
|
||||
[:button {:type "button" :aria-label "Close chat"
|
||||
@@ -375,6 +455,7 @@
|
||||
user @(rf/subscribe [::subs/user])]
|
||||
[:div {:style {:position "fixed" :left "20px" :bottom "20px" :z-index 9999
|
||||
:font-family "Arial, sans-serif" :font-size "14px"}}
|
||||
[chat-markdown-style]
|
||||
(when open? [chat-panel chat user])
|
||||
[:button {:type "button" :aria-label "Chat" :title "Chat" :aria-expanded (boolean open?)
|
||||
:style {:display "block" :width "30px" :height "30px" :padding 0 :border 0
|
||||
|
||||
+21
-30
@@ -11,7 +11,7 @@
|
||||
what an MCP client lists next to the tools (Claude Code shows the prompts as slash commands and
|
||||
the resources as @-mentions). They are the same instructions the page's own chatbot is given
|
||||
(tbd.agent.prompt, shared with the server), so Claude or Codex is told to act rather than offer,
|
||||
to chain calls and to play tic-tac-toe by the turn, and can read what page is open.
|
||||
to chain calls, and can read what page is open.
|
||||
|
||||
The same tools are registered with tbd.ui.model-context (by tbd.ui.core), which is how the page's
|
||||
own chatbot offers them to its LLM and calls them, the ones of the page being shown (see
|
||||
@@ -19,7 +19,11 @@
|
||||
agent outside the page. A `:read-only? true` tool (one that only reads what `state-providers`
|
||||
already covers, like list_todos) stays registered here for WebMCP's outside agents, but is left
|
||||
out of what the page's own chatbot is offered (see tbd.ui.model-context/definitions): that
|
||||
chatbot is handed the state instead, through `state-providers`.
|
||||
chatbot is handed the state instead, through `state-providers`. A `:once-per-turn? true` tool
|
||||
(like move_tic_tac_toe: a game move is the person's to ask for again, not the model's to repeat
|
||||
on its own) is offered to the chatbot as usual, but only until it has been called once in the
|
||||
current turn — tbd.ui.events stops offering it, and refuses a second call, for the rest of the
|
||||
turn (this app's own loop only: it doesn't apply to WebMCP's outside agents, who run their own).
|
||||
|
||||
A tool takes its arguments as a map and returns a value or a promise of one: a string, or data
|
||||
that becomes JSON. Throwing (or rejecting) becomes an error result the agent can read. Input
|
||||
@@ -317,8 +321,8 @@
|
||||
{:pages #{:calculator} :provide (fn [] (:calc (db)))}])
|
||||
|
||||
(defn- move-tic-tac-toe
|
||||
"Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn. Resolves to
|
||||
nil (\"ok\") once it lands: the board shows it, and the next request's state has it too."
|
||||
"Presses cell `cell` as `player` (\"x\" or \"o\"), only if it is that player's turn. Returns the
|
||||
board afterwards (the same shape as get_tic_tac_toe), so the result itself says what changed."
|
||||
[{:keys [cell player]}]
|
||||
(when-not (and (number? cell) (js/Number.isInteger cell) (<= 0 cell 8))
|
||||
(fail! "invalid arguments: cell must be an integer from 0 to 8"))
|
||||
@@ -326,21 +330,14 @@
|
||||
(fail! "invalid arguments: player must be \"x\" or \"o\""))
|
||||
(let [{:keys [board turn]} (:ttt (db))]
|
||||
(when (tictactoe/outcome board)
|
||||
(fail! "the game is over: start a new game"))
|
||||
(fail! "the game is over: the person starts a new one, with the page's own New game button"))
|
||||
(when (not= player (name turn))
|
||||
(fail! (str "it is " (name turn) "'s turn, not " player "'s: wait for the other side to move")))
|
||||
(when (board cell)
|
||||
(fail! (str "cell " cell " is taken")))
|
||||
(show! :tic-tac-toe)
|
||||
(rf/dispatch-sync [::events/ttt-move cell])
|
||||
nil))
|
||||
|
||||
(defn- new-tic-tac-toe-game
|
||||
"Presses New game. Resolves to nil (\"ok\"): the empty board shows it, and so does the state."
|
||||
[_]
|
||||
(show! :tic-tac-toe)
|
||||
(rf/dispatch-sync [::events/ttt-reset])
|
||||
nil)
|
||||
(tic-tac-toe-state)))
|
||||
|
||||
(defn- object-schema [properties required]
|
||||
{:type "object" :properties properties :required required})
|
||||
@@ -433,25 +430,21 @@
|
||||
:description (str "The tic-tac-toe game on this page (JSON): board (9 cells, row by row, cell 0 the top left "
|
||||
"and cell 8 the bottom right; null when empty, else \"x\" or \"o\"), turn (whose move it "
|
||||
"is, \"x\" or \"o\": X goes first, and they alternate) and status (in_progress, won or draw; "
|
||||
"when won, also winner and line). A person moves on the same board, so check the turn "
|
||||
"before you move, and only move for your own side")
|
||||
"when won, also winner and line)")
|
||||
:input-schema (object-schema {} []) :handler get-tic-tac-toe}
|
||||
|
||||
{:name "move_tic_tac_toe" :pages #{:tic-tac-toe}
|
||||
:description (str "Presses a cell of the tic-tac-toe board as `player`, your side. Fails, and changes nothing, "
|
||||
"if it is not your side's turn (the other side is the person's: wait for them to move), the "
|
||||
"cell is taken or the game is over. Never move for the other side")
|
||||
{:name "move_tic_tac_toe" :pages #{:tic-tac-toe} :once-per-turn? true
|
||||
:description (str "Presses a cell of the tic-tac-toe board as `player`, and returns the board afterwards "
|
||||
"(JSON, the same shape as get_tic_tac_toe). Fails, and changes nothing, if it isn't that "
|
||||
"side's turn yet, the cell is taken or the game is over. Runs at most once per message: "
|
||||
"asked for a move, make the one call and answer with a short line, a board sketch if that "
|
||||
"helps — a second call this turn is refused, unasked")
|
||||
:input-schema (object-schema {:cell {:type "integer" :minimum 0 :maximum 8
|
||||
:description "0 is the top left, 2 the top right, 8 the bottom right"}
|
||||
:player {:type "string" :enum ["x" "o"]
|
||||
:description (str "The side you play. The move is refused if it "
|
||||
"is the other side's turn")}}
|
||||
:description "Which side this move is for"}}
|
||||
["cell" "player"])
|
||||
:handler move-tic-tac-toe}
|
||||
|
||||
{:name "new_tic_tac_toe_game" :pages #{:tic-tac-toe}
|
||||
:description "Presses New game: clears the tic-tac-toe board, X to move"
|
||||
:input-schema (object-schema {} []) :handler new-tic-tac-toe-game}])
|
||||
:handler move-tic-tac-toe}])
|
||||
|
||||
;; --- Prompts and resources ---
|
||||
|
||||
@@ -467,10 +460,8 @@
|
||||
:handler (fn [{:keys [task]}] (prompt/task task))}
|
||||
|
||||
{:name "play_tic_tac_toe"
|
||||
:description "Plays tic-tac-toe with you on the page: moves only on its own side's turn, one move at a time"
|
||||
:arguments [{:name "side" :required false
|
||||
:description "The side the agent plays, \"x\" or \"o\" (default o: you play X and start)"}]
|
||||
:handler (fn [{:keys [side]}] (prompt/tic-tac-toe side))}])
|
||||
:description "Plays tic-tac-toe with you on the page"
|
||||
:handler (fn [_] prompt/tic-tac-toe)}])
|
||||
|
||||
(defn- page-state
|
||||
"A promise of what the page is showing: the open page, the pages and who is logged in."
|
||||
|
||||
+216
-31
@@ -1,6 +1,5 @@
|
||||
(ns tbd.ui.events-test
|
||||
(:require [cljs.test :refer [deftest is testing async use-fixtures]]
|
||||
[clojure.string :as str]
|
||||
[re-frame.core :as rf]
|
||||
[re-frame.db :as rf-db]
|
||||
[tbd.ui.db :as db]
|
||||
@@ -25,6 +24,7 @@
|
||||
:after model-context/clear!}
|
||||
(tu/stub-effects-fixture {::events/fetch (record ::events/fetch)
|
||||
::events/fetch-stream (record ::events/fetch-stream)
|
||||
::events/abort-stream (record ::events/abort-stream)
|
||||
::events/persist-chat (record ::events/persist-chat)
|
||||
::events/call-tools (record ::events/call-tools)
|
||||
::events/copy-to-clipboard (record ::events/copy-to-clipboard)
|
||||
@@ -334,6 +334,18 @@
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(is (false? (:open? (chat)))))
|
||||
|
||||
(deftest chat-toggle-persists-across-a-reload-test
|
||||
(start!)
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(is (true? (:open? (chat))))
|
||||
(testing "a fresh start picks the open panel back up"
|
||||
(dispatch! [::events/initialize])
|
||||
(is (true? (:open? (chat)))))
|
||||
(dispatch! [::events/chat-toggle])
|
||||
(testing "and its being closed again"
|
||||
(dispatch! [::events/initialize])
|
||||
(is (false? (:open? (chat))))))
|
||||
|
||||
(defn- without-ids
|
||||
"`messages`, as AG-UI has them on the wire, with the per-message `:id` (a counter, unpredictable
|
||||
from a test) dropped, so what is left can be compared."
|
||||
@@ -379,19 +391,22 @@
|
||||
(deftest chat-streaming-reply-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(testing "the model's reasoning is not kept, and it keeps waiting"
|
||||
(testing "the model's reasoning joins the conversation of its own reply, and it keeps waiting"
|
||||
(event! {:thinking "Let me "})
|
||||
(event! {:thinking "think."})
|
||||
(is (= [{:role "user" :content "hello"}] (:messages (chat))))
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "" :thinking "Let me think."}]
|
||||
(:messages (chat))))
|
||||
(is (= :loading (:status (chat)))))
|
||||
(testing "the first piece of the reply, and the ones that follow, are added to that message"
|
||||
(event! {:content "Hel"})
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel"}]
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hel" :thinking "Let me think."}]
|
||||
(:messages (chat))))
|
||||
(event! {:content "lo, "})
|
||||
(event! {:content "world"})
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hello, world"}]
|
||||
{:role "assistant" :content "Hello, world" :thinking "Let me think."}]
|
||||
(:messages (chat))))
|
||||
(is (= :loading (:status (chat))) "it isn't over until it says so"))
|
||||
(testing "another message can't be sent while the reply is coming in"
|
||||
@@ -401,12 +416,12 @@
|
||||
(event! {:done true})
|
||||
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
|
||||
(is (= [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "Hello, world"}]
|
||||
{:role "assistant" :content "Hello, world" :thinking "Let me think."}]
|
||||
(:messages (chat)))))
|
||||
(testing "events that come after the end are dropped"
|
||||
(event! {:content "late"})
|
||||
(is (= "Hello, world" (:content (last (:messages (chat)))))))
|
||||
(testing "the next message has the conversation so far"
|
||||
(testing "the next message has the conversation so far, without the reasoning (which stays only for display)"
|
||||
(say! "again")
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hello, world"}
|
||||
{:role "user" :content "again"}]
|
||||
@@ -448,15 +463,16 @@
|
||||
(say! "hello")
|
||||
(event! {:thinking "hm" :content "Hi"})
|
||||
(event! {:thinking "m" :content "!"})
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!"}]
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!" :thinking "hmm"}]
|
||||
(:messages (chat))))
|
||||
(testing "an empty piece changes nothing"
|
||||
(event! {:thinking "" :content ""})
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!"}]
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hi!" :thinking "hmm"}]
|
||||
(:messages (chat))))))
|
||||
|
||||
(deftest chat-thinking-is-never-kept-test
|
||||
;; The reasoning of each reply of a turn, before and after tools, leaves nothing in the conversation.
|
||||
(deftest chat-thinking-per-reply-test
|
||||
;; Each reply of a turn (before and after tools) keeps its own reasoning, on its own message, not
|
||||
;; sent to the LLM, but there for "Show reasoning" to reveal.
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
(event! {:thinking "first"})
|
||||
@@ -465,9 +481,9 @@
|
||||
(dispatch! [::events/chat-tool-results [{:id "c1" :name "ping" :content "pong" :error? false}]])
|
||||
(event! {:thinking "second"})
|
||||
(event! {:content "done"})
|
||||
(is (= [["user" nil] ["assistant" nil] ["tool" nil] ["assistant" nil]]
|
||||
(is (= [["user" nil] ["assistant" "first"] ["tool" nil] ["assistant" "second"]]
|
||||
(map (juxt :role :thinking) (:messages (chat)))))
|
||||
(is (not-any? #(re-find #"first|second" (pr-str %)) (:messages (chat)))))
|
||||
(is (not-any? #(re-find #"first|second" (pr-str %)) (sent-messages (last-request)))))
|
||||
|
||||
(deftest chat-blank-message-test
|
||||
(logged-in! [])
|
||||
@@ -595,6 +611,19 @@
|
||||
(dispatch! [::events/chat-toggle-tools])
|
||||
(is (false? (:tools-expanded? (chat)))))
|
||||
|
||||
(deftest chat-toggle-reasoning-test
|
||||
(logged-in! [])
|
||||
(is (false? (:reasoning-expanded? (chat))) "reasoning is hidden by default")
|
||||
(dispatch! [::events/chat-toggle-reasoning])
|
||||
(is (true? (:reasoning-expanded? (chat))))
|
||||
(testing "the choice stays when the conversation starts over"
|
||||
(say! "hello")
|
||||
(reply! "Hi!")
|
||||
(dispatch! [::events/chat-clear])
|
||||
(is (true? (:reasoning-expanded? (chat)))))
|
||||
(dispatch! [::events/chat-toggle-reasoning])
|
||||
(is (false? (:reasoning-expanded? (chat)))))
|
||||
|
||||
(deftest chat-resize-test
|
||||
(logged-in! [])
|
||||
(is (= {:width 320 :height 256} (:size (chat))) "the size it starts with")
|
||||
@@ -611,6 +640,12 @@
|
||||
(answer! 200 {:logged-out true})
|
||||
(is (= {:width 500 :height 400} (:size (chat))))))
|
||||
|
||||
(deftest chat-resize-persists-across-a-reload-test
|
||||
(logged-in! [])
|
||||
(dispatch! [::events/chat-resize 500 400])
|
||||
(dispatch! [::events/initialize])
|
||||
(is (= {:width 500 :height 400} (:size (chat)))))
|
||||
|
||||
(deftest chat-forgotten-on-logout-test
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
@@ -654,6 +689,62 @@
|
||||
{:id id :name tool-name :content content :error? error?})
|
||||
results))))
|
||||
|
||||
(defn- aborted-streams [] (count (filter (comp #{::events/abort-stream} first) @effects)))
|
||||
|
||||
(deftest chat-halt-test
|
||||
(testing "halting while it only reasons: the stream stops, and the reasoning stays on screen, marked"
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(event! {:thinking "hmm, maybe"})
|
||||
(dispatch! [::events/chat-halt])
|
||||
(is (= 1 (aborted-streams)))
|
||||
(is (= {:messages [{:role "user" :content "hello"}
|
||||
{:role "assistant" :content "" :thinking "hmm, maybe" :halted? true}]
|
||||
:input "" :status :idle :error nil}
|
||||
(select-keys (chat) [:messages :input :status :error])))
|
||||
(testing "but isn't saved, nor sent: there is nothing in it for the server"
|
||||
(is (= {:messages [{:role "user" :content "hello"}]} (:body (last-persist-request))))
|
||||
(say! "no, do it this way")
|
||||
(is (= [{:role "user" :content "hello"} {:role "user" :content "no, do it this way"}]
|
||||
(sent-messages (last-request))))))
|
||||
(testing "halting mid-reply keeps what was said, and the next message steers from it"
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(event! {:content "Hel"})
|
||||
(dispatch! [::events/chat-halt])
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel" :halted? true}]
|
||||
(:messages (chat))))
|
||||
(testing "events that come after are dropped"
|
||||
(event! {:content "lo"})
|
||||
(event! {:done true})
|
||||
(is (= "Hel" (:content (last (:messages (chat)))))))
|
||||
(say! "shorter please")
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "Hel"}
|
||||
{:role "user" :content "shorter please"}]
|
||||
(sent-messages (last-request)))))
|
||||
(testing "halting before anything came"
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(dispatch! [::events/chat-halt])
|
||||
(is (= [{:role "user" :content "hello"} {:role "assistant" :content "" :halted? true}]
|
||||
(:messages (chat)))))
|
||||
(testing "halting while the tools run: each call gets an answer, and their real results are dropped"
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(asks! (call "c1" "add" "{}"))
|
||||
(dispatch! [::events/chat-halt])
|
||||
(is (= :idle (:status (chat))))
|
||||
(is (= {:role "tool" :tool-call-id "c1" :name "add" :error? true}
|
||||
(dissoc (last (:messages (chat))) :content)))
|
||||
(let [n (count (:messages (chat)))]
|
||||
(ran! ["c1" "add" "5"])
|
||||
(is (= n (count (:messages (chat))))))
|
||||
(is (= 1 (count (requests))) "nothing more went to the LLM"))
|
||||
(testing "halting when nothing is on its way does nothing"
|
||||
(logged-in! [])
|
||||
(dispatch! [::events/chat-halt])
|
||||
(is (zero? (aborted-streams)))))
|
||||
|
||||
(deftest chat-offers-the-tools-test
|
||||
(logged-in! [])
|
||||
(testing "no tools on the page, none offered"
|
||||
@@ -750,15 +841,17 @@
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(say! "1+2?")
|
||||
(testing "while the model reasons or writes a call, nothing is done, and the conversation has neither"
|
||||
(testing "while the model reasons or writes a call, nothing is done, and no tools have run"
|
||||
(event! {:thinking "I should add."})
|
||||
(event! {:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]})
|
||||
(is (= [{:role "user" :content "1+2?"}] (:messages (chat))))
|
||||
(is (= [{:role "user" :content "1+2?"}
|
||||
{:role "assistant" :content "" :thinking "I should add."}]
|
||||
(:messages (chat))))
|
||||
(is (= [] (tool-calls-asked))))
|
||||
(testing "when the reply is over, the calls join the conversation and are made"
|
||||
(event! {:done true})
|
||||
(is (= [{:role "user" :content "1+2?"}
|
||||
{:role "assistant" :content ""
|
||||
{:role "assistant" :content "" :thinking "I should add."
|
||||
:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")]}]
|
||||
(:messages (chat))))
|
||||
(is (= :loading (:status (chat))) "the LLM still has to answer")
|
||||
@@ -785,6 +878,57 @@
|
||||
(is (= {:status :idle :error nil} (select-keys (chat) [:status :error])))
|
||||
(is (nil? (:pending-calls (chat))))))
|
||||
|
||||
(deftest chat-tool-result-too-big-for-the-server-test
|
||||
;; A result over the LLM's limit is kept whole in the tab and in /api/chat/history (for "Expand
|
||||
;; tool use" to show all of it, even after a reload), but fit to that limit for the LLM.
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(let [huge (apply str (repeat 9000 "x"))]
|
||||
(say! "1+2?")
|
||||
(event! {:tool-calls [(call "c1" "add" "{\"x\":1,\"y\":2}")] :done true})
|
||||
(ran! ["c1" "add" huge false])
|
||||
(testing "the tab's own copy is whole"
|
||||
(is (= huge (:content (last (:messages (chat)))))))
|
||||
(testing "what goes to the LLM is fit to the server's limit"
|
||||
(let [sent (:content (last (sent-messages (last-request))))]
|
||||
(is (= 8000 (count sent)))
|
||||
(is (= "xxx … (truncated)" (subs sent 7983)))))
|
||||
(reply! "It's 3.")
|
||||
(testing "what's saved for next login is whole, once the turn ends"
|
||||
(let [saved (:content (first (filter #(= "tool" (:role %)) (:messages (:body (last-persist-request))))))]
|
||||
(is (= huge saved))))))
|
||||
|
||||
(deftest chat-reasoning-too-big-for-history-test
|
||||
;; Reasoning, like a tool result, is kept whole in the tab and in what's saved (for "Show
|
||||
;; reasoning" to show all of it, even after a reload), up to the history's own, larger limit.
|
||||
(logged-in! [])
|
||||
(say! "hello")
|
||||
(let [huge (apply str (repeat 100010 "x"))]
|
||||
(event! {:thinking huge})
|
||||
(testing "the tab's own copy is whole"
|
||||
(is (= huge (:thinking (last (:messages (chat)))))))
|
||||
(reply! "Hi!")
|
||||
(testing "what's saved for next login is fit to the history's limit"
|
||||
(let [saved (:thinking (first (filter :thinking (:messages (:body (last-persist-request))))))]
|
||||
(is (= 100000 (count saved)))
|
||||
(is (= "xxx … (truncated)" (subs saved 99983)))))))
|
||||
|
||||
(deftest chat-history-too-big-drops-oldest-test
|
||||
;; Past the history's total limit, the oldest turns go, whole.
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "add" :description "Adds" :input-schema add-schema :handler identity}])
|
||||
(let [big (apply str (repeat 90000 "x"))]
|
||||
(dotimes [i 12]
|
||||
(say! (str "q" i))
|
||||
(event! {:tool-calls [(call (str "c" i) "add" "{}")] :done true})
|
||||
(ran! [(str "c" i) "add" big false])
|
||||
(reply! (str "a" i)))
|
||||
(let [saved (:messages (:body (last-persist-request)))]
|
||||
(is (<= (count (pr-str saved)) 1000000))
|
||||
(is (= "user" (:role (first saved))))
|
||||
(is (= "a11" (:content (last saved))))
|
||||
(is (every? #(= big (:content %)) (filter #(= "tool" (:role %)) saved))))))
|
||||
|
||||
(deftest chat-tool-call-with-text-test
|
||||
(logged-in! [])
|
||||
(say! "hi")
|
||||
@@ -820,6 +964,41 @@
|
||||
(dispatch! [::events/chat-send])
|
||||
(is (zero? (:tool-calls-used (chat))))))
|
||||
|
||||
(deftest chat-once-per-turn-tools-test
|
||||
;; A once-per-turn tool (like tic-tac-toe's move_tic_tac_toe: the bug this guards against was
|
||||
;; the chatbot happily playing both sides of one game in answer to a single "make a move") may
|
||||
;; run once in a turn; a second attempt, whether the model asks again after the first result or
|
||||
;; in the very same reply, is refused without ever reaching the page.
|
||||
(logged-in! [])
|
||||
(model-context/register! [{:name "move" :once-per-turn? true :description "d" :input-schema add-schema
|
||||
:handler identity}
|
||||
{:name "ping" :description "d" :input-schema add-schema :handler identity}])
|
||||
(say! "make a move")
|
||||
(testing "offered like any other tool, the first time"
|
||||
(is (= ["move" "ping"] (map :name (:tools (:body (last-request)))))))
|
||||
(testing "once it has run, it is no longer offered for the rest of the turn"
|
||||
(asks! (call "a" "move" "{}"))
|
||||
(is (= [(call "a" "move" "{}")] (:calls (last (tool-calls-asked)))) "the first call goes through, unmarked")
|
||||
(ran! ["a" "move" "ok" false])
|
||||
(is (= ["ping"] (map :name (:tools (:body (last-request)))))))
|
||||
(testing "asking for it again anyway this turn is refused before it ever reaches the page"
|
||||
(asks! (call "b" "move" "{}"))
|
||||
(is (= [(assoc (call "b" "move" "{}") :blocked? true)] (:calls (last (tool-calls-asked))))))
|
||||
(testing "two calls to it in the very same reply: only the first of them runs"
|
||||
(ran! ["b" "move" "n/a" true])
|
||||
(reply! "Can't move again this turn.")
|
||||
(say! "go again")
|
||||
(asks! (call "c" "move" "{}") (call "d" "move" "{}"))
|
||||
(is (= [(call "c" "move" "{}") (assoc (call "d" "move" "{}") :blocked? true)]
|
||||
(:calls (last (tool-calls-asked))))))
|
||||
(testing "a new message starts a fresh turn: the tool is offered, and may run, again"
|
||||
(ran! ["c" "move" "n/a" false] ["d" "move" "n/a" true])
|
||||
(reply! "Moved.")
|
||||
(say! "make another")
|
||||
(is (= ["move" "ping"] (map :name (:tools (:body (last-request))))))
|
||||
(asks! (call "e" "move" "{}"))
|
||||
(is (= [(call "e" "move" "{}")] (:calls (last (tool-calls-asked)))))))
|
||||
|
||||
(deftest chat-tool-call-budget-test
|
||||
(logged-in! [])
|
||||
(say! "go wild")
|
||||
@@ -896,7 +1075,11 @@
|
||||
(select-keys (chat) [:messages :input :status :error :pending-calls])))
|
||||
(is (= [] (tool-calls-asked)))))
|
||||
|
||||
(deftest chat-sends-results-of-earlier-turns-as-out-of-date-test
|
||||
(deftest chat-sends-results-of-earlier-turns-as-they-are-test
|
||||
;; Nothing here marks an old result stale: the request's `state` (tbd.ui.model-context/
|
||||
;; current-state) is refreshed on every message, and the system prompt tells the model that is
|
||||
;; what to trust over anything said earlier, an old result included — so there is nothing left
|
||||
;; for a marker on the result itself to do.
|
||||
(logged-in! [])
|
||||
(swap! rf-db/app-db assoc-in [:chat :messages]
|
||||
[{:role "user" :content "play"}
|
||||
@@ -904,20 +1087,19 @@
|
||||
{:role "tool" :tool-call-id "old" :name "get_tic_tac_toe" :content "{\"turn\":\"x\"}" :error? false}
|
||||
{:role "assistant" :content "Your move."}])
|
||||
(say! "that's wrong, it's my turn")
|
||||
(testing "a result from before the user's last message is no longer sent, its call and reply are"
|
||||
(testing "an earlier result is sent as it was, like its call and reply"
|
||||
(let [sent (get-in (last-request) [:body :messages])]
|
||||
(is (= ["user" "assistant" "tool" "assistant" "user"] (map :role sent)))
|
||||
(is (= "old" (:toolCallId (nth sent 2))))
|
||||
(is (str/includes? (:content (nth sent 2)) "out of date"))
|
||||
(is (not (str/includes? (:content (nth sent 2)) "\"turn\"")) "what it read is gone")
|
||||
(is (= "{\"turn\":\"x\"}" (:content (nth sent 2))))
|
||||
(is (= "Your move." (:content (nth sent 3))))))
|
||||
(testing "the conversation the user sees keeps the result"
|
||||
(is (= "{\"turn\":\"x\"}" (:content (nth (:messages (chat)) 2)))))
|
||||
(testing "the results of the turn going on are sent as they are, for the chain to continue"
|
||||
(testing "the results of the turn going on are sent as they are too, for the chain to continue"
|
||||
(asks! (call "new" "get_tic_tac_toe" "{}"))
|
||||
(ran! ["new" "get_tic_tac_toe" "{\"turn\":\"o\"}" false])
|
||||
(let [sent (get-in (last-request) [:body :messages])]
|
||||
(is (str/includes? (:content (nth sent 2)) "out of date"))
|
||||
(is (= "{\"turn\":\"x\"}" (:content (nth sent 2))))
|
||||
(is (= "{\"turn\":\"o\"}" (:content (last sent)))))))
|
||||
|
||||
(deftest chat-sends-no-orphaned-result-test
|
||||
@@ -985,23 +1167,26 @@
|
||||
(call "4" "blank" "")
|
||||
(call "5" "fails" "{}")
|
||||
(call "6" "nope" "{}")
|
||||
(call "7" "fast" "oops")]
|
||||
(call "7" "fast" "oops")
|
||||
(assoc (call "8" "fast" "{}") :blocked? true)]
|
||||
:on-results [::ran]})))
|
||||
(fn [results]
|
||||
(testing "one after the other, in order: the tools work on the same page"
|
||||
(is (= [:slow :fast] @order)))
|
||||
(is (= [:slow :fast] @order)) "the blocked call never touches the tool, so \"fast\" runs only once")
|
||||
(testing "a result for each call, whatever became of it"
|
||||
(is (= ["1" "2" "3" "4" "5" "6" "7"] (map :id results)))
|
||||
(is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast"] (map :name results)))
|
||||
(is (= ["1" "2" "3" "4" "5" "6" "7" "8"] (map :id results)))
|
||||
(is (= ["slow" "fast" "huge" "blank" "fails" "nope" "fast" "fast"] (map :name results)))
|
||||
(is (= ["slow done" "fast {:x 1}"] (map :content (take 2 results)))))
|
||||
(testing "a result is never empty, and never longer than the server takes"
|
||||
(testing "a result is never empty, and kept whole (fit to the server's limit only once it leaves the tab)"
|
||||
(is (= "(no output)" (:content (nth results 3))))
|
||||
(is (= 8000 (count (:content (nth results 2)))))
|
||||
(is (= "xxx … (truncated)" (subs (:content (nth results 2)) 7983))))
|
||||
(is (= 9000 (count (:content (nth results 2))))))
|
||||
(testing "failures are results for the LLM to read"
|
||||
(is (= [false false false false true true true] (map (comp boolean :error?) results)))
|
||||
(is (= [false false false false true true true true] (map (comp boolean :error?) results)))
|
||||
(is (= ["it broke" "unknown tool: nope" "invalid arguments: they must be a JSON object"]
|
||||
(map :content (drop 4 results))))))
|
||||
(map :content (drop 4 (take 7 results))))))
|
||||
(testing "a blocked call is refused before it ever reaches the tool"
|
||||
(is (= "not run: this only runs once per message, and already has this turn — answer instead of calling it again"
|
||||
(:content (last results))))))
|
||||
#(js/Promise. (fn [resolve]
|
||||
(reset! answer resolve)
|
||||
(call-tools-fx {:calls [] :on-results [::ran]})))
|
||||
|
||||
@@ -55,10 +55,43 @@
|
||||
(tu/steps
|
||||
#(stream! (streaming asked (sse {:type "RUN_FINISHED"})) 1)
|
||||
(fn [_]
|
||||
(is (= ["/api/chat" {:method "POST"
|
||||
:headers {:Content-Type "application/edn"}
|
||||
:body "{:x 1}"}]
|
||||
@asked))))
|
||||
(let [[uri opts] @asked]
|
||||
(is (= ["/api/chat" {:method "POST"
|
||||
:headers {:Content-Type "application/edn"}
|
||||
:body "{:x 1}"}]
|
||||
[uri (dissoc opts :signal)]))
|
||||
(is (instance? js/AbortSignal (:signal opts)) "with a signal, for ::abort-stream"))))
|
||||
done))))
|
||||
|
||||
(deftest abort-test
|
||||
;; Halted (see ::events/chat-halt): nothing more is dispatched — not the rest of the stream, nor
|
||||
;; the \"connection lost\" its end would otherwise be.
|
||||
(async done
|
||||
(let [release (atom nil)
|
||||
fetch (fn [_ _]
|
||||
(js/Promise.resolve
|
||||
#js {:ok true :status 200
|
||||
:body #js {:getReader
|
||||
(fn []
|
||||
(let [reads (atom [(sse {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}) :wait])]
|
||||
#js {:read (fn []
|
||||
(let [r (first @reads)]
|
||||
(swap! reads rest)
|
||||
(cond
|
||||
(= :wait r) (js/Promise. #(reset! release %))
|
||||
(nil? r) (js/Promise.resolve #js {:done true})
|
||||
:else (js/Promise.resolve #js {:done false :value r}))))
|
||||
:cancel (fn [] (js/Promise.resolve nil))}))}}))]
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(stream! fetch 1)
|
||||
(fn [got]
|
||||
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] got))
|
||||
((tu/real-effect ::events/abort-stream) true)
|
||||
(@release #js {:done false :value (sse {:type "TEXT_MESSAGE_CONTENT" :delta "late"})})
|
||||
(js/Promise. (fn [resolve] (js/setTimeout resolve 30))))
|
||||
(fn [_]
|
||||
(is (= [[:event {:type "TEXT_MESSAGE_CONTENT" :delta "Hi"}]] @got) "nothing after the abort")))
|
||||
done))))
|
||||
|
||||
(deftest events-test
|
||||
|
||||
@@ -0,0 +1,34 @@
|
||||
(ns tbd.ui.markdown-test
|
||||
(:require [cljs.test :refer [deftest is testing]]
|
||||
[tbd.ui.markdown :as markdown]))
|
||||
|
||||
(deftest render-test
|
||||
(testing "plain text, wrapped in a paragraph"
|
||||
(is (= [:<> [:p "hello"]] (markdown/render "hello"))))
|
||||
(testing "inline formatting"
|
||||
(is (= [:<> [:p "a " [:strong "bold"] " " [:em "word"] " and " [:code "code"]]]
|
||||
(markdown/render "a **bold** *word* and `code`"))))
|
||||
(testing "a single newline is a line break, not a new paragraph"
|
||||
(is (= [:<> [:p "one" [:br] "two"]] (markdown/render "one\ntwo"))))
|
||||
(testing "a stray * or _ that isn't emphasis (padded with a space) is left alone"
|
||||
(is (= [:<> [:p "3 * 4 * 5"]] (markdown/render "3 * 4 * 5"))))
|
||||
(testing "headings, a list, a fenced code block"
|
||||
(is (= [:<>
|
||||
[:h1 "Title"]
|
||||
[:ul [:li "a"] [:li "b"]]
|
||||
[:pre [:code {:class "language-js"} "1"]]]
|
||||
(markdown/render "# Title\n\n- a\n- b\n\n```js\n1\n```"))))
|
||||
(testing "an ordered list and a blockquote"
|
||||
(is (= [:<> [:ol [:li "a"] [:li "b"]]] (markdown/render "1. a\n2. b")))
|
||||
(is (= [:<> [:blockquote [:p "hi"]]] (markdown/render "> hi"))))
|
||||
(testing "a table"
|
||||
(is (= [:<> [:table [:thead [:tr [:th "a"] [:th "b"]]]
|
||||
[:tbody [:tr [:td "1"] [:td "2"]]]]]
|
||||
(markdown/render "a | b\n-|-\n1 | 2"))))
|
||||
(testing "no markup leaks through as HTML: it's always a plain string, never dangerouslySetInnerHTML"
|
||||
(is (= [:<> [:p "hi<script>alert(1)</script>"]] (markdown/render "hi<script>alert(1)</script>"))))
|
||||
(testing "a link opens in its own tab, not the app's"
|
||||
(is (= [:<> [:p [:a {:href "https://example.com" :target "_blank" :rel "noopener noreferrer"} "x"]]]
|
||||
(markdown/render "[x](https://example.com)"))))
|
||||
(testing "a javascript: link loses its href (and so its target/rel), the text stays"
|
||||
(is (= [:<> [:p [:span "x"]]] (markdown/render "[x](javascript:evil)")))))
|
||||
@@ -174,10 +174,13 @@
|
||||
(aset js/globalThis "fetch" real-fetch))})
|
||||
|
||||
(def url-fixture
|
||||
"Each test starts on the page's own address, with no fragment (the page shown is the first)."
|
||||
(let [reset-hash! #(set! js/location.hash "")]
|
||||
{:before reset-hash!
|
||||
:after reset-hash!}))
|
||||
"Each test starts on the page's own address, with no fragment (the page shown is the first), and
|
||||
with nothing saved in localStorage (e.g. the chat widget's :open?/:size, see
|
||||
tbd.ui.events/persist-chat-ui) — jsdom's window, and so its localStorage, is shared by every
|
||||
test in the process."
|
||||
(let [reset! #(do (set! js/location.hash "") (.clear js/localStorage))]
|
||||
{:before reset!
|
||||
:after reset!}))
|
||||
|
||||
(defn log-in! [] (swap! server assoc :user {:login "alice" :id 7}))
|
||||
|
||||
|
||||
@@ -1,10 +1,13 @@
|
||||
(ns tbd.ui.tictactoe-test
|
||||
(:require [cljs.test :refer [deftest is testing]]
|
||||
(:require [cljs.test :refer [deftest is testing use-fixtures]]
|
||||
[re-frame.core :as rf]
|
||||
[re-frame.db :as rf-db]
|
||||
[tbd.ui.events :as events]
|
||||
[tbd.ui.test-util :as tu]
|
||||
[tbd.ui.tictactoe :as ttt]))
|
||||
|
||||
(use-fixtures :each tu/url-fixture)
|
||||
|
||||
(defn- board
|
||||
"A board from a string of 9 characters: x, o or anything else for an empty cell."
|
||||
[s]
|
||||
@@ -70,3 +73,16 @@
|
||||
(testing "a draw"
|
||||
(move! 0 1 2 4 3 5 7 6 8)
|
||||
(is (= :draw (:outcome (game)))))))
|
||||
|
||||
(deftest persistence-test
|
||||
(rf/dispatch-sync [::events/initialize])
|
||||
(move! 0 3)
|
||||
(testing "a reload finds the game where it was left"
|
||||
(rf/dispatch-sync [::events/initialize])
|
||||
(let [{:keys [board turn]} (:ttt @rf-db/app-db)]
|
||||
(is (= [:x nil nil :o] (subvec board 0 4)))
|
||||
(is (= :x turn))))
|
||||
(testing "a reset is also remembered"
|
||||
(rf/dispatch-sync [::events/ttt-reset])
|
||||
(rf/dispatch-sync [::events/initialize])
|
||||
(is (= ttt/new-board (:board (:ttt @rf-db/app-db))))))
|
||||
|
||||
@@ -483,7 +483,9 @@
|
||||
(defn- chat-messages
|
||||
"What the conversation shows, message by message."
|
||||
[]
|
||||
(mapv #(.-textContent %) (q-all "[role=log] > div:not([role=status]):not([data-tool])")))
|
||||
(mapv #(.-textContent %) (q-all "[role=log] > div:not([data-pending]):not([data-tool]):not([data-halted])")))
|
||||
|
||||
(defn- chat-status [] (:status (:chat @rf-db/app-db)))
|
||||
|
||||
(defn- chat-tool-lines
|
||||
"The tool calls and results the conversation shows, line by line."
|
||||
@@ -500,6 +502,16 @@
|
||||
[]
|
||||
(mapv #(.-textContent %) (tool-toggle-buttons)))
|
||||
|
||||
(defn- reasoning-toggle-buttons []
|
||||
(filterv #(re-find #"reasoning$" (.-textContent %)) (q-all "[role=dialog] button")))
|
||||
|
||||
(defn- reasoning-toggle [] (first (reasoning-toggle-buttons)))
|
||||
|
||||
(defn- reasoning-toggle-labels
|
||||
"The label of the button that shows or hides the reasoning, if the panel has one."
|
||||
[]
|
||||
(mapv #(.-textContent %) (reasoning-toggle-buttons)))
|
||||
|
||||
(deftest chat-widget-test
|
||||
;; A green square in the bottom left corner, opposite WebMCP's blue one; it opens the panel.
|
||||
(async done
|
||||
@@ -549,7 +561,9 @@
|
||||
(fn [_]
|
||||
(is (= "" (.-value (q "input[name=message]"))) "the input is emptied when sent")
|
||||
(is (nil? (q "[role=status]")) "no longer thinking")
|
||||
(is (= ["Clear" "×"] (mapv #(.-textContent %) (q-all "[role=dialog] > div:first-child button"))))
|
||||
(is (= ["Show reasoning" "Clear" "×"]
|
||||
(mapv #(.-textContent %) (q-all "[role=dialog] > div:first-child button")))
|
||||
"the fake server reasons before it echoes, so the toggle shows too")
|
||||
(type! (q "input[name=message]") "again")
|
||||
(tu/eventually (fn [] (= "again" (.-value (q "input[name=message]"))))))
|
||||
(fn [_]
|
||||
@@ -589,7 +603,7 @@
|
||||
(fn [_]
|
||||
(is (= "Thinking…" (text "[role=status]")))
|
||||
(is (= ["hello"] (chat-messages)))
|
||||
(is (true? (.-readOnly (q "input[name=message]"))))
|
||||
(is (false? (.-readOnly (q "input[name=message]"))) "typing ahead is still possible")
|
||||
(is (true? (.-disabled (q "[role=dialog] button[type=submit]"))))
|
||||
(is (nil? (first (filter #(= "Clear" (.-textContent %)) (q-all "[role=dialog] button"))))
|
||||
"can't start over mid-reply")
|
||||
@@ -622,7 +636,8 @@
|
||||
|
||||
(deftest chat-streaming-test
|
||||
;; The reply shows as it arrives: "Thinking…" until the model's first word (however long it
|
||||
;; reasons, which is never shown), then the reply growing piece by piece, and only at its end can
|
||||
;; reasons, which is not shown unless "Show reasoning" is turned on — see
|
||||
;; chat-reasoning-toggle-test), then the reply growing piece by piece, and only at its end can
|
||||
;; another message be sent.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-script [:pause
|
||||
@@ -645,22 +660,52 @@
|
||||
"still thinking while the model reasons")
|
||||
(is (not (str/includes? (panel-text) "Let me think.")) "and what it reasons is not shown")
|
||||
(is (= ["hi"] (chat-messages)) "it hasn't said anything")
|
||||
(is (true? (.-readOnly (q "input[name=message]"))) "and it isn't over")
|
||||
(is (= :loading (chat-status)) "and it isn't over")
|
||||
(is (false? (.-readOnly (q "input[name=message]"))) "but typing ahead still works")
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= ["hi" "Hello"] (chat-messages)))))
|
||||
(fn [_]
|
||||
(is (nil? (q "[role=status]")) "the model has begun to answer")
|
||||
(is (true? (.-readOnly (q "input[name=message]"))) "but it isn't over")
|
||||
(is (= :loading (chat-status)) "but it isn't over")
|
||||
(is (true? (.-disabled (q "[role=dialog] button[type=submit]"))))
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] (= ["hi" "Hello, world"] (chat-messages))))
|
||||
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]")))))
|
||||
#(tu/eventually (fn [] (= :idle (chat-status))))
|
||||
(fn [_]
|
||||
(is (not (str/includes? (panel-text) "Let me think.")) "the reasoning is not shown after it either")
|
||||
(is (nil? (q "[role=status]")))
|
||||
(is (nil? (q "[role=dialog] [role=alert]")))))
|
||||
done)))
|
||||
|
||||
(deftest chat-halt-test
|
||||
;; The stop button beside "Thinking…" halts the reply mid-thought, so the next message can steer
|
||||
;; it; what the stream would have sent after is never shown.
|
||||
(async done
|
||||
(swap! tu/server assoc :chat-scripts [[{:thinking "Let me "} :pause {:content "late"} {:done true}]])
|
||||
(tu/finish
|
||||
(tu/steps
|
||||
#(log-in-page! [])
|
||||
(fn [] (click! (q "button[aria-label=Chat]")))
|
||||
(fn [] (is (nil? (q "button[aria-label=Stop]")) "nothing to stop yet"))
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (q "button[aria-label=Stop]"))))
|
||||
(fn [stop]
|
||||
(is (re-matches #"Thinking(\.{1,3}|…)" (text "[role=status]")))
|
||||
(click! stop))
|
||||
#(tu/eventually (fn [] (q "[data-halted]")))
|
||||
(fn [_]
|
||||
(is (nil? (q "button[aria-label=Stop]")))
|
||||
(is (nil? (q "[role=status]")))
|
||||
(is (some? (q "[data-halted]")) "the reply is marked as stopped")
|
||||
(resume-stream!))
|
||||
#(tu/eventually (fn [] true))
|
||||
(fn [_]
|
||||
(is (not (str/includes? (panel-text) "late")) "what came after the halt is dropped")
|
||||
(is (= ["hi"] (chat-messages))))
|
||||
#(send-chat! "try this instead")
|
||||
#(tu/eventually (fn [] (= ["hi" "try this instead" "echo: try this instead"] (chat-messages)))))
|
||||
done)))
|
||||
|
||||
(deftest chat-thinking-animation-test
|
||||
;; While pieces of the reasoning are coming in "Thinking" has one to three dots; once they stop
|
||||
;; (for a moment) it is "Thinking…" again.
|
||||
@@ -687,8 +732,10 @@
|
||||
#(tu/eventually (fn [] (nil? (q "[role=status]")))))
|
||||
done)))
|
||||
|
||||
(deftest chat-reasoning-is-never-shown-test
|
||||
;; Neither while it comes nor in the finished conversation, in any element of the panel.
|
||||
(deftest chat-reasoning-toggle-test
|
||||
;; The reasoning behind a reply is never shown by default, in any element of the panel, while it
|
||||
;; comes or after; "Show reasoning" reveals it, whole (nothing cut off), for every reply that
|
||||
;; reasoned; "Hide reasoning" hides it again.
|
||||
(async done
|
||||
(let [thought "secret reasoning about the answer"]
|
||||
(swap! tu/server assoc :chat-script [{:thinking thought} {:content "Done."} {:done true}])
|
||||
@@ -699,7 +746,16 @@
|
||||
#(send-chat! "hi")
|
||||
#(tu/eventually (fn [] (= ["hi" "Done."] (chat-messages))))
|
||||
(fn [_]
|
||||
(is (not (str/includes? (panel-text) "secret")))))
|
||||
(is (not (str/includes? (panel-text) "secret")) "hidden by default")
|
||||
(is (= ["Show reasoning"] (reasoning-toggle-labels)))
|
||||
(click! (reasoning-toggle)))
|
||||
#(tu/eventually (fn [] (= ["Hide reasoning"] (reasoning-toggle-labels))))
|
||||
(fn [_]
|
||||
(is (str/includes? (panel-text) thought) "shown, whole, once expanded")
|
||||
(click! (reasoning-toggle)))
|
||||
#(tu/eventually (fn [] (= ["Show reasoning"] (reasoning-toggle-labels))))
|
||||
(fn [_]
|
||||
(is (not (str/includes? (panel-text) "secret")) "hidden again")))
|
||||
done))))
|
||||
|
||||
(defn- pointer!
|
||||
@@ -798,7 +854,7 @@
|
||||
(is (= 1000 @@top) "back near the end, it follows again")
|
||||
(reset! @top 200)
|
||||
(.dispatchEvent (q "[role=log]") (js/window.Event. "scroll")))
|
||||
#(tu/eventually (fn [] (false? (.-readOnly (q "input[name=message]")))))
|
||||
#(tu/eventually (fn [] (= :idle (chat-status))))
|
||||
#(send-chat! "again")
|
||||
#(tu/eventually (fn [] (and (:resume @tu/server) (= 1000 @@top))))
|
||||
(fn [_]
|
||||
@@ -855,7 +911,7 @@
|
||||
{:role "tool" :toolCallId "call_1" :content "{\"x\":2,\"y\":3,\"sum\":5}"}]
|
||||
(mapv #(dissoc % :id) (:messages (second (:chat-requests @tu/server)))))))
|
||||
(testing "and it is over: the panel takes messages again"
|
||||
(is (false? (.-readOnly (q "input[name=message]")))))
|
||||
(is (= :idle (chat-status))))
|
||||
(click! (tool-toggle)))
|
||||
#(tu/eventually (fn [] (= ["Collapse tool use"] (tool-toggle-labels))))
|
||||
(fn [_]
|
||||
@@ -919,7 +975,7 @@
|
||||
(is (= ["hi" "Hel"] (chat-messages)))
|
||||
(is (nil? (q "[role=status]")))
|
||||
(is (= "" (.-value (q "input[name=message]"))))
|
||||
(is (false? (.-readOnly (q "input[name=message]"))) "another message can be sent")))
|
||||
(is (= :idle (chat-status)) "another message can be sent")))
|
||||
done)))
|
||||
|
||||
(deftest chat-stream-cut-test
|
||||
|
||||
@@ -188,10 +188,6 @@
|
||||
(.then (fn [_]
|
||||
(is (= :ai-setup (page)) "reading changes nothing")
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
|
||||
(.then (fn [_]
|
||||
(is (= :tic-tac-toe (page)))
|
||||
(rf/dispatch-sync [::events/navigate :ai-setup])
|
||||
(call "new_tic_tac_toe_game" {})))
|
||||
(.then (fn [_]
|
||||
(is (= :tic-tac-toe (page)))
|
||||
(rf/dispatch-sync [::events/navigate :ai-setup])
|
||||
@@ -402,6 +398,11 @@
|
||||
(is (empty? (get-in @rf-db/app-db [:todos :items])))
|
||||
(done))))))
|
||||
|
||||
(deftest tic-tac-toe-tools-are-once-per-turn
|
||||
;; A move is the person's to ask for again, not the model's to repeat on its own: tbd.ui.events
|
||||
;; (see its once-per-turn tests) only lets the chatbot's turn call it once.
|
||||
(is (true? (:once-per-turn? (first (filter #(= "move_tic_tac_toe" (:name %)) webmcp/tools))))))
|
||||
|
||||
(deftest tic-tac-toe
|
||||
(open-page!)
|
||||
(async done
|
||||
@@ -411,9 +412,11 @@
|
||||
(is (= {:board (vec (repeat 9 nil)) :status "in_progress" :turn "x"} (json (:text r))))
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "x"})))
|
||||
(.then (fn [r]
|
||||
;; It pressed the cell, as a user would; there is nothing left to say (see
|
||||
;; It pressed the cell, as a user would; the result says the board it left (see
|
||||
;; provider-for's tic-tac-toe assertions for the shape it takes in the state).
|
||||
(is (= {:text "ok" :error? false} r))
|
||||
(is (false? (:error? r)))
|
||||
(is (= {:board [nil nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "o"}
|
||||
(json (:text r))))
|
||||
(is (= :x (get-in @rf-db/app-db [:ttt :board 4])))
|
||||
(is (= :o (get-in @rf-db/app-db [:ttt :turn])) "it is O's turn now")
|
||||
(call "move_tic_tac_toe" {:cell 4 :player "o"})))
|
||||
@@ -443,23 +446,25 @@
|
||||
(is (:error? r))
|
||||
(call "move_tic_tac_toe" {:cell 0 :player "o"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "ok" :error? false} r))
|
||||
(is (false? (:error? r)))
|
||||
(is (= {:board ["o" nil nil nil "x" nil nil nil nil] :status "in_progress" :turn "x"}
|
||||
(json (:text r))))
|
||||
(is (= :x (get-in @rf-db/app-db [:ttt :turn])))
|
||||
;; The person moves X to 3 and O to 1; the agent's X then completes the middle row.
|
||||
(rf/dispatch-sync [::events/ttt-move 3])
|
||||
(rf/dispatch-sync [::events/ttt-move 1])
|
||||
(call "move_tic_tac_toe" {:cell 5 :player "x"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "ok" :error? false} r))
|
||||
(is (false? (:error? r)))
|
||||
(is (= {:board ["o" "o" nil "x" "x" "x" nil nil nil]
|
||||
:status "won" :winner "x" :line [3 4 5]}
|
||||
(json (:text r))))
|
||||
(is (= [:o :o nil :x :x :x nil nil nil] (get-in @rf-db/app-db [:ttt :board])) "X won the middle row")
|
||||
(call "move_tic_tac_toe" {:cell 8 :player "o"})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "the game is over: start a new game" :error? true} r))
|
||||
(call "new_tic_tac_toe_game" {})))
|
||||
(.then (fn [r]
|
||||
(is (= {:text "ok" :error? false} r))
|
||||
(is (= (vec (repeat 9 nil)) (get-in @rf-db/app-db [:ttt :board])))
|
||||
(is (= :x (get-in @rf-db/app-db [:ttt :turn])))
|
||||
(is (= {:text "the game is over: the person starts a new one, with the page's own New game button"
|
||||
:error? true}
|
||||
r))
|
||||
(done))))))
|
||||
|
||||
;; --- State (tbd.ui.model-context's registry, filled from webmcp/state-providers) ---
|
||||
@@ -561,19 +566,16 @@
|
||||
|
||||
(deftest every-tool-the-prompts-name-exists
|
||||
(let [tool-names (set (map :name webmcp/tools))]
|
||||
(doseq [text [prompt/guide (prompt/tic-tac-toe "o") (prompt/task nil)]
|
||||
(doseq [text [prompt/guide prompt/tic-tac-toe (prompt/task nil)]
|
||||
tool-name (re-seq #"\b(?:get|move|new|list|set|create|delete)_[a-z_]+|\badd\{" text)]
|
||||
(is (contains? tool-names (str/replace tool-name "{" "")) (str tool-name)))))
|
||||
|
||||
(deftest tic-tac-toe-prompt
|
||||
(webmcp/register-prompts! fake-mcp)
|
||||
(testing "the side is the one asked for, and O by default"
|
||||
(is (re-find #"as X\." (:text (prompt-text "play_tic_tac_toe" {:side "x"}))))
|
||||
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" {:side "o"}))))
|
||||
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" nil))))
|
||||
(is (re-find #"as O\." (:text (prompt-text "play_tic_tac_toe" {:side "z"})))))
|
||||
(testing "it says to move on the agent's own turn only"
|
||||
(is (re-find #"never move for the other side" (:text (prompt-text "play_tic_tac_toe" nil))))))
|
||||
(testing "no side is assigned by the prompt; the tools and state carry the game"
|
||||
(is (= prompt/tic-tac-toe (:text (prompt-text "play_tic_tac_toe" nil))))
|
||||
(is (re-find #"get_tic_tac_toe and move_tic_tac_toe"
|
||||
(:text (prompt-text "play_tic_tac_toe" {:side "x"}))))))
|
||||
|
||||
(deftest registers-the-resources
|
||||
(is (identical? fake-mcp (webmcp/register-resources! fake-mcp)))
|
||||
|
||||
Reference in New Issue
Block a user