Amr Gharbeia
2ac87b626a
- Sidebar: permanent 42-col panel with 7 data panels (Gate Trace, Focus, Rules, Context gauge, Files, Cost, Protection); 4-window Croatoan layout at >=120 cols, toggle via Ctrl+X+B - Command palette: Ctrl+P overlay with fuzzy-filtered categorized items, keyboard navigation, Enter to execute; view-palette rendering - TrueColor themes: 4 new presets (nord, tokyonight, catppuccin, monokai) with 27 hex keys via theme-hex-to-rgb - Setup wizard: Ctrl+\ /setup 4-step overlay (provider, key, memory, save) writing .env with in-TUI rendering - Daemon enrichment: dispatcher block counts, cost session summary, modified files tracking, context usage percentage - Daemon fixes: fboundp guards for count-tokens/provider-token-cost, tool registry save/restore in safety tests, SELF_BUILD_MODE cleanup - 139 tests pass across all suites (0 failures)
90 KiB
90 KiB
Passepartout TUI — Controller
Controller
Event handlers + daemon I/O + main loop.
v0.8.0 — Sidebar Controller
The sidebar toggles via /sidebar command or Ctrl+X+B chord. The
Ctrl+X prefix sets :pending-ctrl-x (existing infrastructure from
v0.7.0); Ctrl+B on the next keystroke toggles :sidebar-visible and
sets dirty flags to force redraw.
The sidebar's visibility depends on terminal width. At ≥ 120 columns, the sidebar is a permanent fourth Croatoan window in a 4-column layout (sidebar | content). At < 120 columns, the layout stays 3-window (status | chat | input) and the sidebar renders as an overlay when toggled, drawn as an absolute-positioned window on top of the chat area.
The KEY_RESIZE handler in tui-main recomputes the layout: at ≥ 120
columns it creates the 4-window layout; at < 120 it drops back to
3-window and defers sidebar rendering to the overlay path.
v0.8.0 — Command Palette Controller
Ctrl+P opens the palette (sets :palette-visible to t, builds the
categorized item list via palette-items, resets :palette-filter
to empty string, sets :palette-selected-idx to 0). Subsequent
keypresses route through on-key-palette:
- Printable characters → append to filter, re-filter
:palette-itemsviapalette-filter, reset selection to 0 - Up/Down → decrement/increment
:palette-selected-idx, clamp to bounds - Enter → execute
palette-executeon selected item, dismiss palette - Esc → dismiss palette without action
- Ctrl+P again → toggle dismiss
The palette items are defined in palette-items as a function returning
a categorized list. Each item carries its :name (display), :desc
(tooltip), :shortcut (hint), and :action (a function of zero
arguments that sends the appropriate message or executes the command).
This design avoids duplicating command dispatch logic — palette actions
reuse the same send-daemon / add-msg / theme-switch calls that
on-key uses.
v0.8.0 — Setup Wizard Controller
The TUI setup wizard uses the same overlay window pattern as the palette.
wizard-steps returns the ordered list of configuration steps (provider
selection, API key entry, connection verification, preferences). The
current step index is stored in :wizard-step.
wizard-next runs the current step's :validate function on the input
buffer. On pass, it increments :wizard-step and clears the input buffer.
On fail, it sets :wizard-error with the error message and stays on the
current step. The last step writes to .env and calls /reconnect
to reload daemon configuration.
The wizard cancels on Esc (with confirmation) and resumes where left off if the user reopens it within the same session. State is per-session only — no disk persistence for incomplete wizards.
Contract
- (on-key ch): dispatches key presses: Enter triggers send (extracts
input buffer, pushes history, sends to daemon, clears buffer),
\\ + Enterinserts a literal newline (multi-line input),/helplists all commands,/eval <expr>evaluates a Lisp expression,/focus <proj>switches project context,/scope <scope>changes context scope,/unfocuspops context, Tab completes command names, Backspace deletes, arrows scroll chat and history. v0.7.0: Ctrl+U clears line, Ctrl+W deletes word, Ctrl+A/E home/end, Ctrl+L redraws, Ctrl+D quit on empty, Ctrl+X+E opens $EDITOR. Non-printable keys are ignored. - (on-daemon-msg msg): processes inbound daemon messages. Routes
text responses to chat display (:agent), handshake to system
messages, routes errors to log via
log-message. Extracts:gate-trace(attached to message),:rule-count, and:foveal-id(v0.4.0 differentiator) from daemon response and updates TUI state for status bar rendering. - (send-daemon msg): serializes and sends a message to the daemon over the framed TCP protocol.
- (tui-main): the main loop — connects to daemon, initializes Croatoan windows, optionally starts Swank REPL, runs render/input event loop at ~30fps.
- (on-key-sidebar key): v0.8.0 — handles sidebar-specific keybindings: Ctrl+X+B toggles sidebar, Esc dismisses overlay.
- (on-key-palette key): v0.8.0 — handles command palette keypresses: Up/Down navigate items, Enter executes selection, Esc dismisses palette, printable characters append to filter string.
- (passepartout.channel-tui::palette-items): v0.8.0 — returns categorized command list as
((:category "Session" :items ((:name ... :desc ... :shortcut ... :action ...) ...)) ...). - (palette-filter items query): v0.8.0 — returns items from the
categorized list whose
:nameor:desccontainsquery(case-insensitive substring match). Category headers preserved. - (palette-execute selected-item): v0.8.0 — calls the selected
item's
:actionfunction. Dismisses palette. - (wizard-steps): v0.8.0 — returns ordered list of setup step
definitions:
(:title <str> :prompt <str> :validate <fn> :next <fn>). - (wizard-next): v0.8.0 — runs current step's
:validateon input buffer. On pass, increments:wizard-stepand clears input. On fail, sets:wizard-error. Returns new step index.
Event Handlers
(in-package :passepartout.channel-tui)
(defun on-key (&rest args)
;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
;; backspace). Croatoan's code-key + key-name convert them to keywords
;; so the cond below can use eq.
(let* ((raw (car args))
(ch (if (and (integerp raw) (> raw 255))
(or (let* ((k (code-key raw))
(name (and k (key-name k))))
name)
;; Fallback for known ncurses codes when Croatoan
;; key tables aren't available (e.g. in tests)
(case raw
(343 :enter)
(259 :up)
(258 :down)
(260 :left)
(261 :right)
(339 :ppage)
(338 :npage)
(t raw)))
raw)))
(cond
;; v0.8.0: palette mode — handle palette keypresses first
((and (st :palette-visible) (or (eql ch 27) (eq ch :escape)))
(setf (st :palette-visible) nil)
(setf (st :dirty) (list t t nil)))
((and (st :palette-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
(let* ((filtered (palette-filter (st :palette-items) (st :palette-filter)))
(idx (st :palette-selected-idx))
(n 0)
(item nil))
(loop for group in filtered
for gitems = (getf group :items)
when (and (< n (length gitems)) (<= n idx (+ n (length gitems) -1)))
do (setf item (nth (- idx n) gitems))
(loop-finish)
do (incf n (length gitems)))
(passepartout.channel-tui::palette-execute item)
(setf (st :palette-visible) nil)
(setf (st :dirty) (list t t t))))
((and (st :palette-visible) (eq ch :up))
(setf (st :palette-selected-idx) (max 0 (1- (st :palette-selected-idx))))
(setf (st :dirty) (list nil t nil)))
((and (st :palette-visible) (eq ch :down))
(setf (st :palette-selected-idx) (min 999 (1+ (st :palette-selected-idx))))
(setf (st :dirty) (list nil t nil)))
((and (st :palette-visible) (integerp ch) (>= ch 32) (<= ch 126))
(let ((c (code-char ch)))
(setf (st :palette-filter) (concatenate 'string (or (st :palette-filter) "") (string c)))
(setf (st :palette-selected-idx) 0)
(setf (st :dirty) (list nil t nil))))
((and (st :palette-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8)))
(let ((f (st :palette-filter)))
(when (and f (> (length f) 0))
(setf (st :palette-filter) (subseq f 0 (1- (length f))))
(setf (st :palette-selected-idx) 0)
(setf (st :dirty) (list nil t nil)))))
;; v0.8.0: setup wizard — handle wizard keypresses
((and (st :wizard-visible) (or (eql ch 27) (eq ch :escape)))
(wizard-cancel))
((and (st :wizard-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
(wizard-next))
((and (st :wizard-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8)))
(let ((input (or (st :wizard-input) "")))
(when (> (length input) 0)
(setf (st :wizard-input) (subseq input 0 (1- (length input))))
(setf (st :wizard-error) nil)
(setf (st :dirty) (list nil t nil)))))
((and (st :wizard-visible) (eql ch 2)) ; Ctrl+B — back
(let ((step-idx (st :wizard-step)))
(when (> step-idx 0)
(setf (st :wizard-step) (1- step-idx)
(st :wizard-input) ""
(st :wizard-error) nil)
(setf (st :dirty) (list nil t nil)))))
((and (st :wizard-visible) (integerp ch) (>= ch 32) (<= ch 126))
(let ((c (code-char ch)))
(setf (st :wizard-input) (concatenate 'string (or (st :wizard-input) "") (string c)))
(setf (st :wizard-error) nil)
(setf (st :dirty) (list nil t nil))))
;; v0.7.1: Esc — interrupt streaming
((and (eql ch 27) (st :streaming-text))
(send-daemon (list :type :event :payload '(:action :cancel-stream)))
(when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :content)
(concatenate 'string
(getf (aref (st :messages) idx) :content)
" [interrupted]"))
(setf (getf (aref (st :messages) idx) :streaming) nil)
(setf (getf (aref (st :messages) idx) :time) (now))))
(setf (st :streaming-text) nil)
(setf (st :busy) nil)
(setf (st :dirty) (list t t nil)))
;; v0.7.2: Esc — exit search mode
((and (eql ch 27) (st :search-mode))
(setf (st :search-mode) nil
(st :search-matches) nil
(st :search-query) "")
(setf (st :dirty) (list nil t nil))
(add-msg :system "Search exited"))
;; v0.7.2: search mode — Up/Down navigate matches
((and (st :search-mode) (or (eql ch 259) (eq ch :up)))
(let* ((matches (st :search-matches))
(idx (st :search-match-idx))
(new-idx (max 0 (1- idx))))
(setf (st :search-match-idx) new-idx)
(when matches
(setf (st :scroll-offset) (nth new-idx matches))
(add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches)))
(setf (st :dirty) (list nil t nil)))))
((and (st :search-mode) (or (eql ch 258) (eq ch :down)))
(let* ((matches (st :search-matches))
(idx (st :search-match-idx))
(new-idx (min (1- (length matches)) (1+ idx))))
(setf (st :search-match-idx) new-idx)
(when matches
(setf (st :scroll-offset) (nth new-idx matches))
(add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches)))
(setf (st :dirty) (list nil t nil)))))
;; v0.7.2: search mode — Enter jumps to current match
((and (st :search-mode) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
(let ((matches (st :search-matches))
(idx (st :search-match-idx)))
(when (and matches (>= (length matches) (1+ idx)))
(setf (st :scroll-offset) (nth idx matches))
(setf (st :search-mode) nil
(st :search-matches) nil
(st :search-query) "")
(add-msg :system (format nil "Jumped to match ~d" (1+ idx)))
(setf (st :dirty) (list nil t nil)))))
;; v0.7.1: Tab on empty input — extract then open URL from agent message
((and (or (eql ch 9) (eq ch :tab))
(null (st :input-buffer)))
(if (st :url-buffer)
;; Already extracted — now open it
(progn
(add-msg :system (format nil "Opening ~a" (st :url-buffer)))
(setf (st :url-buffer) nil))
;; Extract URL from last agent message
(let ((url nil))
(loop for i from (1- (length (st :messages))) downto 0
for msg = (aref (st :messages) i)
for content = (getf msg :content)
for role = (getf msg :role)
while (eq role :agent)
when content
do (let ((pos (or (search "https://" content) (search "http://" content))))
(when pos
(let ((end (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab #\))))
content :start pos)
(length content))))
(setf url (subseq content pos end))
(return)))))
(if url
(progn
(setf (st :url-buffer) url)
(add-msg :system (format nil "Press Tab to open ~a" url))
(setf (st :dirty) (list t t nil)))
nil))))
;; v0.7.0: Ctrl key bindings
((eql ch 21) ; Ctrl+U — clear line
(setf (st :input-buffer) nil)
(setf (st :dirty) (list nil nil t)))
((eql ch 23) ; Ctrl+W — delete word backward
(let ((buf (st :input-buffer)))
(loop while (and buf (char= (first buf) #\Space)) do (pop buf))
(loop while (and buf (char/= (first buf) #\Space)) do (pop buf))
(setf (st :input-buffer) buf)
(setf (st :dirty) (list nil nil t))))
((eql ch 1) ; Ctrl+A — home
(setf (st :cursor-pos) 0))
((eql ch 5) ; Ctrl+E — end
(setf (st :cursor-pos) (length (st :input-buffer))))
((eql ch 12) ; Ctrl+L — redraw
(setf (st :dirty) (list t t t)))
((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
((eql ch 6) ; v0.7.2 Ctrl+F — message search
(add-msg :system "Use /search <query> to find messages"))
((eql ch 28) ; v0.8.0 Ctrl+\ — open setup wizard
(wizard-start)
(setf (st :dirty) (list t t nil)))
((eql ch 7) ; v0.7.2 Ctrl+G — toggle gate trace collapse
(let ((gate-idx nil))
(loop for i from (1- (length (st :messages))) downto 0
for m = (aref (st :messages) i)
when (and (getf m :gate-trace) (listp (getf m :gate-trace)))
do (setf gate-idx i) (loop-finish))
(if gate-idx
(let ((cg (st :collapsed-gates)))
(if (member gate-idx cg)
(setf (st :collapsed-gates) (remove gate-idx cg))
(push gate-idx (st :collapsed-gates)))
(add-msg :system (format nil "Gate trace ~a for msg ~a"
(if (member gate-idx (st :collapsed-gates)) "hidden" "shown")
gate-idx))
(setf (st :dirty) (list nil t nil)))
(add-msg :system "No gate trace to toggle"))))
((eql ch 24) ; Ctrl+X prefix
(setf (st :pending-ctrl-x) t))
((and (st :pending-ctrl-x) (eql ch 2)) ; Ctrl+X+B — toggle sidebar
(setf (st :pending-ctrl-x) nil)
(passepartout.channel-tui::sidebar-toggle)
(add-msg :system (if (st :sidebar-visible) "Sidebar shown (Ctrl+X+B to hide)" "Sidebar hidden")))
((eql ch 16) ; Ctrl+P — command palette
(setf (st :palette-visible) t
(st :palette-filter) ""
(st :palette-selected-idx) 0
(st :palette-items) (passepartout.channel-tui::palette-items))
(setf (st :dirty) (list t t nil)))
((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
((eql ch 6) ; v0.7.2 Ctrl+F — message search
(add-msg :system "Use /search <query> to find messages"))
((eql ch 7) ; v0.7.2 Ctrl+G — toggle gate trace collapse
(let ((gate-idx nil))
(loop for i from (1- (length (st :messages))) downto 0
for m = (aref (st :messages) i)
when (and (getf m :gate-trace) (listp (getf m :gate-trace)))
do (setf gate-idx i) (loop-finish))
(if gate-idx
(let ((cg (st :collapsed-gates)))
(if (member gate-idx cg)
(setf (st :collapsed-gates) (remove gate-idx cg))
(push gate-idx (st :collapsed-gates)))
(add-msg :system (format nil "Gate trace ~a for msg ~a"
(if (member gate-idx (st :collapsed-gates)) "hidden" "shown")
gate-idx))
(setf (st :dirty) (list nil t nil)))
(add-msg :system "No gate trace to toggle"))))
((eql ch 24) ; Ctrl+X prefix
(setf (st :pending-ctrl-x) t))
((and (st :pending-ctrl-x) (eql ch 5)) ; Ctrl+X+E — editor
(setf (st :pending-ctrl-x) nil)
(add-msg :system "Opening $EDITOR... save and exit to return.")
(setf (st :dirty) (list t t nil)))
((and (st :pending-ctrl-x) (not (eql ch 5))) ; cancel Ctrl+X
(setf (st :pending-ctrl-x) nil)
(on-key ch)
(return-from on-key nil))
;; Enter
((or (eq ch :enter) (eql ch 13) (eql ch 10)
(eql ch #\Newline) (eql ch #\Return))
;; Multi-line: if buffer ends with \, strip it and insert newline
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
(progn (pop (st :input-buffer))
(push #\Newline (st :input-buffer))
(setf (st :dirty) (list nil nil t)))
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
(when (> (length text) 0)
(push text (st :input-history))
(setf (st :input-hpos) 0)
(setf (st :scroll-offset) 0)
(cond
;; v0.7.2: undo/redo
((string-equal text "/undo")
(send-daemon (list :type :event :payload (list :sensor :undo)))
(add-msg :system "Undo: restoring memory to previous state"))
((string-equal text "/redo")
(send-daemon (list :type :event :payload (list :sensor :redo)))
(add-msg :system "Redo: restoring memory"))
;; /help command
((and (>= (length text) 9)
(string-equal (subseq text 0 9) "/approve "))
(let ((token (string-trim '(#\Space) (subseq text 9))))
(send-daemon (list :type :event :payload
(list :action :hitl-respond :token token :decision :approved)))
(add-msg :system (format nil "✓ Approved: ~a" token))
(resolve-hitl-panel :approved)))
((and (>= (length text) 6)
(string-equal (subseq text 0 6) "/deny "))
(let ((token (string-trim '(#\Space) (subseq text 6))))
(send-daemon (list :type :event :payload
(list :action :hitl-respond :token token :decision :denied)))
(add-msg :system (format nil "✗ Denied: ~a" token))
(resolve-hitl-panel :denied)))
;; /help command
;; /why command — show last gate trace
((string-equal text "/why")
(let ((msgs (st :messages))
(found nil))
(loop for i from (1- (length msgs)) downto 0
for m = (aref msgs i)
for gt = (getf m :gate-trace)
when (and gt (listp gt) (> (length gt) 0))
do (setf found t)
(dolist (entry gt)
(let* ((gate (getf entry :gate))
(result (getf entry :result))
(reason (getf entry :reason))
(msg (format nil "~a ~a~@[ — ~a~]"
(case result (:passed "[PASS]") (:blocked "[BLOCKED]") (:approval "[HITL]"))
(or gate "unknown")
reason)))
(add-msg :system msg)))
(loop-finish))
(unless found
(add-msg :system "No recent gate trace. Run a tool to see gate decisions."))))
;; /identity command — edit and reload identity file
((string-equal text "/identity")
(let* ((editor (or (uiop:getenv "EDITOR") "emacs"))
(path (merge-pathnames "memex/IDENTITY.org" (user-homedir-pathname))))
(add-msg :system (format nil "Opening ~a in ~a..." (namestring path) editor))
(uiop:run-program (list editor (namestring path)) :output t :error-output t)
(when (fboundp 'load-identity-file)
(funcall 'load-identity-file))
(add-msg :system "Identity reloaded")))
;; /audit command — Merkle provenance
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit "))
(if (fboundp 'audit-node)
(let* ((node-id (string-trim '(#\Space) (subseq text 7)))
(info (funcall 'audit-node node-id)))
(if info
(add-msg :system (format nil "Node ~a: type=~a scope=~a hash=~a"
(getf info :id) (getf info :type)
(getf info :scope)
(subseq (or (getf info :hash) "(none)") 0 16)))
(add-msg :system (format nil "Node ~a not found" node-id))))
(add-msg :system "Memory audit not available")))
;; /tags command — tag stack
;; /tags command — tag stack
((string-equal text "/tags")
(let ((cats passepartout::*tag-categories*))
(if cats
(dolist (entry cats)
(add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
;; /context command — context visibility
((string-equal text "/context")
(let* ((msg-count (length (st :messages)))
(focus (or (st :foveal-id) "none"))
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
(tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
(floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
50))
(log-tokens (min 4000 (floor (* msg-count 60) 4)))
(overhead-tokens 200)
(total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
(total-limit 8192)
(pct-used (floor (* 100 total-est) total-limit)))
(add-msg :system (format nil "Context: ~d msgs, focus=~a, ~d/~d tokens (~d%)"
msg-count focus total-est total-limit pct-used))
(add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens))
(add-msg :system (format nil "LOGS ~5d tokens" log-tokens))
(add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens))
(add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens))))
;; /context why <id> — debug node
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
(let ((node-id (string-trim '(#\Space) (subseq text 13))))
(if (fboundp 'passepartout::memory-object-get)
(let ((obj (funcall 'passepartout::memory-object-get node-id)))
(if obj
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
node-id
(passepartout::memory-object-type obj)
(passepartout::memory-object-scope obj)
(passepartout::memory-object-version obj)))
(add-msg :system (format nil "Node ~a not found" node-id))))
(add-msg :system "Memory not available"))))
;; /context dropped — pruned nodes
((string-equal text "/context dropped")
(add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)"))
;; /search command — message search
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
(let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8))))
(msgs (st :messages))
(total (length msgs))
(matches nil))
(loop for i from 0 below total
for m = (aref msgs i)
for content = (getf m :content)
when (search query (string-downcase content))
do (push i matches))
(setf matches (nreverse matches))
;; Enter search mode
(setf (st :search-mode) t
(st :search-query) query
(st :search-matches) matches
(st :search-match-idx) 0)
(if matches
(add-msg :system (format nil "Search: ~d matches for '~a' (1/~d) — Up/Down nav, Enter jump, Esc exit"
(length matches) query (length matches)))
(add-msg :system (format nil "0 matches for '~a'" query)))))
;; /rewind command — session rewind
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind "))
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
(n (handler-case (parse-integer n-str) (error () nil))))
(if n
(if (fboundp 'passepartout::rollback-memory)
(let* ((idx (1- n))
(snaps passepartout::*memory-snapshots*)
(ts (when (< idx (length snaps))
(getf (nth idx snaps) :timestamp))))
(funcall 'passepartout::rollback-memory idx)
(add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts)))
(add-msg :system "Memory rollback not available"))
(add-msg :system "Usage: /rewind <number>"))))
;; /sessions command — list snapshots
((string-equal text "/sessions")
(let ((snaps passepartout::*memory-snapshots*))
(if snaps
(let ((shown (subseq snaps 0 (min 10 (length snaps)))))
(add-msg :system (format nil "~d snapshots (showing ~d):"
(length snaps) (length shown)))
(loop for s in shown
for i from 0
for ts = (getf s :timestamp)
for data = (getf s :data)
for size = (hash-table-size data)
do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d"
(1+ i) size ts))))
(add-msg :system "No snapshots available"))))
;; /audit verify — memory integrity
((string-equal text "/audit verify")
(let ((count 0) (hashed 0))
(maphash (lambda (k v) (declare (ignore k))
(when v
(incf count)
(when (passepartout::memory-object-hash v)
(incf hashed))))
passepartout::*memory-store*)
(add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots"
count hashed
(length passepartout::*memory-snapshots*)))))
;; /resume <n> — resume from snapshot
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
(n (handler-case (parse-integer n-str) (error () nil))))
(if n
(if (fboundp 'passepartout::rollback-memory)
(progn (funcall 'passepartout::rollback-memory (1- n))
(add-msg :system (format nil "Resumed from snapshot ~d" n)))
(add-msg :system "Memory rollback not available"))
(add-msg :system "Usage: /resume <number>"))))
;; /help <topic> — search user manual
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help "))
(let* ((topic (string-trim '(#\Space) (subseq text 6)))
(results (self-help-lookup topic)))
(dolist (entry results)
(add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(unless results
(add-msg :system (format nil "Topic '~a' not found in USER_MANUAL.org" topic)))))
((string-equal text "/help")
(add-msg :system "/undo Undo last operation")
(add-msg :system "/redo Redo last operation")
(add-msg :system "/why Show last gate trace")
(add-msg :system "/identity Edit IDENTITY.org")
(add-msg :system "/tags List tag severities")
(add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/search <q> Search messages")
(add-msg :system "/context Show context summary")
(add-msg :system "/eval <expr> Evaluate Lisp")
(add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/sessions Show snapshots")
(add-msg :system "/resume <n> Resume from snapshot")
(add-msg :system "/focus <proj> Set project context")
(add-msg :system "/theme Show theme")
(add-msg :system "/help [topic] Show this help")
(add-msg :system "\\ + Enter Multi-line input")
(add-msg :system "Ctrl+G Toggle gate trace"))
;; /setup command — open wizard
((string-equal text "/setup")
(wizard-start)
(add-msg :system "Setup wizard opened (Ctrl+W)")
(setf (st :dirty) (list t t nil)))
;; /theme command
((string-equal text "/theme")
(add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
*tui-theme-current-name*
(getf *tui-theme* :user)
(getf *tui-theme* :agent)
(getf *tui-theme* :system)
(getf *tui-theme* :input)))
(add-msg :system "Presets: /theme dark | light | solarized | gruvbox"))
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/theme "))
(let ((name (string-trim '(#\Space) (subseq text 7))))
(if (theme-switch name)
(add-msg :system (format nil "Theme switched to ~a" name))
(add-msg :system (format nil "Unknown theme '~a'. Try: dark light solarized gruvbox" name)))))
;; /eval command
((and (>= (length text) 6)
(string-equal (subseq text 0 6) "/eval "))
(handler-case
(let* ((*read-eval* t)
(*package* (find-package :passepartout.channel-tui))
(r (eval (read-from-string (subseq text 6)))))
(add-msg :system (format nil "=> ~s" r)))
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
;; /focus <project> — set project context
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/focus "))
(let ((project (string-trim '(#\Space) (subseq text 7))))
(if (and (fboundp 'focus-project) (> (length project) 0))
(progn (funcall 'focus-project project nil)
(add-msg :system (format nil "Focused on project: ~a" project)))
(add-msg :system "Usage: /focus <project-name>"))))
;; /scope <scope> — change context scope
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/scope "))
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
(cond
((and (fboundp 'focus-session) (string-equal scope-str "session"))
(funcall 'focus-session)
(add-msg :system "Scope: session"))
((and (fboundp 'focus-project) (string-equal scope-str "project"))
(funcall 'focus-project nil nil)
(add-msg :system "Scope: project"))
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
(funcall 'focus-memex)
(add-msg :system "Scope: memex"))
(t (add-msg :system "Usage: /scope memex|session|project")))))
;; /unfocus — pop context
((and (>= (length text) 8)
(string-equal (subseq text 0 8) "/unfocus"))
(if (fboundp 'unfocus)
(progn (funcall 'unfocus)
(add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded")))
;; /quit — save history and exit
((or (string-equal text "/quit") (string-equal text "/q"))
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
(user-homedir-pathname))))
(uiop:ensure-all-directories-exist (list hist-file))
(with-open-file (out hist-file :direction :output
:if-exists :supersede :if-does-not-exist :create)
(dolist (entry (reverse (st :input-history)))
(write-line entry out))))
(add-msg :system "* Goodbye *")
(send-daemon (list :type :event :payload '(:action :quit)))
(setf (st :running) nil))
;; /reconnect — re-establish daemon connection
((string-equal text "/reconnect")
(disconnect-daemon)
(connect-daemon))
;; Normal message
(t
(add-msg :user text)
(setf (st :busy) t)
(send-daemon (list :type :event
:payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil)
(setf (st :cursor-pos) 0)
(setf (st :dirty) (list t t t))))))
;; Tab — command completion (v0.7.0: extended with subcommand + file paths)
((or (eql ch 9) (eq ch :tab))
(let ((text (input-string)))
(cond
;; @ prefix — file path completion
((and (>= (length text) 1) (eql (char text 0) #\@))
(let* ((partial (subseq text 1))
(memex (or (uiop:getenv "MEMEX_DIR")
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
(proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex))
(files (handler-case (append (uiop:directory-files proj "**/*.org")
(uiop:directory-files proj "**/*.lisp"))
(error () nil)))
(names (mapcar (lambda (f) (subseq (namestring f) (1+ (length (namestring proj))))) files))
(match (find-if (lambda (n) (and (>= (length n) (length partial))
(string-equal n partial :end2 (length partial))))
names)))
(when match
(setf (st :input-buffer) (reverse (coerce (concatenate 'string "@" match) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; /theme subcommand
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme "))
(let* ((partial (string-trim '(#\Space) (subseq text 7)))
(names '("dark" "light" "solarized" "gruvbox"))
(match (if (string= partial "") (first names)
(find partial names :test #'string-equal))))
(when match
(setf (st :input-buffer) (reverse (coerce (concatenate 'string "/theme " match) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; /focus subcommand
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus "))
(let* ((partial (string-trim '(#\Space) (subseq text 7)))
(memex (or (uiop:getenv "MEMEX_DIR")
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
(proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex))
(dirs (handler-case (mapcar (lambda (d) (car (last (pathname-directory d))))
(uiop:subdirectories proj))
(error () nil)))
(match (if (string= partial "") (first dirs)
(find-if (lambda (d) (and (>= (length d) (length partial))
(string-equal d partial :end2 (length partial))))
dirs))))
(when match
(setf (st :input-buffer) (reverse (coerce (concatenate 'string "/focus " match) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; Command prefix /
((and (> (length text) 1) (eql (char text 0) #\/))
(let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit"))
(match (find text cmds :test
(lambda (in cmd) (and (>= (length cmd) (length in))
(string-equal cmd in :end1 (length in)))))))
(when match
(setf (st :input-buffer) (reverse (coerce match 'list)))
(when (member match '("/eval" "/focus" "/scope") :test #'string=)
(push #\Space (st :input-buffer)))
(setf (st :dirty) (list nil nil t))))))))
;; Backspace
((or (eq ch :backspace) (eql ch 127) (eql ch 8)
(eql ch #\Backspace))
(input-delete-char)
(setf (st :dirty) (list nil nil t)))
;; Left arrow
((or (eq ch :left) (eql ch 260))
(when (> (or (st :cursor-pos) 0) 0)
(decf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Right arrow
((or (eq ch :right) (eql ch 261))
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
(incf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Up arrow
((or (eq ch :up) (eql ch 259))
(let* ((h (st :input-history)) (p (st :input-hpos)))
(when (and h (< p (1- (length h))))
(incf (st :input-hpos))
(setf (st :input-buffer)
(reverse (coerce (nth (st :input-hpos) h) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; Down arrow
((or (eq ch :down) (eql ch 258))
(when (> (st :input-hpos) 0)
(decf (st :input-hpos))
(let ((h (st :input-history)))
(setf (st :input-buffer)
(if (and h (< (st :input-hpos) (length h)))
(reverse (coerce (nth (st :input-hpos) h) 'list))
nil))
(setf (st :dirty) (list nil nil t)))))
;; PageUp
((or (eq ch :ppage) (eql ch 339))
(let ((page-size (max 10 (floor (length (st :messages)) 3))))
(setf (st :scroll-offset) (+ (st :scroll-offset) page-size)))
(setf (st :dirty) (list nil t nil)))
;; PageDown
((or (eq ch :npage) (eql ch 338))
(let ((page-size (max 10 (floor (length (st :messages)) 3))))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) page-size))))
(setf (st :dirty) (list nil t nil)))
;; Printable
(t
(let ((chr (typecase ch
(character ch)
(integer (code-char ch))
(t nil))))
(when (and chr (graphic-char-p chr))
(input-insert-char chr)
(setf (st :dirty) (list nil nil t))))))))
;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun palette-items ()
"Returns categorized command list for the palette."
(let ((items nil))
(push (list :category "Session" :items
(list (list :name "/focus" :desc "Set project context" :shortcut "C-o"
:action (lambda () (add-msg :system "/focus <project>")))
(list :name "/scope" :desc "Change context scope"
:action (lambda () (add-msg :system "/scope memex|session|project")))
(list :name "/unfocus" :desc "Pop context stack"
:action (lambda () (send-daemon (list :type :event :payload (list :sensor :unfocus)))))
(list :name "/search" :desc "Search messages" :shortcut "C-f"
:action (lambda () (add-msg :system "Use /search <query> to find messages")))))
items)
(push (list :category "Agent" :items
(list (list :name "/why" :desc "Show last gate trace" :shortcut "C-g"
:action (lambda () (add-msg :system "Gate trace: use /why")))
(list :name "/audit" :desc "Inspect memory object"
:action (lambda () (add-msg :system "/audit <node-id>")))
(list :name "/context" :desc "Show context budget"
:action (lambda () (add-msg :system "/context")))))
items)
(push (list :category "View" :items
(list (list :name "/theme" :desc "Switch color theme"
:action (lambda () (add-msg :system "Presets: dark light solarized gruvbox nord tokyonight catppuccin monokai")))
(list :name "/sidebar" :desc "Toggle sidebar" :shortcut "C-x C-b"
:action #'sidebar-toggle)
(list :name "/help" :desc "Show all commands"
:action (lambda () (add-msg :system "/focus /scope /unfocus /search /why /audit /context /help /theme /sidebar")))))
items)
(push (list :category "System" :items
(list (list :name "/setup" :desc "Run setup wizard" :shortcut "C-\\"
:action (lambda () (wizard-start)
(add-msg :system "Setup wizard opened")
(setf (st :dirty) (list t t nil))))
(list :name "/eval" :desc "Evaluate Lisp expression"
:action (lambda () (add-msg :system "/eval <expr>")))
(list :name "/reconnect" :desc "Reconnect to daemon"
:action (lambda () (disconnect-daemon) (connect-daemon)))
(list :name "/quit" :desc "Save history and exit" :shortcut "C-d"
:action (lambda () (add-msg :system "* Goodbye *")
(send-daemon (list :type :event :payload '(:action :quit)))
(setf (st :running) nil)))))
items)
(nreverse items)))
(defun palette-execute (selected-item)
"Execute the selected palette item's action."
(when (and selected-item (getf selected-item :action))
(funcall (getf selected-item :action))))
(defun wizard-steps ()
"Returns the ordered list of setup wizard steps."
(list
(list :title "Provider Selection"
:prompt "LLM provider (openai, anthropic, ollama, openrouter, deepseek, groq):"
:validate (lambda (input)
(let ((provider (string-downcase (string-trim '(#\Space) input))))
(if (member provider '("openai" "anthropic" "ollama" "openrouter" "deepseek" "groq")
:test #'string=)
(progn (setf (st :wizard-provider) provider) nil)
(format nil "Unknown provider: ~a" input)))))
(list :title "API Key"
:prompt (format nil "API key for ~a:" (or (st :wizard-provider) "provider"))
:validate (lambda (input)
(let ((key (string-trim '(#\Space) input)))
(if (> (length key) 4)
(progn (setf (st :wizard-api-key) key) nil)
"Key too short — enter a valid API key"))))
(list :title "Memory"
:prompt "Max memory entries? (default: 1000, Enter to accept):"
:validate (lambda (input)
(let ((val (string-trim '(#\Space) input)))
(if (or (string= val "") (string= val "1000"))
(progn (setf (st :wizard-memory) "1000") nil)
(if (every #'digit-char-p val)
(progn (setf (st :wizard-memory) val) nil)
"Enter a number")))))
(list :title "Review & Save"
:prompt "Save configuration? (yes/no):"
:validate (lambda (input)
(let ((val (string-downcase (string-trim '(#\Space) input))))
(cond
((string= val "yes")
(wizard-write-config)
nil)
((string= val "no")
(setf (st :wizard-visible) nil
(st :wizard-step) 0
(st :wizard-error) nil)
(add-msg :system "Wizard cancelled — run /setup to restart")
nil)
(t "Type 'yes' to save or 'no' to cancel")))))))
(defun wizard-start ()
"Open the setup wizard at step 0."
(setf (st :wizard-visible) t
(st :wizard-step) 0
(st :wizard-input) ""
(st :wizard-error) nil
(st :wizard-provider) nil
(st :wizard-api-key) nil
(st :wizard-memory) nil))
(defun wizard-next ()
"Validate current step input; advance on success, show error on failure."
(let ((steps (wizard-steps))
(step-idx (st :wizard-step)))
(when (< step-idx (length steps))
(let* ((step (nth step-idx steps))
(validate-fn (getf step :validate))
(error-msg (funcall validate-fn (or (st :wizard-input) ""))))
(if error-msg
(setf (st :wizard-error) error-msg
(st :dirty) (list nil t nil))
(if (= step-idx (1- (length steps)))
(progn
(setf (st :wizard-visible) nil
(st :wizard-step) 0
(st :wizard-error) nil)
(add-msg :system "Configuration saved. Run /reconnect to reload."))
(setf (st :wizard-step) (1+ step-idx)
(st :wizard-input) ""
(st :wizard-error) nil
(st :dirty) (list nil t nil))))))))
(defun wizard-cancel ()
"Dismiss the wizard, preserving state for resumption."
(setf (st :wizard-visible) nil
(st :dirty) (list t t nil)))
(defun wizard-write-config ()
"Write collected wizard data to .env and notify."
(let ((provider (st :wizard-provider))
(api-key (st :wizard-api-key))
(memory (or (st :wizard-memory) "1000"))
(env-path (merge-pathnames ".env" (merge-pathnames "memex/" (user-homedir-pathname)))))
(handler-case
(progn
(uiop:ensure-all-directories-exist (list env-path))
(with-open-file (out env-path :direction :output :if-exists :supersede :if-does-not-exist :create)
(format out "# Passepartout configuration (generated by setup wizard)~%")
(format out "PROVIDER_CASCADE=~a~%" provider)
(format out "~:@(~a~)_API_KEY=~a~%" provider api-key)
(format out "MEMORY_MAX_ENTRIES=~a~%" memory)
(format out "DAEMON_PORT=9105~%")))
(error (c)
(setf (st :wizard-error) (format nil "Failed to write config: ~a" c)))))
(setf (st :wizard-visible) nil
(st :wizard-step) 0
(st :wizard-error) nil)
(add-msg :system (format nil "Configuration saved to memex/.env (~a). Run /reconnect to reload." provider)))
(defun resolve-hitl-panel (decision)
"Mark the most recent HITL panel message as resolved with DECISION."
(loop for i from (1- (length (st :messages))) downto 0
for m = (aref (st :messages) i)
when (and (getf m :panel) (not (getf m :panel-resolved)))
do (setf (getf m :panel-resolved) decision)
(setf (aref (st :messages) i) m)
(setf (st :dirty) (list nil t nil))
(loop-finish)))
(defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload))
(text (getf payload :text))
(msg-type (getf msg :type))
(action (getf payload :action))
(level (getf msg :level))
(sensor (getf payload :sensor))
(gate-trace (getf msg :gate-trace))
(rule-count (getf payload :rule-count))
(foveal-id (getf payload :foveal-id)))
;; v0.7.2: HITL approval-required panel
(when (eq level :approval-required)
(let* ((hitl-msg (or (getf payload :message)
(getf payload :text)
"HITL approval required"))
(hitl-action (getf (getf payload :action) :payload))
(tool-name (getf hitl-action :tool))
(explanation (or tool-name "unknown action")))
(add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx"
hitl-msg explanation)
:panel t))
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
;; v0.7.1: streaming chunk
(when (eq msg-type :stream-chunk)
(cond
((string= text "")
;; Final chunk: stamp time, clear streaming
(when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :streaming) nil)
(setf (getf (aref (st :messages) idx) :time) (now))))
(setf (st :streaming-text) nil)
(setf (st :busy) nil)
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
((null (st :streaming-text))
;; First chunk: add new streaming message
(setf (st :streaming-text) "")
(setf (st :busy) nil)
(add-msg :agent text)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :streaming) t))
(setf (st :streaming-text) text)
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
(t
;; Subsequent chunk: append
(let* ((new-text (concatenate 'string (st :streaming-text) text))
(idx (1- (length (st :messages)))))
(setf (st :streaming-text) new-text)
(setf (getf (aref (st :messages) idx) :content) new-text)
(setf (st :dirty) (list nil t nil)))
(return-from on-daemon-msg nil))))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))));; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun resolve-hitl-panel (decision)
"Mark the most recent HITL panel message as resolved with DECISION."
(loop for i from (1- (length (st :messages))) downto 0
for m = (aref (st :messages) i)
when (and (getf m :panel) (not (getf m :panel-resolved)))
do (setf (getf m :panel-resolved) decision)
(setf (aref (st :messages) i) m)
(setf (st :dirty) (list nil t nil))
(loop-finish)))
;; v0.7.2 — self-help-lookup: read USER_MANUAL.org and find matching sections
(defun self-help-lookup (topic)
"Search USER_MANUAL.org for headlines matching TOPIC, return content previews."
(let* ((manual-path (merge-pathnames "projects/passepartout/docs/USER_MANUAL.org"
(merge-pathnames "memex/" (user-homedir-pathname))))
(results nil))
(handler-case
(let* ((text (uiop:read-file-string manual-path))
(lines (uiop:split-string text :separator '(#\Newline)))
(in-section nil)
(section-content nil))
(dolist (line lines)
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
(cond
;; New headline
((and (>= (length trimmed) 2) (eql (char trimmed 0) #\*))
;; Flush previous section if in one
(when (and in-section section-content)
(push (cons in-section (string-trim '(#\Space #\Newline)
(format nil "~{~a~^ ~}" (reverse section-content))))
results))
;; Check if this headline matches topic
(let ((title (string-trim '(#\Space #\*) trimmed)))
(if (search topic title :test #'char-equal)
(setf in-section title
section-content nil)
(setf in-section nil
section-content nil))))
;; Content line in matching section
(in-section
(when (and (> (length trimmed) 0)
(not (eql (char trimmed 0) #\#)))
(push trimmed section-content))))))
;; Flush last section
(when (and in-section section-content)
(push (cons in-section (string-trim '(#\Space #\Newline)
(format nil "~{~a~^ ~}" (reverse section-content))))
results))
(nreverse results))
(error (c) (list (cons "Error" (format nil "Cannot read manual: ~a" c)))))))
(defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload))
(text (getf payload :text))
(msg-type (getf msg :type))
(action (getf payload :action))
(level (getf msg :level))
(sensor (getf payload :sensor))
(gate-trace (getf msg :gate-trace))
(rule-count (getf payload :rule-count))
(foveal-id (getf payload :foveal-id)))
;; v0.7.2: HITL approval-required panel
(when (eq level :approval-required)
(let* ((hitl-msg (or (getf payload :message)
(getf payload :text)
"HITL approval required"))
(hitl-action (getf (getf payload :action) :payload))
(tool-name (getf hitl-action :tool))
(explanation (or tool-name "unknown action")))
(add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx"
hitl-msg explanation)
:panel t))
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
;; v0.7.1: streaming chunk
(when (eq msg-type :stream-chunk)
(cond
((string= text "")
;; Final chunk: stamp time, clear streaming
(when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :streaming) nil)
(setf (getf (aref (st :messages) idx) :time) (now))))
(setf (st :streaming-text) nil)
(setf (st :busy) nil)
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
((null (st :streaming-text))
;; First chunk: add new streaming message
(setf (st :streaming-text) "")
(setf (st :busy) nil)
(add-msg :agent text)
(let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :streaming) t))
(setf (st :streaming-text) text)
(setf (st :dirty) (list nil t nil))
(return-from on-daemon-msg nil))
(t
;; Subsequent chunk: append
(let* ((new-text (concatenate 'string (st :streaming-text) text))
(idx (1- (length (st :messages)))))
(setf (st :streaming-text) new-text)
(setf (getf (aref (st :messages) idx) :content) new-text)
(setf (st :dirty) (list nil t nil)))
(return-from on-daemon-msg nil))))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
;; v0.8.0: sidebar enrichment fields
(when (getf payload :block-counts) (setf (st :block-counts) (getf payload :block-counts)))
(when (getf payload :context-usage) (setf (st :context-usage) (getf payload :context-usage)))
(when (getf payload :modified-files) (setf (st :modified-files) (getf payload :modified-files)))
(when (getf payload :session-cost) (setf (st :session-cost) (getf payload :session-cost)))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))))Daemon Communication
(defun send-daemon (msg)
(let ((s (st :stream)))
(when (and s (open-stream-p s))
(handler-case
(progn
(format s "~a" (frame-message msg))
(finish-output s))
(error () nil)))))
(defun recv-daemon (s)
(handler-case
(let* ((hdr (make-string 6)) (n 0))
(loop while (< n 6)
do (let ((ch (read-char s nil)))
(unless ch (return-from recv-daemon nil))
(setf (char hdr n) ch) (incf n)))
(let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
(buf (make-string (or len 0))))
(when (and len (> len 0))
(loop for i from 0 below len
do (let ((ch (read-char s nil)))
(unless ch (return-from recv-daemon nil))
(setf (char buf i) ch)))
(let ((*read-eval* nil))
(read-from-string buf)))))
(error () nil)))
(defun reader-loop (s)
(let ((consecutive-nils 0))
(loop while (and (st :running) (open-stream-p s))
do (let ((msg (recv-daemon s)))
(if msg
(progn (queue-event (list :type :daemon :payload msg))
(setf consecutive-nils 0))
(progn (sleep 0.5)
(incf consecutive-nils)
(when (> consecutive-nils 10)
(queue-event (list :type :disconnected))
(return))))))))
(defun load-history ()
"Load input history from disk on TUI startup."
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
(user-homedir-pathname))))
(when (uiop:file-exists-p hist-file)
(with-open-file (in hist-file :direction :input)
(loop for line = (read-line in nil nil)
while line
do (push line (st :input-history))))
(setf (st :input-history) (nreverse (st :input-history))))))Connection
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
(add-msg :system "* Connecting to daemon... *")
(loop for attempt from 1 to 3
for backoff = 0 then 3
do (sleep backoff)
(handler-case
(let ((s (usocket:socket-connect host port :timeout 5)))
(setf (st :stream) (usocket:socket-stream s)
(st :connected) t)
(bt:make-thread (lambda () (reader-loop (st :stream)))
:name "tui-reader")
(add-msg :system (format nil "* Connected v~a *" "0.5.0"))
(return-from connect-daemon t))
(usocket:connection-refused-error (c)
(when (= attempt 3)
(add-msg :system (format nil "* No daemon on port ~a after ~a attempts *"
port attempt))))
(error (c)
(add-msg :system (format nil "* Connection attempt ~a failed: ~a *"
attempt c))
(when (= attempt 3)
(add-msg :system "* TIP: run 'passepartout daemon' first *")))))
nil)
(defun disconnect-daemon ()
(when (st :stream)
(ignore-errors (close (st :stream)))
(setf (st :stream) nil (st :connected) nil)
(add-msg :system "* Disconnected *")))Main Loop
(defun tui-main ()
(init-state)
(load-history)
(theme-load)
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(let* ((h (or (height scr) 24))
(w (or (width scr) 80))
(sidebar-w (when (>= w 120)
(make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44))))
(content-w (if sidebar-w (- w 44) (- w 2)))
(ch (- h 5))
(sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
(cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
(iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
(swank-port (or (ignore-errors
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
4006)))
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
(st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
(connect-daemon)
(when (> swank-port 0)
(handler-case
(progn
(ql:quickload :swank :silent t)
(funcall (find-symbol "CREATE-SERVER" "SWANK")
:port swank-port :dont-close t)
(add-msg :system
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
(error ()
(add-msg :system "* Swank unavailable *"))))
(flet ((recreate-windows (scr-width scr-height)
(let* ((new-w scr-width)
(new-h scr-height)
(has-sidebar (and (>= new-w 120) (st :sidebar-visible)))
(new-sidebar-w (when has-sidebar
(make-instance 'window :height (- new-h 5)
:width 42 :y 3 :x (- new-w 44))))
(new-content-w (if new-sidebar-w (- new-w 44) (- new-w 2)))
(new-ch (- new-h 5)))
(setq sw (make-instance 'window :height 3 :width new-content-w :y 0 :x 1)
ch new-ch
cw (make-instance 'window :height new-ch :width new-content-w :y 3 :x 1)
iw (make-instance 'window :height 1 :width new-content-w :y (- new-h 1) :x 1)
sidebar-w new-sidebar-w
w new-w
h new-h)
(setf (function-keys-enabled-p iw) t
(input-blocking iw) nil
(st :dirty) (list t t t)
(st :sw) sw (st :cw) cw (st :iw) iw))))
(let ((initial-sidebar (and (>= w 120) (st :sidebar-visible))))
(when initial-sidebar
(view-sidebar (or sidebar-w
(make-instance 'window :height (- h 5) :width 42
:y 3 :x (- w 44))))
(refresh (or sidebar-w
(make-instance 'window :height (- h 5) :width 42
:y 3 :x (- w 44))))))
(redraw sw cw ch iw)
(when sidebar-w
(view-sidebar sidebar-w)
(refresh sidebar-w))
(when (st :palette-visible)
(let* ((pw (min 56 (floor (* w 0.7))))
(ph (min 18 (floor (* h 0.6))))
(px (floor (- w pw) 2))
(py (floor (- h ph) 2))
(palette-win (make-instance 'window :height ph :width pw :y py :x px)))
(view-palette palette-win)
(refresh palette-win)
(close palette-win)))
(when (st :wizard-visible)
(let* ((ww 60) (wh 14)
(wx (floor (- w ww) 2))
(wy (floor (- h wh) 2))
(wizard-win (make-instance 'window :height wh :width ww :y wy :x wx)))
(view-wizard wizard-win)
(refresh wizard-win)
(close wizard-win)))
(refresh scr)
(loop while (st :running) do
(dolist (ev (drain-queue))
(cond
((eq (getf ev :type) :daemon)
(on-daemon-msg (getf ev :payload)))
((eq (getf ev :type) :disconnected)
(setf (st :connected) nil
(st :busy) nil)
(add-msg :system "* Connection lost — type /reconnect to retry *"))))
(let ((ch (get-char iw)))
(cond
((or (not ch) (equal ch -1)) nil)
((eql ch 410)
(recreate-windows (or (width scr) 80) (or (height scr) 24))
(redraw sw cw ch iw)
(refresh scr))
(t (on-key ch))))
(redraw sw cw ch iw)
(when sidebar-w
(view-sidebar sidebar-w)
(refresh sidebar-w))
;; Recreate windows when sidebar visibility or terminal width changes
(let ((sidebar-wanted (and (st :sidebar-visible) (>= w 120))))
(when (or (and sidebar-wanted (not sidebar-w))
(and (not sidebar-wanted) sidebar-w))
(recreate-windows w h)
(redraw sw cw ch iw)))
(when (st :palette-visible)
(let* ((pw (min 56 (floor (* w 0.7))))
(ph (min 18 (floor (* h 0.6))))
(px (floor (- w pw) 2))
(py (floor (- h ph) 2))
(palette-win (make-instance 'window :height ph :width pw :y py :x px)))
(view-palette palette-win)
(refresh palette-win)
(close palette-win)))
(when (st :wizard-visible)
(let* ((ww 60) (wh 14)
(wx (floor (- w ww) 2))
(wy (floor (- h wh) 2))
(wizard-win (make-instance 'window :height wh :width ww :y wy :x wx)))
(view-wizard wizard-win)
(refresh wizard-win)
(close wizard-win)))
(refresh scr)
(sleep 0.03))
(disconnect-daemon)))))Test Suite
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-tui-tests
(:use :cl :passepartout :passepartout.channel-tui)
(:export #:tui-suite))
(in-package :passepartout-tui-tests)
(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling")
(fiveam:in-suite tui-suite)
(fiveam:test test-init-state
"Contract model.1: init-state returns fresh state plist with required keys."
(init-state)
(fiveam:is (eq t (st :running)))
(fiveam:is (eq :chat (st :mode)))
(fiveam:is (eq nil (st :connected)))
(fiveam:is (eq nil (st :stream)))
(fiveam:is (zerop (length (st :messages))))
(fiveam:is (eq 0 (st :scroll-offset)))
(fiveam:is (eq nil (st :busy))))
(fiveam:test test-add-msg
"Contract model.2: add-msg appends a message with role, content, and time."
(init-state)
(add-msg :user "hello")
(let* ((msgs (st :messages))
(msg (aref msgs 0)))
(fiveam:is (eq :user (getf msg :role)))
(fiveam:is (string= "hello" (getf msg :content)))
(fiveam:is (stringp (getf msg :time)))
(fiveam:is (= 5 (length (getf msg :time))))))
(fiveam:test test-add-msg-dirty-flag
"Contract model.2: add-msg sets dirty flags for status and chat."
(init-state)
(setf (st :dirty) (list nil nil nil))
(add-msg :system "boot")
(let ((dirty (st :dirty)))
(fiveam:is (eq t (first dirty)))
(fiveam:is (eq t (second dirty)))
(fiveam:is (eq nil (third dirty)))))
(fiveam:test test-queue-event-roundtrip
"Contract model.3: queue-event + drain-queue preserves events in order."
(init-state)
(queue-event '(:type :key :payload (:ch 13)))
(queue-event '(:type :daemon :payload (:text "hi")))
(let ((evs (drain-queue)))
(fiveam:is (= 2 (length evs)))
(fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs)))
(fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs)))
(fiveam:is (null (drain-queue)))))
(fiveam:test test-on-key-enter-sends-user-message
"Contract 1: on-key with Enter extracts input, adds user message, clears buffer."
(init-state)
;; Simulate typing "test"
(dolist (ch '(#\t #\e #\s #\t))
(on-key (char-code ch)))
(fiveam:is (string= "test" (input-string)))
;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled
(on-key 343)
;; Input buffer should be cleared
(fiveam:is (string= "" (input-string)))
;; A user message should be in the message list
(let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 1))
(let ((last (aref msgs 0)))
(fiveam:is (eq :user (getf last :role)))
(fiveam:is (string= "test" (getf last :content))))))
(fiveam:test test-on-key-eval-command
"Contract 1: on-key handles /eval command and displays result."
(init-state)
;; Type "/eval (+ 1 2)"
(dolist (ch (coerce "/eval (+ 1 2)" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 1))
(let ((last-msg (aref msgs 0)))
(fiveam:is (eq :system (getf last-msg :role)))
(fiveam:is (search "=> 3" (getf last-msg :content))))))
(fiveam:test test-on-key-backspace
"Contract 1: on-key with Backspace removes last character from buffer."
(init-state)
(dolist (ch '(#\a #\b #\c))
(on-key (char-code ch)))
(fiveam:is (string= "abc" (input-string)))
;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled
(on-key 263)
(fiveam:is (string= "ab" (input-string))))
(fiveam:test test-on-key-focus-command
"Contract 1: /focus command parses project name."
(init-state)
(dolist (ch (coerce "/focus myapp" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((msg (aref (st :messages) 0)))
(fiveam:is (eq :system (getf msg :role)))))
(fiveam:test test-on-key-scope-command
"Contract 1: /scope command with valid argument."
(init-state)
(dolist (ch (coerce "/scope memex" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((msg (aref (st :messages) 0)))
(fiveam:is (eq :system (getf msg :role)))))
(fiveam:test test-on-key-unfocus-command
"Contract 1: /unfocus command dispatches correctly."
(init-state)
(dolist (ch (coerce "/unfocus" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((msg (aref (st :messages) 0)))
(fiveam:is (eq :system (getf msg :role)))))
(fiveam:test test-on-key-tab-completion
"Contract 1: Tab completes / commands when input starts with /."
(init-state)
(dolist (ch (coerce "/ev" 'list))
(on-key (char-code ch)))
(on-key 9)
(fiveam:is (string= "/eval " (input-string))))
(fiveam:test test-on-key-tab-no-slash
"Contract 1: Tab does nothing when input doesn't start with /."
(init-state)
(dolist (ch (coerce "hello" 'list))
(on-key (char-code ch)))
(on-key 9)
(fiveam:is (string= "hello" (input-string))))
(fiveam:test test-on-key-multiline
"Contract 1: \\ + Enter inserts newline instead of sending."
(init-state)
(dolist (ch (coerce "line1" 'list))
(on-key (char-code ch)))
(on-key (char-code #\\))
(on-key 343)
(fiveam:is (search "line1" (input-string)))
(fiveam:is (search (string #\Newline) (input-string))))
(fiveam:test test-on-key-help
"Contract 1: /help displays command list."
(init-state)
(dolist (ch (coerce "/help" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 3))
(fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs))))
(fiveam:test test-activity-indicator
"Contract model: :busy flag is set on send and cleared on agent response."
(init-state)
(fiveam:is (eq nil (st :busy)))
;; Simulate sending a normal message (sets busy)
(dolist (ch (coerce "hello" 'list))
(on-key (char-code ch)))
(on-key 343)
(fiveam:is (eq t (st :busy)))
;; Simulate receiving an agent response (clears busy)
(on-daemon-msg '(:type :event :payload (:text "hi back")))
(fiveam:is (eq nil (st :busy))))
(fiveam:test test-theme
"Contract view: *tui-theme* provides color mappings."
(fiveam:is (eq :green (getf *tui-theme* :user)))
(fiveam:is (eq :white (getf *tui-theme* :agent)))
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
(fiveam:is (eq :white (theme-color :unknown-role))))
(fiveam:test test-on-key-ctrl-u-clears
"Contract 1/v0.7.0: Ctrl+U clears the input buffer."
(init-state)
(dolist (ch '(#\h #\i)) (on-key (char-code ch)))
(on-key 21) ; Ctrl+U
(fiveam:is (string= "" (input-string))))
(fiveam:test test-on-key-ctrl-l-redraws
"Contract 1/v0.7.0: Ctrl+L sets all dirty flags."
(init-state)
(setf (st :dirty) (list nil nil nil))
(on-key 12) ; Ctrl+L
(let ((d (st :dirty)))
(fiveam:is (eq t (first d)))
(fiveam:is (eq t (second d)))))
(fiveam:test test-scroll-notify
"Contract/v0.7.0: add-msg sets scroll-notify when scrolled up."
(init-state)
(setf (st :scroll-at-bottom) nil)
(add-msg :agent "hi")
(fiveam:is (eq t (st :scroll-notify)))
(setf (st :scroll-at-bottom) t (st :scroll-notify) nil)
(add-msg :agent "hi2")
(fiveam:is (eq nil (st :scroll-notify))))
(fiveam:test test-tab-subcommand
"Contract/v0.7.0: Tab completes subcommand for /theme."
(init-state)
(dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch)))
(on-key 9)
(fiveam:is (search "dark" (input-string) :test #'char-equal)))
;; ── v0.7.1 Streaming ──
(fiveam:test test-stream-chunk-appends
"Contract/v0.7.1: stream-chunk frame appends to last message."
(init-state)
(on-daemon-msg '(:type :stream-chunk :payload (:text "Hello")))
(on-daemon-msg '(:type :stream-chunk :payload (:text " world")))
(let ((msgs (st :messages)))
(fiveam:is (= 1 (length msgs)))
(let ((msg (aref msgs 0)))
(fiveam:is (eq :agent (getf msg :role)))
(fiveam:is (string= "Hello world" (getf msg :content)))
(fiveam:is (eq t (getf msg :streaming))))))
(fiveam:test test-stream-chunk-final
"Contract/v0.7.1: final empty chunk stamps timestamp and clears streaming flag."
(init-state)
(on-daemon-msg '(:type :stream-chunk :payload (:text "Hi")))
(on-daemon-msg '(:type :stream-chunk :payload (:text "")))
(let ((msg (aref (st :messages) 0)))
(fiveam:is (stringp (getf msg :time)))
(fiveam:is (string= "Hi" (getf msg :content)))
(fiveam:is (null (st :streaming-text)))))
(fiveam:test test-stream-interrupt
"Contract/v0.7.1: Esc during streaming appends [interrupted] and finalizes."
(init-state)
(on-daemon-msg '(:type :stream-chunk :payload (:text "partial")))
(on-key 27)
(let ((msg (aref (st :messages) 0)))
(fiveam:is (stringp (getf msg :time)))
(fiveam:is (search "[interrupted]" (getf msg :content)))
(fiveam:is (null (st :streaming-text)))
(fiveam:is (null (st :busy)))))
(fiveam:test test-stream-check-skip
"Contract/v0.7.1: Esc without active streaming does nothing."
(init-state)
(on-key 27)
(fiveam:is (null (st :streaming-text)))
(fiveam:is (= 0 (length (st :messages)))))
(fiveam:test test-tab-open-url
"Contract/v0.7.1: Tab on empty input with URL message extracts URL."
(init-state)
(add-msg :agent "visit https://example.com for info")
(on-key 9)
(fiveam:is (string= "https://example.com" (st :url-buffer))))
;; ── v0.7.2 HITL Panels ──
(fiveam:test test-hitl-panel-in-on-daemon-msg
"Contract v0.7.2: approval-required messages render as HITL panels."
(init-state)
(on-daemon-msg '(:type :EVENT :level :approval-required
:payload (:sensor :approval-required
:action (:TYPE :REQUEST :PAYLOAD (:TOOL "shell"))
:message "rm -rf blocked")))
(let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role)))
(fiveam:is (getf m :panel))
(fiveam:is (search "rm -rf" (getf m :content)))))
(fiveam:test test-hitl-panel-after-approve
"Contract v0.7.2: /approve adds confirmation and marks panel resolved."
(init-state)
(on-daemon-msg '(:type :EVENT :level :approval-required
:payload (:sensor :approval-required :message "test")))
(dolist (ch (coerce "/approve HITL-test" 'list))
(on-key (char-code ch)))
(on-key 13)
;; Panel message (index 0) should be marked resolved
(let ((m (aref (st :messages) 0)))
(fiveam:is (getf m :panel))
(fiveam:is (eq :approved (getf m :panel-resolved))))
;; Last message should be the approval confirmation
(let ((m (aref (st :messages) (1- (length (st :messages))))))
(fiveam:is (search "Approved" (getf m :content)))))
(fiveam:test test-hitl-panel-after-deny
"Contract v0.7.2: /deny marks panel as denied."
(init-state)
(on-daemon-msg '(:type :EVENT :level :approval-required
:payload (:sensor :approval-required :message "blocked")))
(dolist (ch (coerce "/deny HITL-deny" 'list))
(on-key (char-code ch)))
(on-key 13)
(let ((m (aref (st :messages) 0)))
(fiveam:is (getf m :panel))
(fiveam:is (eq :denied (getf m :panel-resolved)))))
(fiveam:test test-hitl-approve-parsed
"Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text."
(init-state)
(dolist (ch (coerce "/approve HITL-abcd" 'list))
(on-key (char-code ch)))
(on-key 343)
;; Should add a system message confirming approval, not a user message
(let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 1))
(let ((m (aref msgs 0)))
(fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Approved" (getf m :content))))))
(fiveam:test test-hitl-deny-parsed
"Contract v0.7.2: /deny HITL-xxxx sends structured denial."
(init-state)
(dolist (ch (coerce "/deny HITL-xyz" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Denied" (getf m :content)))))
;; ── v0.7.2 Undo/Redo ──
(fiveam:test test-undo-command
"Contract v0.7.2: /undo sends undo event."
(init-state)
(dolist (ch (coerce "/undo" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Undo" (getf m :content)))))
(fiveam:test test-redo-command
"Contract v0.7.2: /redo sends redo event."
(init-state)
(dolist (ch (coerce "/redo" 'list))
(on-key (char-code ch)))
(on-key 343)
(let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Redo" (getf m :content)))))
;; ── v0.7.2 Self-help ──
(fiveam:test test-why-command
"Contract v0.7.2: /why shows gate trace from last message."
(init-state)
(add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf")))
(dolist (ch (coerce "/why" 'list))
(on-key (char-code ch)))
(on-key 13)
(let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs)))))
(fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "[BLOCKED]" (getf m :content)))
(fiveam:is (search "shell" (getf m :content)))))
(fiveam:test test-why-no-trace
"Contract v0.7.2: /why with no gate trace shows fallback message."
(init-state)
(dolist (ch (coerce "/why" 'list))
(on-key (char-code ch)))
(on-key 13)
(let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs)))))
(fiveam:is (search "No recent" (getf m :content)))))
;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ──
(fiveam:test test-ctrlg-toggle-gate-trace
"Contract v0.7.2: Ctrl+G toggles gate-trace collapse state."
(init-state)
(add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed)))
(on-key 7) ;; Ctrl+G — first press hides
(let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs)))))
(fiveam:is (search "hidden" (getf m :content))))
(on-key 7) ;; second press shows
(let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs)))))
(fiveam:is (search "shown" (getf m :content)))))
(fiveam:test test-ctrlg-no-gate-trace
"Contract v0.7.2: Ctrl+G with no gate trace shows fallback."
(init-state)
(on-key 7)
(let ((m (aref (st :messages) 0)))
(fiveam:is (search "No gate trace" (getf m :content)))))
;; ── v0.7.2 Message Search Mode ──
(fiveam:test test-search-mode-activate
"Contract v0.7.2: /search enters search mode."
(init-state)
(add-msg :agent "hello world")
(add-msg :agent "goodbye")
(dolist (ch (coerce "/search hello" 'list))
(on-key (char-code ch)))
(on-key 13)
(fiveam:is (eq t (st :search-mode)))
(fiveam:is (string= "hello" (st :search-query)))
(fiveam:is (= 1 (length (st :search-matches)))))
(fiveam:test test-search-mode-escape-exits
"Contract v0.7.2: Escape exits search mode."
(init-state)
(add-msg :agent "test")
(dolist (ch (coerce "/search test" 'list))
(on-key (char-code ch)))
(on-key 13)
(fiveam:is (eq t (st :search-mode)))
(on-key 27) ;; Escape
(fiveam:is (null (st :search-mode))))
(fiveam:test test-search-mode-up-down-nav
"Contract v0.7.2: Up/Down navigates between search matches."
(init-state)
(add-msg :agent "aaa hello bbb")
(add-msg :agent "ccc hello ddd")
(add-msg :agent "no match here")
(dolist (ch (coerce "/search hello" 'list))
(on-key (char-code ch)))
(on-key 13)
(fiveam:is (= 0 (st :search-match-idx)))
(on-key 258) ;; Down
(fiveam:is (= 1 (st :search-match-idx)))
(on-key 259) ;; Up
(fiveam:is (= 0 (st :search-match-idx)))
(on-key 259) ;; Up (clamped)
(fiveam:is (= 0 (st :search-match-idx))))
(fiveam:test test-context-sections
"Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS."
(init-state)
(add-msg :agent "hello world")
(dolist (ch (coerce "/context" 'list))
(on-key (char-code ch)))
(on-key 13)
(let ((msgs (st :messages)))
(fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs))
(fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs))
(fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs))))
(fiveam:test test-help-topic-lookup
"Contract v0.7.2: /help <topic> reads and searches USER_MANUAL.org."
(init-state)
(dolist (ch (coerce "/help configuration" 'list))
(on-key (char-code ch)))
(on-key 13)
(let ((msgs (st :messages)))
(fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs))))
(fiveam:test test-pads-page-up
"Contract v0.7.2: PageUp scrolls by page size (> 5 lines)."
(init-state)
(dotimes (i 30) (add-msg :system (format nil "msg ~d" i)))
(setf (st :scroll-offset) 0)
(on-key :ppage)
(fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines"))
(fiveam:test test-pads-page-down-clamp
"Contract v0.7.2: PageDown clamps to 0."
(init-state)
(dotimes (i 5) (add-msg :system (format nil "msg ~d" i)))
(setf (st :scroll-offset) 3)
(on-key :npage)
(fiveam:is (= 0 (st :scroll-offset))))v0.8.0 Tests — Sidebar, Palette, Theme, Wizard
(in-package :passepartout-tui-tests)
(fiveam:test test-theme-hex-to-rgb
"Contract 4: theme-hex-to-rgb parses #RRGGBB to integer triple."
(multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "#5E81AC")
(fiveam:is (= 94 r))
(fiveam:is (= 129 g))
(fiveam:is (= 172 b))))
(fiveam:test test-theme-hex-to-rgb-invalid
"Contract 4: theme-hex-to-rgb returns white for invalid input."
(multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "not-a-color")
(fiveam:is (= 255 r))
(fiveam:is (= 255 g))
(fiveam:is (= 255 b))))
(fiveam:test test-sidebar-toggle
"Contract 7: sidebar-toggle flips :sidebar-visible and sets dirty flags."
(init-state)
(setf (st :dirty) (list nil nil nil))
(passepartout.channel-tui::sidebar-toggle)
(fiveam:is (eq t (st :sidebar-visible)))
(fiveam:is (eq t (first (st :dirty))))
(fiveam:is (eq t (second (st :dirty)))))
(fiveam:test test-ctrl-x-b-toggles-sidebar
"Contract 5: Ctrl+X then Ctrl+B toggles sidebar."
(init-state)
(on-key 24) ; Ctrl+X
(fiveam:is (eq t (st :pending-ctrl-x)))
(on-key 2) ; Ctrl+B
(fiveam:is (eq t (st :sidebar-visible))))
(fiveam:test test-ctrl-p-opens-palette
"Contract 6: Ctrl+P opens command palette."
(init-state)
(on-key 16) ; Ctrl+P
(fiveam:is (eq t (st :palette-visible)))
(fiveam:is (not (null (st :palette-items))))
(fiveam:is (= 0 (st :palette-selected-idx))))
(fiveam:test test-palette-escape-dismisses
"Contract 6: Esc dismisses palette."
(init-state)
(setf (st :palette-visible) t)
(on-key 27) ; Esc
(fiveam:is (null (st :palette-visible))))
(fiveam:test test-palette-enter-executes
"Contract 9: Enter executes selected item and dismisses palette."
(init-state)
(setf (st :palette-visible) t
(st :palette-selected-idx) 0
(st :palette-items) (passepartout.channel-tui::palette-items))
(on-key (char-code #\/))
(on-key (char-code #\t))
(fiveam:is (string= "/t" (st :palette-filter))))
(fiveam:test test-palette-items-has-categories
"Contract 7: palette-items returns categorized list with at least Session and View."
(init-state)
(let ((items (passepartout.channel-tui::palette-items)))
(fiveam:is (listp items))
(fiveam:is (find "Session" items :key (lambda (g) (getf g :category)) :test #'string=))
(fiveam:is (find "View" items :key (lambda (g) (getf g :category)) :test #'string=))))
;; ── v0.8.0 Setup Wizard ──
(fiveam:test test-wizard-steps-count
"Contract v0.8.0: wizard-steps returns 4 steps."
(let ((steps (passepartout.channel-tui::wizard-steps)))
(fiveam:is (= 4 (length steps)))))
(fiveam:test test-wizard-start-sets-visible
"Contract v0.8.0: wizard-start sets wizard-visible and resets state."
(init-state)
(passepartout.channel-tui::wizard-start)
(fiveam:is (eq t (st :wizard-visible)))
(fiveam:is (= 0 (st :wizard-step)))
(fiveam:is (string= "" (st :wizard-input))))
(fiveam:test test-wizard-cancel-hides
"Contract v0.8.0: wizard-cancel hides the wizard."
(init-state)
(setf (st :wizard-visible) t)
(passepartout.channel-tui::wizard-cancel)
(fiveam:is (null (st :wizard-visible))))
(fiveam:test test-wizard-next-valid-advances
"Contract v0.8.0: valid input advances to next step."
(init-state)
(passepartout.channel-tui::wizard-start)
(setf (st :wizard-input) "openai")
(passepartout.channel-tui::wizard-next)
(fiveam:is (= 1 (st :wizard-step)))
(fiveam:is (string= "openai" (st :wizard-provider))))
(fiveam:test test-wizard-next-invalid-shows-error
"Contract v0.8.0: invalid input shows error and stays on current step."
(init-state)
(passepartout.channel-tui::wizard-start)
(setf (st :wizard-input) "invalid-provider")
(passepartout.channel-tui::wizard-next)
(fiveam:is (= 0 (st :wizard-step)))
(fiveam:is (not (null (st :wizard-error)))))
(fiveam:test test-ctrl-backslash-opens-wizard
"Contract v0.8.0: Ctrl+\\ opens the setup wizard."
(init-state)
(on-key 28) ; Ctrl+\
(fiveam:is (eq t (st :wizard-visible))))