Amr Gharbeia
a64532bc96
When / is typed on an empty input with no dialog open, open the command palette with "/" pre-filled in the filter instead of inserting / into the text buffer. Ctrl+P still opens the palette without a pre-filled filter.
1208 lines
53 KiB
Org Mode
1208 lines
53 KiB
Org Mode
#+TITLE: Passepartout TUI — Controller
|
|
#+PROPERTY: header-args:lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
|
|
|
|
* Controller
|
|
|
|
Event handlers + daemon I/O + main loop.
|
|
|
|
** Contract
|
|
|
|
1. (on-key ch): dispatches key presses: Enter triggers send (extracts
|
|
input buffer, pushes history, sends to daemon, clears buffer),
|
|
~\\ + Enter~ inserts a literal newline (multi-line input),
|
|
~/help~ lists all commands, ~/eval <expr>~ evaluates a Lisp
|
|
expression, ~/focus <proj>~ switches project context,
|
|
~/scope <scope>~ changes context scope, ~/unfocus~ pops 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.
|
|
2. (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.
|
|
3. (send-daemon msg): serializes and sends a message to the daemon
|
|
over the framed TCP protocol.
|
|
4. (tui-main): the main loop — connects to daemon, initializes
|
|
Croatoan windows, optionally starts Swank REPL, runs
|
|
render/input event loop at ~30fps.
|
|
|
|
** Event Handlers
|
|
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
|
|
(in-package :passepartout.channel-tui)
|
|
|
|
(defun input-text ()
|
|
"Get current input text from the text-input widget."
|
|
(cl-tty.input:text-input-value (st :text-input)))
|
|
|
|
(defun (setf input-text) (value)
|
|
"Set current input text and reset cursor."
|
|
(setf (cl-tty.input:text-input-value (st :text-input)) value
|
|
(cl-tty.input:text-input-cursor (st :text-input)) (length value)))
|
|
|
|
(defun handle-submit (text)
|
|
"Called when user presses Enter in the text-input widget."
|
|
(let ((trimmed (string-trim '(#\Space #\Tab) text)))
|
|
(when (> (length trimmed) 0)
|
|
(push trimmed (st :input-history))
|
|
(setf (st :input-hpos) 0 (st :scroll-offset) 0)
|
|
(command-dispatch trimmed)
|
|
;; Clear input text — replace with a fresh widget with same callbacks
|
|
(setf (st :text-input) (make-text-input-with-callbacks))
|
|
(setf (st :dirty) (list t t t)))))
|
|
|
|
(defun handle-cancel ()
|
|
"Called when user presses Escape in the text-input widget."
|
|
(cond
|
|
((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
|
|
(getf (aref (st :messages) idx) :time) (now))))
|
|
(setf (st :streaming-text) nil (st :busy) nil)
|
|
(setf (st :dirty) (list t t nil)))
|
|
((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"))))
|
|
|
|
(defun extract-url-from-messages ()
|
|
"Scan agent messages from newest to oldest for a URL. Returns the URL or nil."
|
|
(let ((msgs (st :messages)))
|
|
(dotimes (i (length msgs) nil)
|
|
(let* ((idx (1- (- (length msgs) i)))
|
|
(msg (aref msgs idx))
|
|
(content (getf msg :content))
|
|
(role (getf msg :role)))
|
|
(unless (eq role :agent) (return nil))
|
|
(when content
|
|
(let ((pos (or (search "https://" content) (search "http://" content))))
|
|
(when pos
|
|
(let ((end (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab)))
|
|
content :start pos)
|
|
(length content))))
|
|
(return (subseq content pos end))))))))))
|
|
|
|
(defun handle-tab (text pos)
|
|
"Called when user presses Tab in the text-input widget.
|
|
Returns two values: new-text and new-cursor-pos (or nil if no completion)."
|
|
(declare (ignore pos))
|
|
(cond
|
|
;; URL extraction on empty input
|
|
((string= "" text)
|
|
(if (st :url-buffer)
|
|
(progn (add-msg :system (format nil "Opening ~a" (st :url-buffer)))
|
|
(setf (st :url-buffer) nil)
|
|
nil)
|
|
(let ((url (extract-url-from-messages)))
|
|
(when url
|
|
(setf (st :url-buffer) url)
|
|
(add-msg :system (format nil "Press Tab to open ~a" url))
|
|
(setf (st :dirty) (list t t nil)))
|
|
nil)))
|
|
;; @ 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
|
|
(values (concatenate 'string "@" match) (length (concatenate 'string "@" match))))))
|
|
;; /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" "catppuccin" "tokyonight" "dracula"
|
|
"gemini" "mono"))
|
|
(match (if (string= partial "") (first names)
|
|
(find partial names :test #'string-equal))))
|
|
(when match (values (concatenate 'string "/theme " match)))))
|
|
;; /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 (values (concatenate 'string "/focus " match)))))
|
|
;; 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
|
|
(if (member match '("/eval" "/focus" "/scope") :test #'string=)
|
|
(values (concatenate 'string match " "))
|
|
(values match)))))
|
|
(t nil)))
|
|
|
|
|
|
(defun handle-history (direction)
|
|
"Called when user presses Up/Down in the text-input widget.
|
|
Returns two values: new-text and new-cursor-pos (or nil if no movement)."
|
|
(let ((h (st :input-history)) (p (st :input-hpos)))
|
|
(if (eq direction :up)
|
|
(when (and h (< p (1- (length h))))
|
|
(incf (st :input-hpos))
|
|
(values (nth (st :input-hpos) h) (length (nth (st :input-hpos) h))))
|
|
(when (> (st :input-hpos) 0)
|
|
(decf (st :input-hpos))
|
|
(if (and h (< (st :input-hpos) (length h)))
|
|
(values (nth (st :input-hpos) h) (length (nth (st :input-hpos) h)))
|
|
(values "" 0))))))
|
|
|
|
(defun handle-ppage ()
|
|
"Scroll chat up by one page."
|
|
(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)))
|
|
|
|
(defun handle-npage ()
|
|
"Scroll chat down by one page."
|
|
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
|
|
(setf (st :dirty) (list nil t nil)))
|
|
|
|
(defun handle-search-navigate (direction)
|
|
"Search mode: move to prev/next match."
|
|
(let* ((matches (st :search-matches))
|
|
(idx (st :search-match-idx))
|
|
(new-idx (if (eq direction :up)
|
|
(max 0 (1- 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.8.0 — command dispatch table: each command is its own function.
|
|
;; Exact-match commands are looked up in *command-table*; prefix
|
|
;; commands (e.g. /search <query>) go through command-dispatch-prefix.
|
|
|
|
(defun cmd-undo (text) (declare (ignore text))
|
|
(send-daemon (list :type :event :payload (list :sensor :undo)))
|
|
(add-msg :system "Undo: restoring memory to previous state"))
|
|
|
|
(defun cmd-redo (text) (declare (ignore text))
|
|
(send-daemon (list :type :event :payload (list :sensor :redo)))
|
|
(add-msg :system "Redo: restoring memory"))
|
|
|
|
(defun cmd-why (text) (declare (ignore text))
|
|
(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))
|
|
(prefix (case result (:passed "✓") (:blocked "✗") (:approval "→") (t "?"))))
|
|
(add-msg :system (format nil " ~a ~a~@[: ~a~]" prefix gate reason)))))
|
|
(unless found (add-msg :system "No gate trace on last agent message."))))
|
|
|
|
(defun cmd-help (text) (declare (ignore text))
|
|
(add-msg :system "Commands:")
|
|
(add-msg :system "/undo /redo /reconnect /focus /scope /unfocus /theme /why /quit /help Ctrl+G"))
|
|
|
|
(defun cmd-theme (text) (declare (ignore text))
|
|
(add-msg :system (format nil "Theme: user-fg=~a agent-fg=~a system=~a input-fg=~a"
|
|
(theme-color :user-fg) (theme-color :agent-fg) (theme-color :system) (theme-color :input-fg)))
|
|
(add-msg :system "Presets: amber gold terracotta sepia nord-warm monokai-warm gruvbox-warm light-amber catppuccin tokyonight dracula gemini mono"))
|
|
|
|
(defun cmd-eval-usage (text) (declare (ignore text))
|
|
(add-msg :system "Usage: /eval (expr) Evaluate Lisp"))
|
|
|
|
(defun cmd-audit-usage (text) (declare (ignore text))
|
|
(add-msg :system "/audit <id> Inspect memory. /audit verify check integrity."))
|
|
|
|
(defun cmd-sessions (text) (declare (ignore text))
|
|
(let* ((snaps (passepartout::snapshot-list)) (count (length snaps)))
|
|
(add-msg :system (format nil "Snapshots: ~d. /rewind <n> /resume <n>" count))))
|
|
|
|
(defun cmd-quit (text) (declare (ignore text))
|
|
(save-history)
|
|
(add-msg :system "* Goodbye *")
|
|
(send-daemon (list :type :event :payload '(:action :quit)))
|
|
(setf (st :running) nil))
|
|
|
|
(defun cmd-reconnect (text) (declare (ignore text))
|
|
(disconnect-daemon) (add-msg :system "* Reconnecting... *") (connect-daemon)
|
|
(setf (st :dirty) (list t t nil)))
|
|
|
|
(defun cmd-context (text) (declare (ignore text))
|
|
(add-msg :system "Context summary: /context why <id> or /context dropped"))
|
|
|
|
(defun cmd-tags (text) (declare (ignore text))
|
|
(let ((tags (or (uiop:getenv "TAG_CATEGORIES") (uiop:getenv "PRIVACY_FILTER_TAGS") "@personal")))
|
|
(add-msg :system (format nil "Tags: ~a" tags))))
|
|
|
|
;; Prefix command handlers
|
|
|
|
(defun cmd-search (text)
|
|
(let ((query (string-trim '(#\Space) (subseq text 8))))
|
|
(when (> (length query) 0)
|
|
(let (matches)
|
|
(dotimes (i (length (st :messages)))
|
|
(let* ((msg (aref (st :messages) i)) (content (getf msg :content)))
|
|
(when (and content (search query content :test #'char-equal))
|
|
(push i matches))))
|
|
(setf matches (nreverse matches))
|
|
(setf (st :search-mode) t (st :search-query) query
|
|
(st :search-matches) matches (st :search-match-idx) 0)
|
|
(add-msg :system (format nil "Search: ~d matches for '~a' (1/~d)" (length matches) query (length matches)))
|
|
(when matches (setf (st :scroll-offset) (first matches)))
|
|
(setf (st :dirty) (list nil t nil))))))
|
|
|
|
(defun cmd-theme-set (text)
|
|
(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" name)))))
|
|
|
|
(defun cmd-eval (text)
|
|
(let ((code (subseq text 6)))
|
|
(handler-case
|
|
(let ((result (eval (let ((*read-eval* nil)) (read-from-string code)))))
|
|
(add-msg :system (format nil "=> ~a" result)))
|
|
(error (c) (add-msg :system (format nil "Eval error: ~a" c))))))
|
|
|
|
(defun cmd-audit (text)
|
|
(let ((arg (string-trim '(#\Space) (subseq text 7))))
|
|
(if (string-equal arg "verify")
|
|
(let* ((r (passepartout::audit-verify-hash)) (total (car r)) (missing (cdr r)))
|
|
(add-msg :system (format nil "Memory: ~d objects, ~d missing hashes" total missing)))
|
|
(let ((info (passepartout::audit-node arg)))
|
|
(if info (add-msg :system (format nil "Node ~a: type=~a version=~a hash=~a scope=~a"
|
|
(getf info :id) (getf info :type) (getf info :version) (getf info :hash) (getf info :scope)))
|
|
(add-msg :system (format nil "Node ~a not found" arg)))))))
|
|
|
|
(defun cmd-rewind (text)
|
|
(let ((n (ignore-errors (parse-integer (string-trim '(#\Space) (subseq text 8))))))
|
|
(if n (progn (passepartout::rollback-memory n) (add-msg :system (format nil "Rolled back to snapshot ~d" n)))
|
|
(add-msg :system "Usage: /rewind <number>"))))
|
|
|
|
(defun cmd-resume (text)
|
|
(let ((n (ignore-errors (parse-integer (string-trim '(#\Space) (subseq text 7))))))
|
|
(if (and n (< n (length (symbol-value 'passepartout::*memory-snapshots*))))
|
|
(progn (passepartout::rollback-memory n) (add-msg :system (format nil "Resumed snapshot ~d" n)))
|
|
(add-msg :system "Usage: /resume <number>"))))
|
|
|
|
(defun cmd-default (text)
|
|
(add-msg :user text)
|
|
(setf (st :busy) t)
|
|
(send-daemon (list :type :event :payload (list :sensor :user-input :text text))))
|
|
|
|
(defparameter *command-table*
|
|
(list
|
|
(cons "/undo" #'cmd-undo)
|
|
(cons "/redo" #'cmd-redo)
|
|
(cons "/why" #'cmd-why)
|
|
(cons "/help" #'cmd-help)
|
|
(cons "/theme" #'cmd-theme)
|
|
(cons "/eval" #'cmd-eval-usage)
|
|
(cons "/audit" #'cmd-audit-usage)
|
|
(cons "/sessions" #'cmd-sessions)
|
|
(cons "/quit" #'cmd-quit)
|
|
(cons "/q" #'cmd-quit)
|
|
(cons "/reconnect" #'cmd-reconnect)
|
|
(cons "/context" #'cmd-context)
|
|
(cons "/tags" #'cmd-tags))
|
|
"Alist of (command-string . handler-function) for exact-match commands.")
|
|
|
|
(defun command-dispatch (text)
|
|
"Handle a submitted command or message. TEXT is the trimmed input.
|
|
Called from handle-submit."
|
|
(let ((handler (find text *command-table* :test #'string-equal :key #'car)))
|
|
(if handler
|
|
(funcall (cdr handler) text)
|
|
(command-dispatch-prefix text))))
|
|
|
|
(defun command-dispatch-prefix (text)
|
|
"Handle prefix-matched commands that take arguments."
|
|
(cond
|
|
((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)))
|
|
((> (length text) 8)
|
|
(when (string-equal (subseq text 0 8) "/search ")
|
|
(cmd-search text)))
|
|
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme "))
|
|
(cmd-theme-set text))
|
|
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/eval ") (> (length text) 6))
|
|
(cmd-eval text))
|
|
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit "))
|
|
(cmd-audit text))
|
|
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind "))
|
|
(cmd-rewind text))
|
|
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/resume "))
|
|
(cmd-resume text))
|
|
(t (cmd-default text))))
|
|
|
|
(defun unified-menu-show (&optional initial-filter)
|
|
"Open the command minibuffer with ALL commands. If INITIAL-FILTER is
|
|
supplied (e.g. \"/\"), pre-fill the select filter with it."
|
|
(let* ((on-select (lambda (opt)
|
|
(pop (st :dialog-stack))
|
|
(let ((val (getf opt :value)))
|
|
(cond ((stringp val)
|
|
;; Slash command — fill input buffer
|
|
(setf (input-text) val)
|
|
(setf (st :dirty) (list nil nil t)))
|
|
((listp val)
|
|
;; Daemon action — send immediately
|
|
(send-daemon (list :type :event :payload val))
|
|
(add-msg :system (format nil "Sent: ~a" (getf opt :title)))
|
|
(setf (st :dirty) (list t t nil)))))))
|
|
(sel (cl-tty.dialog:make-select :options (all-commands) :on-select on-select)))
|
|
(when initial-filter
|
|
(setf (cl-tty.dialog:select-filter sel) initial-filter))
|
|
(let ((dlg (make-instance 'cl-tty.dialog:dialog :title "Commands" :content sel)))
|
|
(push dlg (st :dialog-stack)))))
|
|
|
|
;; 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))
|
|
(gate-trace (getf msg :gate-trace))
|
|
(rule-count (getf payload :rule-count))
|
|
(foveal-id (getf payload :foveal-id))
|
|
(session-cost (getf payload :session-cost)))
|
|
;; 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))
|
|
(when session-cost (setf (st :session-cost) session-cost))
|
|
(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))))))
|
|
#+END_SRC
|
|
|
|
** Daemon Communication
|
|
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
|
|
(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))))))
|
|
|
|
(defun save-history ()
|
|
"Save input history to disk for next TUI session."
|
|
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
|
|
(user-homedir-pathname))))
|
|
(ensure-directories-exist hist-file)
|
|
(with-open-file (out hist-file :direction :output :if-exists :supersede)
|
|
(dolist (line (reverse (st :input-history)))
|
|
(write-line line out)))))
|
|
#+END_SRC
|
|
|
|
** Connection
|
|
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
|
|
;; Process a key-event: route through dialog, keymap, navigation, or text-input.
|
|
(defun process-key-event (event)
|
|
(let* ((k (cl-tty.input:key-event-key event)))
|
|
(cond
|
|
((st :dialog-stack)
|
|
(let* ((dlg (car (st :dialog-stack)))
|
|
(sel (cl-tty.dialog:dialog-content dlg)))
|
|
(if (cl-tty.dialog:select-handle-key sel event)
|
|
;; select-handle-key handled nav or enter + fired callback
|
|
(when (eql k :enter)
|
|
(pop (st :dialog-stack)))
|
|
;; not handled: escape, char input, backspace
|
|
(cond
|
|
((eql k :escape)
|
|
(pop (st :dialog-stack)))
|
|
((let ((ch (code-char (cl-tty.input:key-event-code event))))
|
|
(and ch (graphic-char-p ch)
|
|
(setf (cl-tty.dialog:select-filter sel)
|
|
(concatenate 'string
|
|
(or (cl-tty.dialog:select-filter sel) "")
|
|
(string ch))))))
|
|
((eql k :backspace)
|
|
(let ((f (cl-tty.dialog:select-filter sel)))
|
|
(when (> (length (or f "")) 0)
|
|
(setf (cl-tty.dialog:select-filter sel)
|
|
(subseq f 0 (1- (length f)))))))))
|
|
(setf (st :dirty) (list t t nil))))
|
|
((cl-tty.input:dispatch-key-event event)
|
|
(setf (st :dirty) (list t t nil)))
|
|
((member k '(:ppage :npage))
|
|
(if (eq k :ppage) (handle-ppage) (handle-npage)))
|
|
(t (let ((ch (code-char (cl-tty.input:key-event-code event))))
|
|
(if (and ch (char= ch #\/)
|
|
(null (st :dialog-stack))
|
|
(zerop (length (input-text))))
|
|
(unified-menu-show "/")
|
|
(handler-case
|
|
(progn
|
|
(cl-tty.input:handle-text-input (st :text-input) event)
|
|
(setf (st :dirty) (list nil nil t)))
|
|
(error (c)
|
|
(add-msg :system (format nil "* Input error: ~a *" c))))))))))
|
|
|
|
(defun connect-daemon (&optional (host "127.0.0.1") (start-port 9105) (end-port 9115))
|
|
"Try to connect to daemon once across START-PORT to END-PORT.
|
|
Returns T on success, nil on failure. Does NOT wait or retry."
|
|
(loop for port from start-port to end-port
|
|
do (handler-case
|
|
(let ((s (usocket:socket-connect host port :timeout 2)))
|
|
(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 () nil)
|
|
(error (c) nil)))
|
|
nil)
|
|
|
|
(defun disconnect-daemon ()
|
|
(when (st :stream)
|
|
(ignore-errors (close (st :stream)))
|
|
(setf (st :stream) nil (st :connected) nil)
|
|
(add-msg :system (format nil "* Disconnected [now=~a] *" (now)))))
|
|
#+END_SRC
|
|
|
|
** Main Loop
|
|
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
|
|
|
|
;; 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))
|
|
(unified-menu-show)))
|
|
(:ctrl+b (lambda (e) (declare (ignore e))
|
|
(setf (st :sidebar-mode)
|
|
(case (st :sidebar-mode)
|
|
(:auto :visible)
|
|
(:visible :hidden)
|
|
(:hidden :auto)))
|
|
(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/E/U/W/K handled by text-input widget)
|
|
(:ctrl+y (lambda (e) (declare (ignore e))
|
|
(let ((killed (st :kill-ring)))
|
|
(when killed
|
|
(let ((cur (input-text)))
|
|
(setf (input-text) (concatenate 'string cur killed)))
|
|
(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 (string= "" (input-text))
|
|
(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))
|
|
(let ((cur (input-text)))
|
|
(setf (input-text) (concatenate 'string cur (string #\Newline))))
|
|
(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
|
|
(:ppage (lambda (e) (declare (ignore e)) (handle-ppage)))
|
|
(:npage (lambda (e) (declare (ignore e)) (handle-npage)))))
|
|
|
|
(defvar *cat-proc* nil "Cat subprocess for keyboard input (unused — direct stdin reads)")
|
|
(defvar *tty-in* nil "Stream from cat subprocess stdout (unused — direct stdin reads)")
|
|
|
|
(defun make-text-input-with-callbacks ()
|
|
"Create a text-input widget with the standard passepartout callbacks."
|
|
(cl-tty.input:make-text-input
|
|
:on-submit #'handle-submit
|
|
:on-cancel #'handle-cancel
|
|
:on-tab #'handle-tab
|
|
:on-history #'handle-history))
|
|
|
|
(defun tui-main ()
|
|
(init-state)
|
|
(setf (st :text-input) (make-text-input-with-callbacks))
|
|
(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))
|
|
;; Quick sync connect attempt (just 3 ports, 6s max)
|
|
(let ((connected (connect-daemon "127.0.0.1" 9105 9107)))
|
|
(unless connected
|
|
(add-msg :system "* Daemon not found — will retry in background... *")))
|
|
(when (> swank-port 0)
|
|
(handler-case
|
|
(progn
|
|
(ql:quickload :swank :silent t)
|
|
(let ((*standard-output* (make-string-output-stream))
|
|
(*error-output* (make-string-output-stream)))
|
|
(funcall (find-symbol "CREATE-SERVER" "SWANK")
|
|
:port swank-port :dont-close t))
|
|
(values))
|
|
(error ()
|
|
(add-msg :system "* Swank unavailable *"))))
|
|
(cl-tty.backend:with-terminal (be w h)
|
|
;; stty -icanon -echo -ixon is set by the bash script.
|
|
;; We read directly from SBCL's stdin (fd 0) since the
|
|
;; terminal is in raw mode — no cat subprocess needed.
|
|
;; Initial dirty all to trigger first redraw in loop
|
|
(setq w (or (and (numberp w) (> w 0) w) 80)
|
|
h (or (and (numberp h) (> h 0) h) 24))
|
|
;; Retry daemon connection in background if sync attempt failed
|
|
(unless (st :connected)
|
|
(add-msg :system "* Connecting to daemon... *")
|
|
(bt:make-thread
|
|
(lambda ()
|
|
(loop while (and (st :running) (not (st :connected)))
|
|
do (connect-daemon)
|
|
(unless (st :connected) (sleep 5))))
|
|
:name "daemon-auto-connect"))
|
|
;; Initial render before first read-event (which may block)
|
|
(unless (st :dialog-stack)
|
|
(redraw 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 *"))))
|
|
|
|
|
|
;; Keyboard reader via cl-tty.input:read-event (handles CSI, SS3, UTF-8, resize)
|
|
(handler-case
|
|
(multiple-value-bind (ev resize-data)
|
|
(cl-tty.input:read-event be :timeout 0.1)
|
|
(cond
|
|
((eq ev :resize)
|
|
(let ((new-size resize-data))
|
|
(setq w (car new-size) h (cdr new-size))
|
|
(setf (st :dirty) (list t t t))))
|
|
((cl-tty.input:key-event-p ev)
|
|
(process-key-event ev))))
|
|
(error (c)
|
|
(add-msg :system (format nil "* Reader error: ~a *" c))))
|
|
;; 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))
|
|
(unless (st :dialog-stack)
|
|
(redraw be w h))
|
|
(let ((ds (st :dialog-stack)))
|
|
(when ds
|
|
(cl-tty.backend:begin-sync be)
|
|
(let* ((chat-w (- w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0)))
|
|
(dlg (car ds))
|
|
(sel (cl-tty.dialog:dialog-content dlg))
|
|
(filtered (cl-tty.dialog:select-filtered-options sel))
|
|
(cnt (length filtered))
|
|
(mh (min 15 (1+ cnt)))
|
|
(panel-top (input-panel-top chat-w h))
|
|
(top (max 0 (- panel-top mh))))
|
|
(cl-tty.dialog:render-select-minibuffer
|
|
be 0 top chat-w (- h top) sel
|
|
(cl-tty.dialog:dialog-title dlg)
|
|
(list :bg-panel (theme-color :bg-panel)
|
|
:separator (theme-color :separator)
|
|
:accent (theme-color :accent)
|
|
:text-muted (theme-color :text-muted)
|
|
:agent-fg (theme-color :agent-fg)
|
|
:input-fg (theme-color :input-fg)
|
|
:bg-input (theme-color :bg-input)
|
|
:input-prompt (theme-color :input-prompt))))
|
|
(cl-tty.backend:end-sync be))
|
|
(sleep 0.1)))
|
|
(progn (disconnect-daemon)))))
|
|
#+END_SRC
|
|
|
|
* Test Suite
|
|
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
|
|
(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)
|
|
|
|
;; Test helpers: concise wrappers over process-key-event
|
|
(defun simulate-typing (string)
|
|
(dolist (ch (coerce string 'list))
|
|
(passepartout.channel-tui::process-key-event
|
|
(cl-tty.input:make-key-event
|
|
:key (intern (string ch) :keyword) :code (char-code ch)))))
|
|
|
|
(defun simulate-key (key &optional code)
|
|
(passepartout.channel-tui::process-key-event
|
|
(cl-tty.input:make-key-event :key key :code (or code 0))))
|
|
|
|
(defun simulate-ctrl (key)
|
|
(passepartout.channel-tui::process-key-event
|
|
(cl-tty.input:make-key-event
|
|
:key key :ctrl t :code (- (char-code key) 64))))
|
|
|
|
(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-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)
|
|
(simulate-typing "hello")
|
|
(simulate-key :enter)
|
|
(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: *theme* provides color mappings via theme-color."
|
|
(fiveam:is (string= "#fab283" (theme-color :user-fg)))
|
|
(fiveam:is (string= "#e8e8e8" (theme-color :agent-fg)))
|
|
(fiveam:is (string= "#808080" (theme-color :system)))
|
|
(fiveam:is (string= "#e8e8e8" (theme-color :input-fg)))
|
|
(fiveam:is (string= "#FFFFFF" (theme-color :unknown-role))))
|
|
|
|
(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)
|
|
(simulate-typing "/theme ")
|
|
(simulate-key :tab)
|
|
(fiveam:is (search "amber" (input-text) :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")))
|
|
(simulate-key :escape)
|
|
(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)
|
|
(simulate-key :escape)
|
|
(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")
|
|
(simulate-key :tab)
|
|
(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")))
|
|
(simulate-typing "/approve HITL-test")
|
|
(simulate-key :enter)
|
|
;; 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")))
|
|
(simulate-typing "/deny HITL-deny")
|
|
(simulate-key :enter)
|
|
(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)
|
|
(simulate-typing "/approve HITL-abcd")
|
|
(simulate-key :enter)
|
|
;; 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)
|
|
(simulate-typing "/deny HITL-xyz")
|
|
(simulate-key :enter)
|
|
(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)
|
|
(simulate-typing "/undo")
|
|
(simulate-key :enter)
|
|
(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)
|
|
(simulate-typing "/redo")
|
|
(simulate-key :enter)
|
|
(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")))
|
|
(simulate-typing "/why")
|
|
(simulate-key :enter)
|
|
(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)
|
|
(simulate-typing "/why")
|
|
(simulate-key :enter)
|
|
(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")
|
|
(simulate-typing "/search hello")
|
|
(simulate-key :enter)
|
|
(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")
|
|
(simulate-typing "/search test")
|
|
(simulate-key :enter)
|
|
(fiveam:is (eq t (st :search-mode)))
|
|
(simulate-key :escape) ;; 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")
|
|
(simulate-typing "/search hello")
|
|
(simulate-key :enter)
|
|
(fiveam:is (= 0 (st :search-match-idx)))
|
|
(simulate-key :down) ;; Down
|
|
(fiveam:is (= 1 (st :search-match-idx)))
|
|
(simulate-key :up) ;; Up
|
|
(fiveam:is (= 0 (st :search-match-idx)))
|
|
(simulate-key :up) ;; 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")
|
|
(simulate-typing "/context")
|
|
(simulate-key :enter)
|
|
(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)
|
|
(simulate-typing "/help configuration")
|
|
(simulate-key :enter)
|
|
(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)
|
|
(simulate-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)
|
|
(simulate-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))))
|
|
#+END_SRC
|