+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