Amr Gharbeia
e0003a5f3c
The backend info message showed NIL for height because the nil guard ran after it. Swap order so the message shows guarded values.
76 KiB
76 KiB
Passepartout TUI — Controller
Controller
Event handlers + daemon I/O + main loop.
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.
Event Handlers
(in-package :passepartout.channel-tui)
(defun on-key (ch)
(cond
;; v0.7.1: Esc — interrupt streaming
((and (or (eq ch :escape) (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 (list #\Space #\Newline #\Tab (code-char 41))))
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))))
;; Enter
((or (eq ch :enter) (eql ch 13) (eql ch 10) (eql ch 343)
(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 with trigger counts
((string-equal text "/tags")
(let ((cats passepartout::*tag-categories*)
(counts passepartout::*tag-trigger-count*))
(if cats
(dolist (entry cats)
(let* ((tag (car entry))
(sev (cdr entry))
(n (gethash (string-downcase tag) counts 0)))
(add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n))))
(add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
;; /context command — section breakdown with token estimates
((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)))
;; rough estimate: TIME, CONTEXT overhead
(overhead-tokens 200)
(total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
(total-limit 8192)
(pct-used (floor (* 100 total-est) total-limit))
(bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10)))
:initial-element #\#)))
(add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used))
(add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens))
(add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens))
(add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens))
(add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count))
(add-msg :system (format nil " [~a~a] ~d%"
bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used))
(when (> pct-used 80)
(add-msg :system "⚠ Context near limit — older messages may be dropped"))))
;; /context why <id> — debug node with full attributes
((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
(let ((attrs (passepartout::memory-object-attributes obj))
(parent (passepartout::memory-object-parent-id obj))
(children (passepartout::memory-object-children obj))
(hash (or (passepartout::memory-object-hash obj) "(none)")))
(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)))
(when parent
(add-msg :system (format nil " parent: ~a" parent)))
(when children
(add-msg :system (format nil " children: ~d" (length children))))
(add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash)))))
(when attrs
(add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)")))))
(add-msg :system (format nil "Node ~a not found in memory" node-id))))
(add-msg :system "Memory not available"))))
;; /context dropped — estimate pruned nodes from budget
((string-equal text "/context dropped")
(let* ((msg-count (length (st :messages)))
(est-total (* msg-count 60))
(budget 8192)
(dropped-msgs (if (> est-total budget)
(floor (- est-total budget) 60)
0)))
(if (> dropped-msgs 0)
(add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)"
dropped-msgs (- est-total budget) budget
(floor (* 100 est-total) budget)))
(add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)"
est-total budget (floor (* 100 est-total) budget))))))
;; /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")
(if (fboundp 'passepartout::audit-verify-hash)
(let* ((result (funcall 'passepartout::audit-verify-hash))
(total (car result))
(missing (cdr result)))
(add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]"
total missing
(length passepartout::*memory-snapshots*)
(zerop missing)
(unless (zerop missing) missing))))
(add-msg :system "Memory audit not available")))
;; /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)))
(sections (self-help-lookup (string-trim '(#\Space) (subseq text 6)))))
(if sections
(dolist (entry sections)
(let* ((title (car entry))
(content (cdr entry))
(preview (if (> (length content) 300)
(concatenate 'string (subseq content 0 297) "...")
content)))
(add-msg :system (format nil "~a: ~a" title preview))))
(add-msg :system (format nil "No manual section found for '~a'" topic)))))
((string-equal text "/help")
(add-msg :system "/eval <expr> Evaluate Lisp")
(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 "/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"))
;; /theme command
((string-equal text "/theme")
(add-msg :system (format nil "Theme: ~a — user-fg=~a agent-fg=~a system=~a input-fg=~a"
*tui-theme-current-name*
(getf *tui-theme* :user-fg)
(getf *tui-theme* :agent-fg)
(getf *tui-theme* :system)
(getf *tui-theme* :input-fg)))
(add-msg :system "Presets: /theme amber | gold | terracotta | sepia | nord-warm | monokai-warm | gruvbox-warm | light-amber"))
((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: amber gold terracotta sepia nord-warm monokai-warm gruvbox-warm light-amber" 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 '("amber" "gold" "terracotta" "sepia" "nord-warm" "monokai-warm" "gruvbox-warm" "light-amber"))
(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 263)
(eql ch #\Backspace))
(input-delete-char)
(setf (st :dirty) (list nil nil t)))
;; Left arrow
((eq ch :left)
(when (> (or (st :cursor-pos) 0) 0)
(decf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Right arrow
((eq ch :right)
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
(incf (st :cursor-pos))
(setf (st :dirty) (list nil nil t))))
;; Up arrow
((eq ch :up)
(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
((eq ch :down)
(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 — scroll back by page (10 lines)
((eq ch :ppage)
(let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
(setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page
((eq ch :npage)
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(setf (st :dirty) (list nil t nil)))
;; Printable
(t
(let ((chr (typecase ch
(character ch)
((integer 32 126) (code-char ch))
(keyword (let ((s (string ch)))
(and (= (length s) 1) (char-downcase (char s 0)))))
(t nil))))
(when (and chr (graphic-char-p chr))
(input-insert-char chr)
(setf (st :dirty) (list nil nil t))
(when (and (char= chr #\/) (null (st :dialog-stack))
(= (length (st :input-buffer)) 1))
(minibuffer-show-commands)))))))
;; v0.8.0 — minibuffer dialog for slash commands
(defun minibuffer-show-commands ()
(let* ((on-select (lambda (opt)
(let ((cmd (getf opt :value)))
(pop (st :dialog-stack))
(setf (st :minibuffer-active) nil)
(setf (st :input-buffer) (reverse (coerce cmd 'list)))
(setf (st :cursor-pos) 0)
(setf (st :dirty) (list nil nil t)))))
(sel (cl-tty.select:make-select :options *slash-commands* :on-select on-select))
(dlg (make-instance 'cl-tty.dialog:dialog
:title "Commands"
:content sel)))
(push dlg (st :dialog-stack))
(setf (st :minibuffer-active) t)))
;; v0.8.0 — command palette for daemon commands (Ctrl+P)
(defun command-palette-show-commands ()
(let* ((on-select (lambda (cmd)
(pop (st :dialog-stack))
(setf (st :command-palette-active) nil)
(let ((action (getf cmd :value)))
(send-daemon (list :type :event :payload action))
(add-msg :system (format nil "Sent: ~a" action)))
(setf (st :dirty) (list t t nil))))
(sel (cl-tty.select:make-select :options *daemon-commands*
:on-select on-select))
(dlg (make-instance 'cl-tty.dialog:dialog
:title "Command Palette"
:content sel)))
(push dlg (st :dialog-stack))
(setf (st :command-palette-active) t)))
;; 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) #\*))
(when (and in-section section-content)
(push (cons in-section (string-trim '(#\Space #\Newline)
(format nil "~{~a~^ ~}" (reverse section-content))))
results))
(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))))))
(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))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace))
((eq action :handshake)
(setf (st :daemon-version) (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")
(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
;; v0.8.0 — Global keymap
(eval-when (:load-toplevel :execute)
(cl-tty.input:defkeymap :global
(:ctrl+q (lambda (e) (declare (ignore e))
(setf (st :running) nil)))
(:ctrl+p (lambda (e) (declare (ignore e))
(command-palette-show-commands)))
(:ctrl+b (lambda (e) (declare (ignore e))
(setf (st :sidebar-visible) (not (st :sidebar-visible)))
(setf (st :dirty) (list t t nil))))
(:ppage (lambda (e) (declare (ignore e))
(let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
(setf (st :dirty) (list nil t nil))))
(:npage (lambda (e) (declare (ignore e))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(setf (st :dirty) (list nil t nil))))
;; v0.9.0 — Readline keybindings
(:ctrl+a (lambda (e) (declare (ignore e))
(setf (st :cursor-pos) 0)))
(:ctrl+e (lambda (e) (declare (ignore e))
(setf (st :cursor-pos) (length (st :input-buffer)))))
(:ctrl+u (lambda (e) (declare (ignore e))
(setf (st :input-buffer) nil)
(setf (st :cursor-pos) 0)
(setf (st :dirty) (list nil nil t))))
(:ctrl+w (lambda (e) (declare (ignore e))
(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)))))
(:ctrl+k (lambda (e) (declare (ignore e))
(let* ((s (input-string))
(pos (or (st :cursor-pos) 0))
(killed (subseq s pos)))
(setf (st :kill-ring) killed)
(setf (st :input-buffer) (reverse (coerce (subseq s 0 pos) 'list)))
(setf (st :dirty) (list nil nil t)))))
(:ctrl+y (lambda (e) (declare (ignore e))
(let ((killed (st :kill-ring)))
(when killed
(dolist (ch (reverse (coerce killed 'list)))
(push ch (st :input-buffer)))
(setf (st :cursor-pos) (length (st :input-buffer)))
(setf (st :dirty) (list nil nil t))))))
(:ctrl+l (lambda (e) (declare (ignore e))
(setf (st :dirty) (list t t t))))
(:ctrl+d (lambda (e) (declare (ignore e))
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit."))))
(:ctrl+f (lambda (e) (declare (ignore e))
(add-msg :system "Use /search <query> to find messages")))
(:ctrl+g (lambda (e) (declare (ignore e))
(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")))))
(:alt+enter (lambda (e) (declare (ignore e))
(push #\Newline (st :input-buffer))
(setf (st :dirty) (list nil nil t))))
;; v0.9.0 — Ctrl+X prefix + help
(:ctrl+x (lambda (e) (declare (ignore e))
(setf (st :pending-ctrl-x) t)))
(:? (lambda (e) (declare (ignore e))
(add-msg :system "Keybindings: Ctrl+P palette | Ctrl+B sidebar | Ctrl+F search | Ctrl+L redraw | Ctrl+D quit | Ctrl+Q quit | PageUp/Dn scroll | Esc interrupt | Tab complete | Up/Dn history")
(add-msg :system "Commands: /eval <expr> | /undo | /redo | /why | /identity | /tags | /audit | /search | /context | /focus | /scope | /unfocus | /theme | /reconnect | /help")
(setf (st :dirty) (list t t nil))))))
;; v0.8.0 — Prompt/local keymap (for when input is active)
(eval-when (:load-toplevel :execute)
(cl-tty.input:defkeymap :local
(:up (lambda (e) (declare (ignore e)) (on-key :up)))
(:down (lambda (e) (declare (ignore e)) (on-key :down)))
(:escape (lambda (e) (declare (ignore e)) (on-key :escape)))))
(defun tui-main ()
(init-state)
(load-history)
(theme-load)
(let* ((swank-port (or (ignore-errors
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
4006)))
(setf (st :dirty) (list t t t))
(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 *"))))
(cl-tty.backend:with-terminal (be w h)
;; Disable echo only — keep canonical mode (line input). stty raw
;; breaks read on fd 0 in this SBCL environment, but -echo alone
;; works. A cat subprocess inherits the terminal and provides
;; bytes through a pipe that SBCL reads reliably.
(uiop:run-program '("stty" "-echo") :output nil :ignore-error-status t)
(let* ((cat-proc (uiop:launch-program '("stdbuf" "-o0" "cat")
:output :stream
:input :interactive
:stderr nil))
(tty-in (uiop:process-info-output cat-proc)))
(add-msg :system (format nil "* cat pid=~a *" (uiop:process-info-pid cat-proc)))
;; Guard against nil w/h from backend-size
(setq w (or (and (numberp w) (> w 0) w) 80)
h (or (and (numberp h) (> h 0) h) 24))
;; Log backend info and terminal dimensions
(let ((backend-type (if (typep be 'cl-tty.backend:modern-backend)
"modern" "simple")))
(add-msg :system (format nil "* ~a backend ~dx~d *" backend-type w h)))
;; Guard against nil w/h from backend-size
(setq w (or (and (numberp w) (> w 0) w) 80)
h (or (and (numberp h) (> h 0) h) 24))
;; Log backend info and terminal dimensions
(cl-tty.backend:backend-clear be)
(view-status be w h)
(view-chat be w h)
;; Draw separator line above input
(cl-tty.backend:draw-text be 0 (- h 4) (make-string w :initial-element #\─)
(theme-color :separator) nil)
(view-input be w h)
(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 *"))))
;; Check for terminal resize (SIGWINCH sets this flag)
;; Keyboard reader: block on cat pipe with 0.1s timeout.
(handler-case
(sb-ext:with-timeout 0.1
(let ((raw-ch (read-char tty-in nil nil)))
(when raw-ch
(let ((code (char-code raw-ch)))
(queue-event
(list :type :key
:payload (list :code code
:ch (cond
((= code 13) :enter)
((= code 10) :enter)
((= code 27) :escape)
((= code 9) :tab)
((or (= code 127) (= code 8)) :backspace)
((and (>= code 1) (<= code 26))
(intern
(string-upcase
(format nil "CTRL-~a"
(code-char (+ #x60 code))))
:keyword))
(t code)))))))))
(sb-ext:timeout ()))
;; Check for terminal resize (SIGWINCH sets this flag)
(when (boundp 'cl-tty.input::*terminal-resized-p*)
(when cl-tty.input::*terminal-resized-p*
(setf cl-tty.input::*terminal-resized-p* nil)
(multiple-value-setq (w h) (cl-tty.backend:backend-size be))
(setq w (or (and (numberp w) (> w 0) w) 80)
h (or (and (numberp h) (> h 0) h) 24))
(setf (st :dirty) (list t t t))))
;; Guard w and h before render (resize or other code may have set them to nil)
(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:backend-clear be)
(view-status be w h)
(view-chat be w h)
;; Draw separator line above input
(cl-tty.backend:draw-text be 0 (- h 4) (make-string w :initial-element #\─)
(theme-color :separator) nil)
(view-input be w h)
(when (and (st :sidebar-visible) (>= w 120))
(view-sidebar be w h))
(setf (st :dirty) (list nil nil nil)))
(let ((ds (st :dialog-stack)))
(when ds
(let* ((dlg (car ds))
(sel (cl-tty.dialog:dialog-content dlg))
(filtered (cl-tty.select:select-filtered-options sel))
(sel-idx (cl-tty.select:select-selected-index sel))
(cnt (length filtered))
(dw 60) (dh (min 20 (+ 4 cnt)))
(mx (floor (- w dw) 2))
(my 3))
(dotimes (row h)
(cl-tty.backend:draw-rect be 0 row w 1 :bg (theme-color :status-bg)))
(cl-tty.backend:draw-border be mx my dw dh :style :single
:title (cl-tty.dialog:dialog-title dlg)
:fg (theme-color :user-border))
(let ((y-off 1))
(dolist (item filtered)
(let* ((display-idx (first item))
(option (third item))
(title (getf option :title))
(cat (getf option :category))
(sel-p (eql display-idx sel-idx))
(text (if cat (format nil " ~a" title)
(format nil " ~:[ ~;▸~] ~a" sel-p title))))
(when (>= y-off (1- dh)) (return))
(cl-tty.backend:draw-text be (1+ mx) (+ my y-off) text
(cond (cat (theme-color :dim))
(sel-p (theme-color :accent))
(t (theme-color :agent-fg)))
nil :bold sel-p)
(incf y-off)))))))
(sleep 0.1)))
(uiop:terminate-process cat-proc)
(add-msg :system (format nil "* cat ~a ended *" (uiop:process-info-pid cat-proc))))
(progn (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 warm color mappings."
(fiveam:is (string= "#FFB347" (getf *tui-theme* :user-fg)))
(fiveam:is (string= "#E8D5B7" (getf *tui-theme* :agent-fg)))
(fiveam:is (string= "#C8A87C" (getf *tui-theme* :system)))
(fiveam:is (string= "#E8D5B7" (getf *tui-theme* :input-fg)))
(fiveam:is (string= "#FFFFFF" (theme-color :unknown-role))))
(fiveam:test test-on-key-ctrl-u-clears
"Contract v0.9.0: Ctrl+U (via dispatch-key-event) clears the input buffer."
(init-state)
(dolist (ch '(#\h #\i)) (on-key (char-code ch)))
(cl-tty.input:dispatch-key-event
(cl-tty.input:make-key-event :key :u :ctrl t :code 21))
(fiveam:is (string= "" (input-string))))
(fiveam:test test-on-key-ctrl-l-redraws
"Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags."
(init-state)
(setf (st :dirty) (list nil nil nil))
(cl-tty.input:dispatch-key-event
(cl-tty.input:make-key-event :key :l :ctrl t :code 12))
(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 "amber" (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.9.0: Ctrl+G (via dispatch-key-event) toggles gate-trace collapse state."
(init-state)
(add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed)))
(cl-tty.input:dispatch-key-event
(cl-tty.input:make-key-event :key :g :ctrl t :code 7))
(let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs)))))
(fiveam:is (search "hidden" (getf m :content))))
(cl-tty.input:dispatch-key-event
(cl-tty.input:make-key-event :key :g :ctrl t :code 7))
(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.9.0: Ctrl+G (via dispatch-key-event) with no gate trace shows fallback."
(init-state)
(cl-tty.input:dispatch-key-event
(cl-tty.input:make-key-event :key :g :ctrl t :code 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 Minibuffer ──
(fiveam:test test-slash-commands-defined
"Contract v0.8.0: *slash-commands* is non-nil list of option plists."
(fiveam:is (listp passepartout.channel-tui::*slash-commands*))
(fiveam:is (> (length passepartout.channel-tui::*slash-commands*) 0))
(fiveam:is (every (lambda (opt)
(and (getf opt :title) (getf opt :value) (getf opt :category)))
passepartout.channel-tui::*slash-commands*)))
(fiveam:test test-minibuffer-state
"Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields."
(init-state)
(fiveam:is (null (st :dialog-stack)))
(fiveam:is (null (st :minibuffer-active))))
(fiveam:test test-command-palette-state
"Contract v0.8.0: init-state has :command-palette-active and :command-palette-dialog as nil."
(init-state)
(fiveam:is (null (st :command-palette-active)))
(fiveam:is (null (st :command-palette-dialog))))