passepartout/org/channel-tui-view.org

Passepartout TUI — View

• View
  • Contract
  • Status Bar
  • Input Line
  • Sidebar
  • Redraw (dirty-flag dispatch)
• v0.7.2 — Gate Trace
• Test Suite

View

Pure render functions. Each takes the cl-tty backend and current state.

State is read via (st :key) — no mutation here.

Contract

1. (view-status fb w h): no-op. Status bar is a clean black line.
2. (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.
3. (view-input fb w h): renders expanding light grey input box, multi-line word-wrapped prompt, hint bar at h-2. Text and cursor rendered by cl-tty.input text-input's render method.
4. (view-sidebar fb w h): renders sidebar panels using sidebar-lines.
5. (sidebar-lines): builds a flat list of (text . color-key) pairs for the sidebar: gate trace, rules, cost, files, version.
6. (msg->pairs msg index bordered-w unbordered-w is-search): converts a message to renderable (border border-color text text-color &optional bg) lines. Handles markdown, gate trace, tool calls, search highlight.
7. (render-pair fb hpad y pair): draws one message line pair.
8. (redraw fb w h): wraps view-status/chat/input in begin-sync/end-sync, dispatches per dirty flags, fills global :bg first.
9. cl-tty.box:char-width for terminal column width. ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8. Used by cl-tty.box:word-wrap for accurate line counting.
10. (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-trace field 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 text."
  (let* ((hpad 2)
         (inner-w (- chat-w (* 2 hpad)))
         (prompt-w (- inner-w 2))
         (text (cl-tty.input:text-input-value (st :text-input)))
         (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)))

;; Build simple tab-like blocks

(in-package :passepartout.channel-tui)

(defun msg->pairs (msg index bordered-w unbordered-w is-search)
  "Convert a message to a list of (border-str border-color text-str text-color &optional bg) lines."
  (let* ((role (getf msg :role))
         (content (getf msg :content))
         (cs (if is-search (cl-tty.markdown: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 index (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 index (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)))))))
    (nreverse pairs)))

(defun render-pair (fb hpad y pair)
  "Draw a single (border-str border-color text-str text-color &optional bg) line."
  (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 (theme-color :bg)))
      (cl-tty.backend:draw-text fb (+ hpad (if has-border 2 0)) y tstr tcolor (theme-color :bg)))))

(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))
    ;; Search header
    (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)))
    ;; Build all message lines once
    (let* ((msg-lines (map 'vector
                           (lambda (msg i) (msg->pairs msg i bordered-w unbordered-w is-search))
                           msgs
                           (make-array total :initial-contents (loop for i below total collect i))))
           (heights (map 'vector #'length msg-lines))
           (scroll-skip (st :scroll-offset))
           (i 0))
      ;; Forward scan: skip messages scrolled past, then render visible ones
      (loop while (< i total)
            do (let ((hgt (aref heights i)))
                 (if (> scroll-skip 0)
                     (decf scroll-skip hgt)
                     (let ((msg-y y))
                       (dolist (pair (aref msg-lines i))
                         (when (>= msg-y panel-top) (return))
                         (render-pair fb hpad msg-y pair)
                         (incf msg-y))
                       (setf y (1+ msg-y))  ;; +1 spacer between messages
                       (when (>= y panel-top) (return)))))
            (incf i)))))

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))
         (input (st :text-input))
         (n-lines (max 1 (length (cl-tty.box:word-wrap (cl-tty.input:text-input-value input) prompt-w))))
          (panel-rows (max 4 (+ n-lines 2)))
          (panel-top (input-panel-top chat-w h))
         (bg-i (theme-color :bg-input))
         (hint-fg (theme-color :hint)))
    ;; Fill input panel
    (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))
    ;; Render text-input widget (word-wrap + cursor)
    (let ((ln (make-layout-node)))
      (setf (layout-node-x ln) (+ hpad 2)
            (layout-node-y ln) (1+ panel-top)
            (layout-node-width ln) prompt-w)
      (setf (cl-tty.input:text-input-layout-node input) ln)
      (cl-tty.box:render input fb))
    ;; Hint bar at h-2
    (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 sidebar-lines ()
  "Collect all sidebar lines as (text . color-key) pairs."
  (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)))
         (blocked (loop for i below (length msgs)
                        for m = (aref msgs i)
                        sum (loop for g in (getf m :gate-trace)
                                  count (eq (getf g :result) :blocked))))
         (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) :dot-connected :dot-disconnected)))
    (append
     ;; Gate Trace
     '("GATE TRACE" . :accent)
     (if last-gt
         (mapcan (lambda (g)
                   (let* ((name (getf g :gate))
                          (result (getf g :result))
                          (reason (getf g :reason))
                          (glyph (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?")))
                          (color (case result
                                   (:passed :tool-done)
                                   (:blocked :error)
                                   (:approval :input-prompt)
                                   (t :dim))))
                     (if reason
                         (list (cons (format nil "  ~a ~a" glyph name) color)
                               (cons (format nil "    ~a" reason) :dim))
                         (list (cons (format nil "  ~a ~a" glyph name) color)))))
                 last-gt)
         '((cons "  (none)" :dim)))
     ;; Rules
     '("" nil)
     '("RULES" . :accent)
     (list (cons (format nil "  ~d active" (or (st :rule-count) 0)) :agent-fg))
     (list (cons (format nil "  ~d blocked" blocked)
                 (if (> blocked 0) :error :dim)))
     ;; Cost
     '("" nil)
     '("COST" . :accent)
     (list (cons (format nil "  $~,2f" (or (st :session-cost) 0.0)) :status-fg))
     ;; Files
     '("" nil)
     '("FILES" . :accent)
     '("  (not yet)" . :dim)
     ;; spacer
     '("" nil)
     ;; Version footer — rendered at h-2, not in the loop
     (list (cons (format nil "~a ~a" dot ver-label) dot-color)))))

(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)))
         (lines (sidebar-lines))
         (content-lines (butlast lines))
         (footer-line (car (last lines))))
    (cl-tty.backend:draw-rect fb x 0 (- w x) (1- h) :bg (theme-color :bg-panel))
    (loop for (text . color-key) in content-lines
          for y from 0
          when text
            do (cl-tty.backend:draw-text fb (+ x 2) y text
                                          (if color-key (theme-color color-key) (theme-color :dim))
                                          (theme-color :bg-panel)))
    ;; Version footer at h-2
    (when footer-line
      (cl-tty.backend:draw-text fb (+ x 2) (- h 2) (car footer-line)
                                (theme-color (cdr footer-line))
                                (theme-color :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)))
    (handler-case
        (progn
          (cl-tty.backend:with-frame (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)))
          (setf (st :dirty) (list nil nil nil)))
      (error (c)
        (add-msg :system (format nil "* Render error: ~a *" c))))))

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-markdown-bold
  "parse-inline detects **bold**."
  (let ((nodes (cl-tty.markdown:parse-inline "hello **world**!")))
    (is (= 3 (length nodes)))
    (is (eq :bold (getf (second nodes) :type)))))

(test test-markdown-plain
  "parse-inline returns text node for plain input."
  (let ((nodes (cl-tty.markdown:parse-inline "plain")))
    (is (= 1 (length nodes)))
    (is (eq :text (getf (first nodes) :type)))))

(test test-markdown-url
  "parse-inline returns text nodes including URLs (no built-in auto-link)."
  (let ((nodes (cl-tty.markdown:parse-inline "see https://example.com for more")))
    (is (>= (length nodes) 1))))

(test test-markdown-blocks
  "parse-blocks detects code blocks."
  (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
         (nodes (cl-tty.markdown:parse-blocks text)))
    (is (= 3 (length nodes)))
    (is (eq :code-block (getf (second nodes) :type)))
    (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline)
                              (getf (second nodes) :content))))))

(test test-markdown-blocks-no-close
  "parse-blocks returns code-block even when unclosed."
  (let* ((text "```~%unclosed code")
         (nodes (cl-tty.markdown:parse-blocks text)))
    (is (eq :code-block (getf (first nodes) :type)))))

(test test-syntax-highlight
  "highlight-code returns segment pairs for Lisp code."
  (let ((result (cl-tty.markdown:highlight-code "(defun foo (x) (+ x 1))" "lisp")))
    (is (listp result))
    (is (> (length result) 0))))

(test test-syntax-highlight-keyword
  "highlight-code classifies keywords."
  (let ((result (cl-tty.markdown:highlight-code "(let ((x 1)) (+ x 2))" "lisp")))
    (is (find :keyword result :key #'cdr))))

(test test-syntax-highlight-function
  "highlight-code classifies function calls."
  (let ((result (cl-tty.markdown:highlight-code "(+ 1 2)" "lisp")))
    (is (listp result))
    (is (> (length result) 0))))

(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 (stringp (passepartout.channel-tui:theme-color :status-fg)))
  (is (stringp (passepartout.channel-tui:theme-color :status-bg))))

(test test-new-theme-keys
  "v0.10.0: theme has all zone keys."
  (is (stringp (passepartout.channel-tui:theme-color :bg)))
  (is (stringp (passepartout.channel-tui:theme-color :bg-panel)))
  (is (stringp (passepartout.channel-tui:theme-color :bg-element)))
  (is (stringp (passepartout.channel-tui:theme-color :bg-input)))
  (is (stringp (passepartout.channel-tui:theme-color :agent-border)))
  (is (stringp (passepartout.channel-tui:theme-color :thinking-bg)))
  (is (stringp (passepartout.channel-tui:theme-color :symbolic-border)))
  (is (stringp (passepartout.channel-tui:theme-color :text-muted))))