From a64532bc9639f47d7b35e2a7fbb0cf5b7cb966ac Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Wed, 20 May 2026 14:57:26 -0400 Subject: [PATCH] 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. --- org/channel-tui-main.org | 523 +++++++++++++++++++------------------- org/channel-tui-state.org | 4 +- 2 files changed, 268 insertions(+), 259 deletions(-) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index e617904..d5f0355 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -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 ) 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 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 /resume " 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 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 ")))) + +(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 ")))) + +(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 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 /resume " 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 ")))) + (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 ")))) - ((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 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 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 ── diff --git a/org/channel-tui-state.org b/org/channel-tui-state.org index 72d50da..8f2c886 100644 --- a/org/channel-tui-state.org +++ b/org/channel-tui-state.org @@ -24,8 +24,8 @@ All state mutation flows through event handlers in the controller. :queue-event :drain-queue :init-state :view-status :view-chat :view-input :redraw :input-panel-top - :on-key :on-daemon-msg :send-daemon - :connect-daemon :disconnect-daemon + :on-key :process-key-event :input-text :on-daemon-msg :send-daemon + :connect-daemon :disconnect-daemon :*theme* :theme-color :theme-switch)) (in-package :passepartout.channel-tui)