Amr Gharbeia
b1aafc56b2
Discovered and fixed an extra close parenthesis on the hint bar's last draw-text line that caused a compile error.
23 KiB
23 KiB
Passepartout TUI — View
View
| Pure render functions. Each takes the cl-tty backend and current state. |
State is read via (st :key) — no mutation here. |
Contract
- (view-status fb w h): no-op. Status bar is a clean black line.
- (view-chat fb w h): renders scrolled chat messages. User messages get amber left border (│), agent messages no border, streaming agent gets grey left border. Gate traces/tool calls use ╎ prefix.
- (view-input fb w h): renders expanding light grey input box, multi-line word-wrapped prompt, Emacs-style reverse-video cursor, right-aligned lowercase hint at h-2.
- (redraw fb w h): wraps view-status/chat/input in begin-sync/end-sync, dispatches per dirty flags, fills global :bg first.
- (char-width ch): returns terminal column width of character CH. ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8. Used by word-wrap for accurate line counting (v0.7.0).
- (sidebar-visible-p w): returns T if sidebar should show given width W and current :sidebar-mode (:auto >120, :visible always, :hidden never).
Status Bar
The status bar, as of v0.4.0, renders Passepartout's three differentiator visualizations — data only available because of the deterministic gate architecture:
- Rule counter (
Rules:N): the number of pending HITL actions from the Dispatcher's*hitl-pending*hash table. The user watches this tick up as they teach the agent their preferences through approve/deny decisions. - Focus map (
[Focus: <id>]): the foveal focus from the daemon's signal context. Shows the user what the agent is currently looking at. - Gate trace (not rendered in status bar — attached to individual
messages via
:gate-tracefield for future collapsible rendering per message).
All three enrichments cost 0 LLM tokens — they are daemon-state queries that the TUI actuator attaches to the response plist before transmission.
(in-package :passepartout.channel-tui)
(defun sidebar-visible-p (w)
"Compute whether sidebar should be shown given terminal width W
and current sidebar mode (:auto/:visible/:hidden)."
(let ((mode (st :sidebar-mode)))
(or (eq mode :visible)
(and (eq mode :auto) (> w 120)))))
(defun view-status (fb w h)
(declare (ignore fb w h))
;; Status bar is now a clean black line — blends with global :bg.
;; No clock, no dot, no text. Everything clean.
)
(defun input-panel-top (chat-w h)
"Compute the top row of the input panel based on current input buffer."
(let* ((hpad 2)
(inner-w (- chat-w (* 2 hpad)))
(prompt-w (- inner-w 2))
(text (input-string))
(lines (cl-tty.box:word-wrap text prompt-w))
(n-lines (max 1 (length lines)))
(panel-rows (max 4 (+ n-lines 2))))
(- h 4 panel-rows -1)))
;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown
(defun search-highlight (content query)
"Wrap occurrences of QUERY in CONTENT with **bold** markers."
(let ((lower-content (string-downcase content))
(lower-query (string-downcase query))
(result "") (pos 0))
(when (and query (> (length query) 0))
(loop
(let ((found (search lower-query lower-content :start2 pos)))
(unless found (return))
(setf result (concatenate 'string result
(subseq content pos found)
"**" (subseq content found (+ found (length query))) "**"))
(setf pos (+ found (length query)))))
(setf result (concatenate 'string result (subseq content pos)))
(if (string= result "") content result))))
(defun view-chat (fb w h)
(let* ((w (or (and (numberp w) (> w 0) w) 80))
(h (or (and (numberp h) (> h 0) h) 24))
(hpad 2)
(sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
(chat-w (- w sidebar-w))
(msgs (st :messages)) (total (length msgs))
(panel-top (input-panel-top chat-w h))
(max-lines (max 0 panel-top)) (is-search (st :search-mode))
(bordered-w (- chat-w (* 2 hpad) 2))
(unbordered-w (- chat-w (* 2 hpad)))
(y 0))
(when is-search
(let* ((matches (st :search-matches)) (idx (st :search-match-idx))
(query (st :search-query))
(hdr (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit"
(length matches) query (1+ idx) (length matches))))
(cl-tty.backend:draw-text fb hpad y hdr (theme-color :accent) nil)
(incf y) (decf max-lines)))
(let ((msg-lines (make-array total)) (msg-heights (make-array total)))
(dotimes (i total)
(let* ((msg (aref msgs i)) (role (getf msg :role))
(content (getf msg :content))
(cs (if is-search (search-highlight content (st :search-query)) content))
(pairs nil)
(think-bg (theme-color :thinking-bg))
(sym-bdr (theme-color :symbolic-border))
(agent-bdr (theme-color :agent-border))
(user-bdr (theme-color :user-border))
(user-fg (theme-color :user-fg))
(agent-fg (theme-color :agent-fg))
(system-fg (theme-color :system)))
(case role
(:user
(dolist (l (cl-tty.box:word-wrap cs bordered-w))
(push (list "│" user-bdr l user-fg) pairs)))
( :agent
(let* ((streaming (getf msg :streaming))
(think-rect (if streaming think-bg nil))
(bdr (if streaming nil agent-bdr))
(bstr (if streaming nil "│"))
(wrap-w (if streaming unbordered-w bordered-w))
(nodes (cl-tty.markdown:parse-blocks cs))
(raw-body (or (and nodes (cl-tty.markdown:render-md nodes)) (list "")))
(body (mapcan (lambda (l) (cl-tty.box:word-wrap l wrap-w)) raw-body)))
(dolist (l body)
(push (list bstr bdr l agent-fg think-rect) pairs))))
(t (dolist (l (cl-tty.box:word-wrap cs unbordered-w))
(push (list nil nil l system-fg) pairs))))
;; Gate trace
(let ((gt (getf msg :gate-trace)))
(when (and gt (eq role :agent))
(if (member i (st :collapsed-gates))
(push (list "│" sym-bdr (format nil "Gate trace: ~a gates" (length gt)) sym-bdr) pairs)
(dolist (entry (passepartout::gate-trace-lines gt))
(let ((ec (theme-color (getf (cdr entry) :fgcolor))))
(dolist (l (cl-tty.box:word-wrap (car entry) bordered-w))
(push (list "│" sym-bdr l ec) pairs)))))))
;; Tool calls
(let ((tc (getf msg :tool-calls)))
(when tc
(if (member i (st :collapsed-tools))
(let* ((n (or (getf (first tc) :name) "tool"))
(d (or (getf (first tc) :duration) 0.0)))
(push (list "│" (theme-color :tool-done) (format nil "~a … ~,1fs" n d) (theme-color :tool-done)) pairs))
(dolist (call tc)
(let* ((name (or (getf call :name) "tool"))
(dur (or (getf call :duration) 0.0))
(st (getf call :status))
(out (getf call :output))
(bc (theme-color
(cond ((eq st :running) :tool-running)
((eq st :error) :tool-error)
(t :tool-done))))
(pfx (cond ((eq st :error) "✗") ((eq st :running) "●") (t "✓")))
(ol (when out (cl-tty.box:word-wrap out bordered-w))))
(push (list "│" bc (format nil "~a ~a ~,1fs" pfx name dur) bc) pairs)
(dolist (l ol)
(push (list "│" bc l bc) pairs)))))))
(setf (aref msg-lines i) (nreverse pairs))
(setf (aref msg-heights i) (length pairs))))
(let ((msg-count 0) (lines-remaining max-lines))
(loop for i from (1- total) downto 0
while (> lines-remaining 0)
do (let ((mh (aref msg-heights i))
(spacer (if (< i (1- total)) 1 0)))
(if (<= (+ mh spacer) lines-remaining)
(progn (decf lines-remaining (+ mh spacer)) (incf msg-count))
(setf lines-remaining 0))))
(let* ((scroll-skip (st :scroll-offset))
(start (max 0 (- total msg-count scroll-skip))))
(loop for i from start below total while (< y panel-top)
do (let ((pairs (aref msg-lines i)))
(dolist (pair pairs)
(when (>= y panel-top) (return))
(destructuring-bind (bstr bcolor tstr tcolor &optional rect-bg) pair
(when rect-bg
(cl-tty.backend:draw-rect fb 0 y 1 1 :bg rect-bg))
(let ((has-border (and bstr (> (length bstr) 0))))
(when has-border
(cl-tty.backend:draw-text fb hpad y bstr bcolor nil))
(cl-tty.backend:draw-text fb (+ hpad (if has-border 2 0)) y tstr tcolor nil)))
(incf y))
;; spacer between message blocks
(when (< i (1- total))
(incf y)))))))))Input Line
(defun view-input (fb w h)
(let* ((w (or (and (numberp w) (> w 0) w) 80))
(h (or (and (numberp h) (> h 0) h) 24))
(hpad 2)
(sidebar-w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
(chat-w (- w sidebar-w))
(inner-w (- chat-w (* 2 hpad)))
(prompt-w (- inner-w 2))
(text (input-string))
(pos (or (st :cursor-pos) 0))
(lines (cl-tty.box:word-wrap text prompt-w))
(n-lines (max 1 (length lines)))
(panel-rows (max 4 (+ n-lines 2)))
(panel-top (input-panel-top chat-w h))
(bg-i (theme-color :bg-input))
(input-fg (theme-color :input-fg))
(hint-fg (theme-color :hint)))
;; Fill input panel: panel-top to h-4, indented by hpad
(cl-tty.backend:draw-rect fb hpad panel-top inner-w panel-rows :bg bg-i)
;; Speaker lines for all input rows
(dotimes (r panel-rows)
(cl-tty.backend:draw-text fb hpad (+ panel-top r) "│" (theme-color :input-prompt) nil))
;; Draw each wrapped input line
(let ((accum 0) (cl 0) (cc 0))
(dotimes (i n-lines)
(let* ((line (nth i lines))
(row (+ panel-top 1 i))
(len (length line)))
(when (>= row (- h 4)) (return))
(cl-tty.backend:draw-text fb (+ hpad 2) row line input-fg nil)
(when (and (>= pos accum) (<= pos (+ accum len)))
(setf cl i cc (- pos accum)))
(incf accum (1+ len))))
(setf (st :cursor-line) cl (st :cursor-col) cc))
;; Hint bar at h-2: F:/MCP: on left, token gauge + keybindings on right
(let* ((focal (or (st :foveal-id) "-"))
(focal-str (format nil "F:~a" focal))
(mcp-str (format nil "MCP:~d" (or (st :mcp-count) 0)))
(left-str (format nil "~a ~a" focal-str mcp-str))
(msg-count (max 1 (length (st :messages))))
(ctx-est (* msg-count 60))
(ctx-limit 8192)
(ctx-pct (min 100 (floor (* 100 ctx-est) ctx-limit)))
(ctx-tok (if (< ctx-est 1000)
(format nil "~d" ctx-est)
(format nil "~dK" (floor ctx-est 1000))))
(ctx-str (format nil "~a (~d%%)" ctx-tok ctx-pct))
(hint-str "ctrl+p | /help")
(ctx-fg (cond ((< ctx-pct 50) (theme-color :tool-done))
((< ctx-pct 80) (theme-color :input-prompt))
(t (theme-color :error))))
(hint-x (- chat-w (length hint-str) 2))
(ctx-x (- hint-x 1 (length ctx-str))))
(cl-tty.backend:draw-text fb hpad (- h 2) left-str hint-fg (theme-color :bg))
(cl-tty.backend:draw-text fb ctx-x (- h 2) ctx-str ctx-fg (theme-color :bg))
(cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg)))))Sidebar
(defun view-sidebar (fb w h)
(let* ((w (or (and (numberp w) (> w 0) w) 80))
(h (or (and (numberp h) (> h 0) h) 24))
(x (- w (or (st :sidebar-width) 42)))
(bg-panel (theme-color :bg-panel))
(y 0))
(cl-tty.backend:draw-rect fb x 0 (- w x) (1- h) :bg bg-panel)
(cl-tty.backend:draw-text fb x (1- h) (make-string (- w x) :initial-element #\Space) nil bg-panel)
;; Gate Trace — from latest agent message
(cl-tty.backend:draw-text fb (+ x 2) (incf y) "GATE TRACE" (theme-color :accent) bg-panel)
(incf y)
(let* ((msgs (st :messages))
(last-gt (loop for i from (1- (length msgs)) downto 0
for m = (aref msgs i)
when (getf m :gate-trace)
return (getf m :gate-trace))))
(if last-gt
(dolist (g last-gt)
(let* ((name (getf g :gate))
(result (getf g :result))
(reason (getf g :reason))
(glyph (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?")))
(color (case result
(:passed (theme-color :tool-done))
(:blocked (theme-color :error))
(:approval (theme-color :input-prompt))
(t (theme-color :dim)))))
(cl-tty.backend:draw-text fb (+ x 2) (incf y) (format nil " ~a ~a" glyph name) color bg-panel)
(when reason
(incf y)
(cl-tty.backend:draw-text fb (+ x 4) (incf y) reason (theme-color :dim) bg-panel))))
(cl-tty.backend:draw-text fb (+ x 2) (incf y) " (none)" (theme-color :dim) bg-panel))
(incf y 2))
;; Rules + Block Count
(let ((blocked (loop for i below (length (st :messages))
for m = (aref (st :messages) i)
sum (loop for g in (getf m :gate-trace)
count (eq (getf g :result) :blocked)))))
(cl-tty.backend:draw-text fb (+ x 2) (incf y) "RULES" (theme-color :accent) bg-panel)
(incf y)
(cl-tty.backend:draw-text fb (+ x 2) (incf y)
(format nil " ~d active" (or (st :rule-count) 0))
(theme-color :agent-fg) bg-panel)
(incf y)
(cl-tty.backend:draw-text fb (+ x 2) (incf y)
(format nil " ~d blocked" blocked)
(if (> blocked 0) (theme-color :error) (theme-color :dim)) bg-panel)
(incf y 2))
;; Cost
(cl-tty.backend:draw-text fb (+ x 2) (incf y) "COST" (theme-color :accent) bg-panel)
(incf y)
(cl-tty.backend:draw-text fb (+ x 2) (incf y)
(format nil " $~,2f" (or (st :session-cost) 0.0))
(theme-color :status-fg) bg-panel)
(incf y 2)
;; Files (stub)
(cl-tty.backend:draw-text fb (+ x 2) (incf y) "FILES" (theme-color :accent) bg-panel)
(incf y)
(cl-tty.backend:draw-text fb (+ x 2) (incf y) " (not yet)" (theme-color :dim) bg-panel)
(incf y 2)
;; Version footer
(let* ((ver (or (st :daemon-version) ""))
(ver-label (if (> (length ver) 0) (format nil "passepartout ~a" ver) "passepartout"))
(dot (if (st :connected) "●" "○"))
(dot-color (if (st :connected) (theme-color :dot-connected) (theme-color :dot-disconnected))))
(cl-tty.backend:draw-text fb (+ x 2) (- h 2) dot dot-color bg-panel)
(cl-tty.backend:draw-text fb (+ x 4) (- h 2) ver-label (theme-color :text-muted) bg-panel))))Redraw (dirty-flag dispatch)
(defun redraw (fb w h)
(setq w (or (and (numberp w) (> w 0) w) 80)
h (or (and (numberp h) (> h 0) h) 24))
(when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty)))
(cl-tty.backend:begin-sync fb)
(cl-tty.backend:draw-rect fb 0 0 w h :bg (theme-color :bg))
(view-status fb w h)
(view-chat fb w h)
(view-input fb w h)
(when (sidebar-visible-p w)
(view-sidebar fb w h))
(cl-tty.backend:end-sync fb)
(position-cursor fb w h)
(setf (st :dirty) (list nil nil nil))))
(defun position-cursor (fb w h)
"Draw cursor at the input insertion point using reverse video (Emacs-style).
The character under the cursor is redrawn with foreground and background
swapped. If the cursor is past the end of the input string, a reversed
space is drawn."
(let* ((sw (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
(cw (- w sw))
(hpad 2)
(chat-w (- w sw))
(text (input-string))
(text-len (length text))
(pos (or (st :cursor-pos) 0))
(prompt-w (- cw (* 2 hpad) 2))
(cl (or (st :cursor-line) 0))
(cc (or (st :cursor-col) 0))
(lines (cl-tty.box:word-wrap text prompt-w))
(n-lines (max 1 (length lines)))
(panel-rows (max 4 (+ n-lines 2)))
(panel-top (- h 4 panel-rows -1))
(cx (+ hpad 2 cc))
(cy (+ panel-top 1 cl))
(bg-i (theme-color :bg-input))
(input-fg (theme-color :input-fg)))
(if (< pos text-len)
(let ((ch (char text pos)))
(cl-tty.backend:draw-text fb cx cy (string ch) bg-i input-fg))
(cl-tty.backend:draw-text fb cx cy " " bg-i input-fg))
(finish-output (cl-tty.backend::backend-output-stream fb))))v0.7.2 — Gate Trace
(in-package :passepartout)
(defun gate-trace-lines (trace)
"Convert gate-trace plist to display lines."
(let ((lines nil))
(dolist (entry trace)
(let* ((gate (getf entry :gate))
(result (getf entry :result))
(reason (getf entry :reason))
(name (or gate "unknown"))
(color (case result
(:passed :tool-done)
(:blocked :error)
(:approval :accent)
(t :dim)))
(prefix (case result
(:passed " \u2713 ")
(:blocked " \u2717 ")
(:approval " \u2192 ")
(t " ? ")))
(text (format nil "~a~a~@[~a~]~@[~a~]"
prefix name
(when reason (format nil ": ~a" reason))
(if (eq result :approval) " (HITL required)" ""))))
(push (cons text (list :fgcolor color)) lines)))
(nreverse lines)))Test Suite
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(test test-gate-trace-lines-passed
"Contract 9: gate-trace-lines for passed gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "path" :result :passed)))))
(is (= 1 (length lines)))
(is (eq :tool-done (getf (cdar lines) :fgcolor)))))
(test test-gate-trace-lines-blocked
"Contract 9: gate-trace-lines for blocked gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "shell" :result :blocked :reason "rm")))))
(is (= 1 (length lines)))
(is (search "rm" (caar lines)))))
(test test-gate-trace-lines-approval
"Contract 9: gate-trace-lines for approval gate."
(let ((lines (passepartout::gate-trace-lines
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
(test test-sidebar-state
"Contract v0.8.0: init-state includes :sidebar-mode (:auto) and :sidebar-width (42)."
(passepartout.channel-tui::init-state)
(is (eq :auto (passepartout.channel-tui::st :sidebar-mode)))
(is (= 42 (passepartout.channel-tui::st :sidebar-width))))
(defun sidebar-visible-p (w)
"Compute whether sidebar should be shown given terminal width W
and current sidebar mode."
(let ((mode (passepartout.channel-tui::st :sidebar-mode)))
(or (eq mode :visible)
(and (eq mode :auto) (> w 120)))))
(test test-sidebar-auto-wide
"Contract v0.8.0: sidebar auto-shows when terminal > 120 cols."
(passepartout.channel-tui::init-state)
(setf (passepartout.channel-tui::st :sidebar-mode) :auto)
(is (sidebar-visible-p 140))
(is (not (sidebar-visible-p 100))))
(test test-sidebar-visible-mode
"Contract v0.8.0: :visible mode shows sidebar regardless of width."
(passepartout.channel-tui::init-state)
(setf (passepartout.channel-tui::st :sidebar-mode) :visible)
(is (sidebar-visible-p 40))
(is (sidebar-visible-p 140)))
(test test-sidebar-hidden-mode
"Contract v0.8.0: :hidden mode hides sidebar regardless of width."
(passepartout.channel-tui::init-state)
(setf (passepartout.channel-tui::st :sidebar-mode) :hidden)
(is (not (sidebar-visible-p 140)))
(is (not (sidebar-visible-p 40))))
(test test-status-bar-tokens
"v0.9.0: status bar uses :status-fg and :status-bg theme tokens."
(is (getf passepartout.channel-tui::*tui-theme* :status-fg))
(is (getf passepartout.channel-tui::*tui-theme* :status-bg)))
(test test-new-theme-keys
"v0.10.0: theme has all zone keys."
(is (getf passepartout.channel-tui::*tui-theme* :bg))
(is (getf passepartout.channel-tui::*tui-theme* :bg-panel))
(is (getf passepartout.channel-tui::*tui-theme* :bg-element))
(is (getf passepartout.channel-tui::*tui-theme* :bg-input))
(is (getf passepartout.channel-tui::*tui-theme* :agent-border))
(is (getf passepartout.channel-tui::*tui-theme* :thinking-bg))
(is (getf passepartout.channel-tui::*tui-theme* :symbolic-border))
(is (getf passepartout.channel-tui::*tui-theme* :text-muted)))