type / to open command palette; fix missing paren in process-key-event
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.
This commit is contained in:
@@ -72,6 +72,23 @@ Event handlers + daemon I/O + main loop.
|
||||
(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)."
|
||||
@@ -83,20 +100,7 @@ Returns two values: new-text and new-cursor-pos (or nil if no completion)."
|
||||
(progn (add-msg :system (format nil "Opening ~a" (st :url-buffer)))
|
||||
(setf (st :url-buffer) nil)
|
||||
nil)
|
||||
(let ((url nil))
|
||||
(loop for i from (1- (length (st :messages))) downto 0
|
||||
for msg = (aref (st :messages) i)
|
||||
for content = (getf msg :content)
|
||||
for role = (getf msg :role)
|
||||
while (eq role :agent)
|
||||
when content
|
||||
do (let ((pos (or (search "https://" content) (search "http://" content))))
|
||||
(when pos
|
||||
(let ((end (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab))
|
||||
content :start pos)
|
||||
(length content))))
|
||||
(setf url (subseq content pos end))
|
||||
(return)))))
|
||||
(let ((url (extract-url-from-messages)))
|
||||
(when url
|
||||
(setf (st :url-buffer) url)
|
||||
(add-msg :system (format nil "Press Tab to open ~a" url))
|
||||
@@ -150,7 +154,7 @@ Returns two values: new-text and new-cursor-pos (or nil if no completion)."
|
||||
(if (member match '("/eval" "/focus" "/scope") :test #'string=)
|
||||
(values (concatenate 'string match " "))
|
||||
(values match)))))
|
||||
(t nil))))
|
||||
(t nil)))
|
||||
|
||||
|
||||
(defun handle-history (direction)
|
||||
@@ -191,16 +195,150 @@ Returns two values: new-text and new-cursor-pos (or nil if no movement)."
|
||||
(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
|
||||
((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"))
|
||||
((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)))
|
||||
@@ -211,91 +349,20 @@ Called from handle-submit."
|
||||
(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)))
|
||||
((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))
|
||||
(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."))))
|
||||
((> (length text) 8)
|
||||
(when (string-equal (subseq text 0 8) "/search ")
|
||||
(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))))))
|
||||
((string-equal text "/help")
|
||||
(add-msg :system "Commands:") (add-msg :system "/undo /redo /reconnect /focus /scope /unfocus /theme /why /quit /help Ctrl+G"))
|
||||
((string-equal text "/theme")
|
||||
(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"))
|
||||
(cmd-search text)))
|
||||
((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" name)))))
|
||||
((string-equal text "/eval")
|
||||
(add-msg :system "Usage: /eval (expr) Evaluate Lisp"))
|
||||
(cmd-theme-set text))
|
||||
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/eval ") (> (length text) 6))
|
||||
(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))))))
|
||||
((string-equal text "/audit")
|
||||
(add-msg :system "/audit <id> Inspect memory. /audit verify check integrity."))
|
||||
(cmd-eval text))
|
||||
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit "))
|
||||
(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)))))))
|
||||
((string-equal text "/sessions")
|
||||
(let* ((snaps (passepartout::snapshot-list)) (count (length snaps)))
|
||||
(add-msg :system (format nil "Snapshots: ~d. /rewind <n> /resume <n>" count))))
|
||||
(cmd-audit text))
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind "))
|
||||
(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>"))))
|
||||
(cmd-rewind text))
|
||||
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/resume "))
|
||||
(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>"))))
|
||||
((or (string-equal text "/q") (string-equal text "/quit"))
|
||||
(save-history)
|
||||
(add-msg :system "* Goodbye *")
|
||||
(send-daemon (list :type :event :payload '(:action :quit)))
|
||||
(setf (st :running) nil))
|
||||
((string-equal text "/reconnect")
|
||||
(disconnect-daemon) (add-msg :system "* Reconnecting... *") (connect-daemon)
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
((string-equal text "/context")
|
||||
(add-msg :system "Context summary: /context why <id> or /context dropped"))
|
||||
((string-equal text "/tags")
|
||||
(let ((tags (or (uiop:getenv "TAG_CATEGORIES") (uiop:getenv "PRIVACY_FILTER_TAGS") "@personal")))
|
||||
(add-msg :system (format nil "Tags: ~a" tags))))
|
||||
(t
|
||||
(add-msg :user text)
|
||||
(setf (st :busy) t)
|
||||
(send-daemon (list :type :event :payload (list :sensor :user-input :text text)))))))
|
||||
(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
|
||||
@@ -484,6 +551,15 @@ supplied (e.g. \"/\"), pre-fill the select filter with it."
|
||||
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
|
||||
@@ -519,12 +595,17 @@ supplied (e.g. \"/\"), pre-fill the select filter with it."
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
((member k '(:ppage :npage))
|
||||
(if (eq k :ppage) (handle-ppage) (handle-npage)))
|
||||
(t (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))))))))
|
||||
(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.
|
||||
@@ -618,7 +699,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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))))
|
||||
(: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)")
|
||||
@@ -682,51 +763,9 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
((eq (getf ev :type) :disconnected)
|
||||
(setf (st :connected) nil
|
||||
(st :busy) nil)
|
||||
(add-msg :system "* Connection lost — type /reconnect to retry *"))
|
||||
((eq (getf ev :type) :key)
|
||||
(let* ((payload (getf ev :payload))
|
||||
(ch (getf payload :ch)))
|
||||
(case ch
|
||||
(:CTRL-Q (setf (st :running) nil))
|
||||
(:CTRL-P (unified-menu-show))
|
||||
(:CTRL-B (setf (st :sidebar-mode)
|
||||
(case (st :sidebar-mode)
|
||||
(:auto :visible)
|
||||
(:visible :hidden)
|
||||
(:hidden :auto)))
|
||||
(setf (st :dirty) (list t t t)))
|
||||
(:CTRL-L (setf (st :dirty) (list t t t)))
|
||||
(t (if (st :dialog-stack)
|
||||
(let* ((dlg (car (st :dialog-stack)))
|
||||
(sel (cl-tty.dialog:dialog-content dlg)))
|
||||
(cond
|
||||
((eql ch :escape)
|
||||
(pop (st :dialog-stack))
|
||||
(setf (st :dirty) (list t t nil)))
|
||||
((member ch '(:up :down))
|
||||
(if (eql ch :up)
|
||||
(cl-tty.dialog:select-prev sel)
|
||||
(cl-tty.dialog:select-next sel)))
|
||||
((member ch '(:enter))
|
||||
(let* ((filtered (cl-tty.dialog:select-filtered-options sel))
|
||||
(idx (cl-tty.dialog:select-selected-index sel))
|
||||
(item (when (< idx (length filtered))
|
||||
(third (nth idx filtered)))))
|
||||
(when item
|
||||
(let ((cb (cl-tty.dialog:select-on-select sel)))
|
||||
(when cb (funcall cb item))))))
|
||||
((let ((chr (if (characterp ch) ch (code-char ch))))
|
||||
(and chr (graphic-char-p chr))
|
||||
(setf (cl-tty.dialog:select-filter sel)
|
||||
(concatenate 'string
|
||||
(or (cl-tty.dialog:select-filter sel) "")
|
||||
(string chr)))))
|
||||
((member ch '(:backspace))
|
||||
(let ((f (cl-tty.dialog:select-filter sel)))
|
||||
(when (> (length f) 0)
|
||||
(setf (cl-tty.dialog:select-filter sel)
|
||||
(subseq f 0 (1- f))))))))
|
||||
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)
|
||||
@@ -747,59 +786,27 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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))
|
||||
(sel-idx (cl-tty.dialog:select-selected-index sel))
|
||||
(cnt (length filtered))
|
||||
(filter (cl-tty.dialog:select-filter sel))
|
||||
(mh (min 15 (+ 1 cnt)))
|
||||
(panel-top (passepartout.channel-tui:input-panel-top chat-w h))
|
||||
(top (max 0 (- panel-top mh)))
|
||||
(bg-p (theme-color :bg-panel))
|
||||
(sep-c (theme-color :separator)))
|
||||
;; Fill minibuffer area with panel bg
|
||||
(dotimes (r (min (- h 3 top) h))
|
||||
(cl-tty.backend:draw-rect be 0 (+ top r) chat-w 1 :bg bg-p))
|
||||
;; Top separator
|
||||
(cl-tty.backend:draw-text be 0 top
|
||||
(make-string chat-w :initial-element #\─)
|
||||
sep-c bg-p)
|
||||
(cl-tty.backend:draw-text be 1 top
|
||||
(cl-tty.dialog:dialog-title dlg)
|
||||
(theme-color :accent) bg-p)
|
||||
;; Options
|
||||
(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 (or sel-idx 0)))
|
||||
(text (if cat (format nil " ~a" title)
|
||||
(format nil " ~a" title)))
|
||||
(row (+ top y-off)))
|
||||
(when (>= row (1- h)) (return))
|
||||
(cond
|
||||
(sel-p
|
||||
(cl-tty.backend:draw-rect be 1 row (1- chat-w) 1
|
||||
:bg (theme-color :input-fg))
|
||||
(cl-tty.backend:draw-text be 1 row (format nil " >> ~a" title)
|
||||
(theme-color :bg-input) (theme-color :input-fg)))
|
||||
(cat
|
||||
(cl-tty.backend:draw-text be 1 row text
|
||||
(theme-color :text-muted) bg-p))
|
||||
(t
|
||||
(cl-tty.backend:draw-text be 1 row text
|
||||
(theme-color :agent-fg) bg-p)))
|
||||
(incf y-off))))
|
||||
(cl-tty.backend:draw-rect be 0 (- h 3) chat-w 1 :bg bg-p)
|
||||
(cl-tty.backend:draw-text be 0 (- h 3)
|
||||
(format nil "> ~a" (or filter ""))
|
||||
(theme-color :input-prompt) bg-p))
|
||||
(cl-tty.backend:end-sync be))
|
||||
(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
|
||||
@@ -818,6 +825,22 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
@@ -866,9 +889,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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")))
|
||||
@@ -905,8 +927,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(simulate-typing "/theme ")
|
||||
(simulate-key :tab)
|
||||
(fiveam:is (search "amber" (input-text) :test #'char-equal)))
|
||||
|
||||
;; ── v0.7.1 Streaming ──
|
||||
@@ -937,7 +959,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
"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)
|
||||
(simulate-key :escape)
|
||||
(let ((msg (aref (st :messages) 0)))
|
||||
(fiveam:is (stringp (getf msg :time)))
|
||||
(fiveam:is (search "[interrupted]" (getf msg :content)))
|
||||
@@ -947,7 +969,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(fiveam:test test-stream-check-skip
|
||||
"Contract/v0.7.1: Esc without active streaming does nothing."
|
||||
(init-state)
|
||||
(on-key 27)
|
||||
(simulate-key :escape)
|
||||
(fiveam:is (null (st :streaming-text)))
|
||||
(fiveam:is (= 0 (length (st :messages)))))
|
||||
|
||||
@@ -955,7 +977,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
"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)
|
||||
(simulate-key :tab)
|
||||
(fiveam:is (string= "https://example.com" (st :url-buffer))))
|
||||
|
||||
;; ── v0.7.2 HITL Panels ──
|
||||
@@ -977,9 +999,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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))
|
||||
@@ -993,9 +1014,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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)))))
|
||||
@@ -1003,9 +1023,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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))
|
||||
@@ -1016,9 +1035,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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)))))
|
||||
@@ -1028,9 +1046,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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)))))
|
||||
@@ -1038,9 +1055,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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)))))
|
||||
@@ -1051,9 +1067,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
"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)
|
||||
(simulate-typing "/why")
|
||||
(simulate-key :enter)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs (1- (length msgs)))))
|
||||
(fiveam:is (eq :system (getf m :role)))
|
||||
@@ -1063,9 +1078,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(simulate-typing "/why")
|
||||
(simulate-key :enter)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs (1- (length msgs)))))
|
||||
(fiveam:is (search "No recent" (getf m :content)))))
|
||||
@@ -1102,9 +1116,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(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)))))
|
||||
@@ -1113,11 +1126,10 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
"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)
|
||||
(simulate-typing "/search test")
|
||||
(simulate-key :enter)
|
||||
(fiveam:is (eq t (st :search-mode)))
|
||||
(on-key 27) ;; Escape
|
||||
(simulate-key :escape) ;; Escape
|
||||
(fiveam:is (null (st :search-mode))))
|
||||
|
||||
(fiveam:test test-search-mode-up-down-nav
|
||||
@@ -1126,24 +1138,22 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(simulate-typing "/search hello")
|
||||
(simulate-key :enter)
|
||||
(fiveam:is (= 0 (st :search-match-idx)))
|
||||
(on-key 258) ;; Down
|
||||
(simulate-key :down) ;; Down
|
||||
(fiveam:is (= 1 (st :search-match-idx)))
|
||||
(on-key 259) ;; Up
|
||||
(simulate-key :up) ;; Up
|
||||
(fiveam:is (= 0 (st :search-match-idx)))
|
||||
(on-key 259) ;; Up (clamped)
|
||||
(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")
|
||||
(dolist (ch (coerce "/context" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(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))
|
||||
@@ -1152,9 +1162,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(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)
|
||||
(simulate-typing "/help configuration")
|
||||
(simulate-key :enter)
|
||||
(let ((msgs (st :messages)))
|
||||
(fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs))))
|
||||
|
||||
@@ -1163,7 +1172,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(init-state)
|
||||
(dotimes (i 30) (add-msg :system (format nil "msg ~d" i)))
|
||||
(setf (st :scroll-offset) 0)
|
||||
(on-key :ppage)
|
||||
(simulate-key :ppage)
|
||||
(fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines"))
|
||||
|
||||
(fiveam:test test-pads-page-down-clamp
|
||||
@@ -1171,7 +1180,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
|
||||
(init-state)
|
||||
(dotimes (i 5) (add-msg :system (format nil "msg ~d" i)))
|
||||
(setf (st :scroll-offset) 3)
|
||||
(on-key :npage)
|
||||
(simulate-key :npage)
|
||||
(fiveam:is (= 0 (st :scroll-offset))))
|
||||
|
||||
;; ── v0.8.0 Minibuffer ──
|
||||
|
||||
Reference in New Issue
Block a user