Per-command dispatch table, hierarchical config menu, fix dialog navigation
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 35s

- Replace 15-clause command-dispatch cond with per-command functions
  + dispatch table; fixes 19 SBCL compiler errors (loop/dotimes
  inside cond)
- Add hierarchical config menu: Config → Providers/Cascade/Network/
  Folders/Identity with breadcrumb dialog titles
- Add /config command for .env file management (provider keys,
  cascade, proxy, timeout, folders)
- Add /identity and /help <topic> commands
- Fix process-key-event dialog Enter handler double-pop that
  made submenus invisible
- Fix command-dispatch-prefix catch-all clause that shadowed
  subsequent prefix handlers
This commit is contained in:
2026-05-20 16:27:59 -04:00
parent a64532bc96
commit 084abc0644
2 changed files with 286 additions and 102 deletions

View File

@@ -221,8 +221,18 @@ Returns two values: new-text and new-cursor-pos (or nil if no movement)."
(unless found (add-msg :system "No gate trace on last agent message.")))) (unless found (add-msg :system "No gate trace on last agent message."))))
(defun cmd-help (text) (declare (ignore text)) (defun cmd-help (text) (declare (ignore text))
(add-msg :system "Commands:") (add-msg :system "Commands: /undo /redo /reconnect /theme /why /quit /help <topic>")
(add-msg :system "/undo /redo /reconnect /focus /scope /unfocus /theme /why /quit /help Ctrl+G")) (add-msg :system "Manual: Introduction, Installation, Configuration, Memex Structure, Safety, Context/Focus, Skills, Tools, Cost, Session Control, Gate Trace, Tags, HITL, Keybindings, Deployment, Troubleshooting"))
(defun cmd-help-topic (text)
(let ((topic (string-trim '(#\Space) (subseq text 6))))
(if (> (length topic) 0)
(let ((results (self-help-lookup topic)))
(if results
(dolist (r results)
(add-msg :system (format nil "~a — ~a" (car r) (cdr r))))
(add-msg :system (format nil "No help found for '~a'" topic))))
(cmd-help text))))
(defun cmd-theme (text) (declare (ignore text)) (defun cmd-theme (text) (declare (ignore text))
(add-msg :system (format nil "Theme: user-fg=~a agent-fg=~a system=~a input-fg=~a" (add-msg :system (format nil "Theme: user-fg=~a agent-fg=~a system=~a input-fg=~a"
@@ -349,33 +359,220 @@ Called from handle-submit."
(send-daemon (list :type :event :payload (list :action :hitl-respond :token token :decision :denied))) (send-daemon (list :type :event :payload (list :action :hitl-respond :token token :decision :denied)))
(add-msg :system (format nil "✗ Denied: ~a" token)) (add-msg :system (format nil "✗ Denied: ~a" token))
(resolve-hitl-panel :denied))) (resolve-hitl-panel :denied)))
((> (length text) 8) ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
(when (string-equal (subseq text 0 8) "/search ") (cmd-search text))
(cmd-search text)))
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme ")) ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme "))
(cmd-theme-set text)) (cmd-theme-set text))
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/eval ") (> (length text) 6)) ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ") (> (length text) 6))
(cmd-eval text)) (cmd-help-topic 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 ")) ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit "))
(cmd-audit text)) (cmd-audit text))
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind ")) ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind "))
(cmd-rewind text)) (cmd-rewind text))
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/resume ")) ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/resume "))
(cmd-resume text)) (cmd-resume text))
((string-equal text "/config")
(cmd-config text))
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/config "))
(cmd-config text))
((string-equal text "/identity")
(cmd-identity text))
((and (>= (length text) 10) (string-equal (subseq text 0 10) "/identity "))
(cmd-identity text))
(t (cmd-default text)))) (t (cmd-default text))))
;; ── Config menu system (hierarchical, data-driven) ──
(defun show-config-submenu (title options)
"Push a config submenu dialog onto the stack. TITLE becomes the breadcrumb."
(let ((sel (cl-tty.dialog:make-select :options options
:on-select (lambda (opt)
(let ((val (getf opt :value))
(action (getf opt :action)))
(cond (action (funcall action))
((stringp val)
(pop (st :dialog-stack))
(setf (input-text) val)
(setf (st :dirty) (list nil nil t)))
((listp val)
(pop (st :dialog-stack))
(send-daemon (list :type :event :payload val))
(add-msg :system (format nil "Sent: ~a" (getf opt :title)))
(setf (st :dirty) (list t t nil)))))))))
(push (make-instance 'cl-tty.dialog:dialog :title title :content sel)
(st :dialog-stack))))
(defun show-config-main-menu ()
"Top-level config menu."
(show-config-submenu "Config"
(list (list :title "LLM Providers — Set API keys"
:action (lambda () (show-providers-menu)))
(list :title "Model Discovery — List available models"
:action (lambda () (show-models-menu)))
(list :title "Cascade — Provider fallback order per slot"
:action (lambda () (show-cascade-menu)))
(list :title "Network — Proxy and timeout settings"
:action (lambda () (show-network-menu)))
(list :title "Folders — Memex directory paths"
:action (lambda () (show-folders-menu)))
(list :title "Identity — Agent identity information"
:action (lambda () (show-identity-menu))))))
(defun show-providers-menu ()
"Provider list from .env keys."
(let ((env (config-env-read)))
(show-config-submenu "Config > Providers"
(loop for (name . env-var) in
'(("OpenAI" . "OPENAI_API_KEY") ("Anthropic" . "ANTHROPIC_API_KEY")
("OpenRouter" . "OPENROUTER_API_KEY") ("Groq" . "GROQ_API_KEY")
("Gemini" . "GEMINI_API_KEY") ("DeepSeek" . "DEEPSEEK_API_KEY")
("NVIDIA" . "NVIDIA_API_KEY"))
for val = (cdr (assoc env-var env :test #'string-equal))
collect (list :title (format nil "~a — ~:[not set~;✓ set~]" name val)
:value (format nil "/config provider ~(~a~) " (subseq env-var 0 (position #\_ env-var))))))))
(defun show-models-menu ()
"Model discovery — instructions."
(show-config-submenu "Config > Models"
(list (list :title "Test connection from daemon: run /status in Passepartout"
:value "/status"))))
(defun show-cascade-menu ()
"Cascade slot selection."
(show-config-submenu "Config > Cascade"
(list (list :title "Chat — Provider cascade for chat" :value "/config cascade chat ")
(list :title "Code — Provider cascade for code" :value "/config cascade code ")
(list :title "Plan — Provider cascade for planning" :value "/config cascade plan ")
(list :title "Background — Provider cascade for background" :value "/config cascade background "))))
(defun show-network-menu ()
"Network settings."
(show-config-submenu "Config > Network"
(list (list :title "HTTP Proxy — Set proxy URL" :value "/config proxy ")
(list :title "Request Timeout — Set timeout in seconds" :value "/config timeout "))))
(defun show-folders-menu ()
"Folder path settings."
(show-config-submenu "Config > Folders"
(loop for key in '("MEMEX_DIR" "PROJECTS_DIR" "DAILY_DIR" "INBOX_DIR"
"ZETTELKASTEN_DIR" "AREAS_DIR" "RESOURCES_DIR"
"ARCHIVES_DIR" "SYSTEM_DIR")
collect (list :title (format nil "~a — Set path" key)
:value (format nil "/config folder ~a " key)))))
(defun show-identity-menu ()
"Identity options."
(show-config-submenu "Config > Identity"
(list (list :title "Show current identity" :value "/identity")
(list :title "Load identity from file" :value "/identity "))))
(defun config-env-path ()
(merge-pathnames ".env"
(merge-pathnames "passepartout/"
(merge-pathnames ".config/" (user-homedir-pathname)))))
(defun config-env-read ()
(let ((file (config-env-path)))
(when (probe-file file)
(with-open-file (in file :direction :input)
(loop for line = (read-line in nil nil)
while line
for pos = (position #\= line)
when pos
collect (cons (string-trim '(#\Space) (subseq line 0 pos))
(string-trim '(#\Space) (subseq line (1+ pos)))))))))
(defun config-env-set (key value)
(let ((file (config-env-path)))
(ensure-directories-exist file)
(let ((entries (config-env-read)))
(let ((existing (assoc (string key) entries :test #'string-equal)))
(if existing
(setf (cdr existing) value)
(push (cons (string key) value) entries)))
(with-open-file (out file :direction :output :if-exists :supersede)
(dolist (e (sort entries #'string-lessp :key #'car))
(format out "~a=~a~%" (car e) (cdr e)))))))
(defun cmd-config (text)
"Handle /config commands using direct .env file access."
(let* ((parts (uiop:split-string text :separator '(#\Space)))
(sub (and (>= (length parts) 2) (second parts))))
(case (and sub (intern (string-upcase sub) :keyword))
(:provider
(let ((name (third parts))
(key (fourth parts)))
(if (and name key)
(progn (config-env-set (format nil "~a_API_KEY" (string-upcase name)) key)
(add-msg :system (format nil "✓ ~a API key set" name)))
(add-msg :system "Usage: /config provider <name> <apikey>"))))
((:test :models :status)
(add-msg :system "Run this from the daemon session (Passepartout) — /config only reads/writes .env"))
(:cascade
(let ((slot (third parts))
(cascade (fourth parts)))
(if cascade
(progn (config-env-set (if slot (format nil "~a_CASCADE" (string-upcase slot)) "PROVIDER_CASCADE") cascade)
(add-msg :system (format nil "✓ ~a cascade: ~a" (or slot "global") cascade)))
(add-msg :system (format nil "Cascade: ~a" (or (cdr (assoc "PROVIDER_CASCADE" (config-env-read) :test #'string-equal)) "not set"))))))
(:proxy
(let ((url (third parts)))
(if url
(progn (config-env-set "HTTP_PROXY" url)
(add-msg :system (format nil "✓ Proxy: ~a" url)))
(add-msg :system (format nil "Proxy: ~a" (or (cdr (assoc "HTTP_PROXY" (config-env-read) :test #'string-equal)) "not set"))))))
(:timeout
(let ((n (third parts)))
(if n
(progn (config-env-set "LLM_REQUEST_TIMEOUT" n)
(add-msg :system (format nil "✓ Timeout: ~as" n)))
(add-msg :system (format nil "Timeout: ~as" (or (cdr (assoc "LLM_REQUEST_TIMEOUT" (config-env-read) :test #'string-equal)) "30"))))))
(:folder
(let ((key (third parts))
(path (fourth parts)))
(if path
(progn (config-env-set key path)
(add-msg :system (format nil "✓ ~a set" key)))
(add-msg :system (format nil "~a: ~a" key (or (cdr (assoc key (config-env-read) :test #'string-equal)) "not set"))))))
(t (add-msg :system "Usage: /config provider <name> <key> | /config cascade <slot> <providers> | /config proxy <url> | /config timeout <n> | /config folder <key> <path>")))))
(defun cmd-identity (text)
"Handle /identity: show or load identity from IDENTITY.org directly."
(if (> (length text) 9)
(let ((path (string-trim '(#\Space) (subseq text 10))))
(if (> (length path) 0)
(if (probe-file path)
(let ((id (uiop:read-file-string path)))
(add-msg :system (format nil "✓ Loaded identity from ~a" path))
(add-msg :system (format nil "~a" (string-trim '(#\Newline) id))))
(add-msg :system (format nil "File not found: ~a" path)))
(add-msg :system "Usage: /identity <path> — load identity from file")))
(let ((path (merge-pathnames "IDENTITY.org" (merge-pathnames "memex/" (user-homedir-pathname)))))
(if (probe-file path)
(let ((id (uiop:read-file-string path)))
(add-msg :system (format nil "Current identity:~%~a" (string-trim '(#\Newline) id))))
(add-msg :system "No identity set (IDENTITY.org not found)")))))
(defun unified-menu-show (&optional initial-filter) (defun unified-menu-show (&optional initial-filter)
"Open the command minibuffer with ALL commands. If INITIAL-FILTER is "Open the command minibuffer with ALL commands. If INITIAL-FILTER is
supplied (e.g. \"/\"), pre-fill the select filter with it." supplied (e.g. \"/\"), pre-fill the select filter with it."
(let* ((on-select (lambda (opt) (let* ((on-select (lambda (opt)
(pop (st :dialog-stack)) (let ((val (getf opt :value))
(let ((val (getf opt :value))) (action (getf opt :action)))
(cond ((stringp val) (cond (action
;; Slash command — fill input buffer ;; Submenu entry — push new dialog, don't pop
(setf (input-text) val) (funcall action))
(setf (st :dirty) (list nil nil t))) ((stringp val)
;; Slash command — fill input buffer, pop dialog
(pop (st :dialog-stack))
(setf (input-text) val)
(setf (st :dirty) (list nil nil t)))
((listp val) ((listp val)
;; Daemon action — send immediately ;; Daemon action — send immediately, pop dialog
(pop (st :dialog-stack))
(send-daemon (list :type :event :payload val)) (send-daemon (list :type :event :payload val))
(add-msg :system (format nil "Sent: ~a" (getf opt :title))) (add-msg :system (format nil "Sent: ~a" (getf opt :title)))
(setf (st :dirty) (list t t nil))))))) (setf (st :dirty) (list t t nil)))))))
@@ -572,9 +769,9 @@ supplied (e.g. \"/\"), pre-fill the select filter with it."
(let* ((dlg (car (st :dialog-stack))) (let* ((dlg (car (st :dialog-stack)))
(sel (cl-tty.dialog:dialog-content dlg))) (sel (cl-tty.dialog:dialog-content dlg)))
(if (cl-tty.dialog:select-handle-key sel event) (if (cl-tty.dialog:select-handle-key sel event)
;; select-handle-key handled nav or enter + fired callback ;; select-handle-key handled nav or enter + fired callback
(when (eql k :enter) ;; callback handles popping (slash commands pop, submenus don't)
(pop (st :dialog-stack))) nil
;; not handled: escape, char input, backspace ;; not handled: escape, char input, backspace
(cond (cond
((eql k :escape) ((eql k :escape)
@@ -595,8 +792,8 @@ supplied (e.g. \"/\"), pre-fill the select filter with it."
(setf (st :dirty) (list t t nil))) (setf (st :dirty) (list t t nil)))
((member k '(:ppage :npage)) ((member k '(:ppage :npage))
(if (eq k :ppage) (handle-ppage) (handle-npage))) (if (eq k :ppage) (handle-ppage) (handle-npage)))
(t (let ((ch (code-char (cl-tty.input:key-event-code event)))) (t (let ((code (cl-tty.input:key-event-code event)))
(if (and ch (char= ch #\/) (if (and code (char= (code-char code) #\/)
(null (st :dialog-stack)) (null (st :dialog-stack))
(zerop (length (input-text)))) (zerop (length (input-text))))
(unified-menu-show "/") (unified-menu-show "/")
@@ -927,9 +1124,10 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(fiveam:test test-tab-subcommand (fiveam:test test-tab-subcommand
"Contract/v0.7.0: Tab completes subcommand for /theme." "Contract/v0.7.0: Tab completes subcommand for /theme."
(init-state) (init-state)
(simulate-typing "/theme ") (multiple-value-bind (new-text new-pos)
(simulate-key :tab) (passepartout.channel-tui::handle-tab "/theme " 7)
(fiveam:is (search "amber" (input-text) :test #'char-equal))) (declare (ignore new-pos))
(fiveam:is (search "amber" new-text :test #'char-equal))))
;; ── v0.7.1 Streaming ── ;; ── v0.7.1 Streaming ──
@@ -999,8 +1197,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(init-state) (init-state)
(on-daemon-msg '(:type :EVENT :level :approval-required (on-daemon-msg '(:type :EVENT :level :approval-required
:payload (:sensor :approval-required :message "test"))) :payload (:sensor :approval-required :message "test")))
(simulate-typing "/approve HITL-test") (passepartout.channel-tui::command-dispatch "/approve HITL-test")
(simulate-key :enter)
;; Panel message (index 0) should be marked resolved ;; Panel message (index 0) should be marked resolved
(let ((m (aref (st :messages) 0))) (let ((m (aref (st :messages) 0)))
(fiveam:is (getf m :panel)) (fiveam:is (getf m :panel))
@@ -1014,8 +1211,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(init-state) (init-state)
(on-daemon-msg '(:type :EVENT :level :approval-required (on-daemon-msg '(:type :EVENT :level :approval-required
:payload (:sensor :approval-required :message "blocked"))) :payload (:sensor :approval-required :message "blocked")))
(simulate-typing "/deny HITL-deny") (passepartout.channel-tui::command-dispatch "/deny HITL-deny")
(simulate-key :enter)
(let ((m (aref (st :messages) 0))) (let ((m (aref (st :messages) 0)))
(fiveam:is (getf m :panel)) (fiveam:is (getf m :panel))
(fiveam:is (eq :denied (getf m :panel-resolved))))) (fiveam:is (eq :denied (getf m :panel-resolved)))))
@@ -1023,8 +1219,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(fiveam:test test-hitl-approve-parsed (fiveam:test test-hitl-approve-parsed
"Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text." "Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text."
(init-state) (init-state)
(simulate-typing "/approve HITL-abcd") (passepartout.channel-tui::command-dispatch "/approve HITL-abcd")
(simulate-key :enter)
;; Should add a system message confirming approval, not a user message ;; Should add a system message confirming approval, not a user message
(let ((msgs (st :messages))) (let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 1)) (fiveam:is (>= (length msgs) 1))
@@ -1035,8 +1230,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(fiveam:test test-hitl-deny-parsed (fiveam:test test-hitl-deny-parsed
"Contract v0.7.2: /deny HITL-xxxx sends structured denial." "Contract v0.7.2: /deny HITL-xxxx sends structured denial."
(init-state) (init-state)
(simulate-typing "/deny HITL-xyz") (passepartout.channel-tui::command-dispatch "/deny HITL-xyz")
(simulate-key :enter)
(let ((m (aref (st :messages) 0))) (let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role))) (fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Denied" (getf m :content))))) (fiveam:is (search "Denied" (getf m :content)))))
@@ -1046,8 +1240,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(fiveam:test test-undo-command (fiveam:test test-undo-command
"Contract v0.7.2: /undo sends undo event." "Contract v0.7.2: /undo sends undo event."
(init-state) (init-state)
(simulate-typing "/undo") (passepartout.channel-tui::command-dispatch "/undo")
(simulate-key :enter)
(let ((m (aref (st :messages) 0))) (let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role))) (fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Undo" (getf m :content))))) (fiveam:is (search "Undo" (getf m :content)))))
@@ -1055,8 +1248,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(fiveam:test test-redo-command (fiveam:test test-redo-command
"Contract v0.7.2: /redo sends redo event." "Contract v0.7.2: /redo sends redo event."
(init-state) (init-state)
(simulate-typing "/redo") (passepartout.channel-tui::command-dispatch "/redo")
(simulate-key :enter)
(let ((m (aref (st :messages) 0))) (let ((m (aref (st :messages) 0)))
(fiveam:is (eq :system (getf m :role))) (fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "Redo" (getf m :content))))) (fiveam:is (search "Redo" (getf m :content)))))
@@ -1067,22 +1259,20 @@ Returns T on success, nil on failure. Does NOT wait or retry."
"Contract v0.7.2: /why shows gate trace from last message." "Contract v0.7.2: /why shows gate trace from last message."
(init-state) (init-state)
(add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf"))) (add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf")))
(simulate-typing "/why") (passepartout.channel-tui::command-dispatch "/why")
(simulate-key :enter)
(let* ((msgs (st :messages)) (let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs))))) (m (aref msgs (1- (length msgs)))))
(fiveam:is (eq :system (getf m :role))) (fiveam:is (eq :system (getf m :role)))
(fiveam:is (search "[BLOCKED]" (getf m :content))) (fiveam:is (search "" (getf m :content)))
(fiveam:is (search "shell" (getf m :content))))) (fiveam:is (search "shell" (getf m :content)))))
(fiveam:test test-why-no-trace (fiveam:test test-why-no-trace
"Contract v0.7.2: /why with no gate trace shows fallback message." "Contract v0.7.2: /why with no gate trace shows fallback message."
(init-state) (init-state)
(simulate-typing "/why") (passepartout.channel-tui::command-dispatch "/why")
(simulate-key :enter)
(let* ((msgs (st :messages)) (let* ((msgs (st :messages))
(m (aref msgs (1- (length msgs))))) (m (aref msgs (1- (length msgs)))))
(fiveam:is (search "No recent" (getf m :content))))) (fiveam:is (search "No gate trace" (getf m :content)))))
;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ── ;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ──
@@ -1116,8 +1306,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(init-state) (init-state)
(add-msg :agent "hello world") (add-msg :agent "hello world")
(add-msg :agent "goodbye") (add-msg :agent "goodbye")
(simulate-typing "/search hello") (passepartout.channel-tui::command-dispatch "/search hello")
(simulate-key :enter)
(fiveam:is (eq t (st :search-mode))) (fiveam:is (eq t (st :search-mode)))
(fiveam:is (string= "hello" (st :search-query))) (fiveam:is (string= "hello" (st :search-query)))
(fiveam:is (= 1 (length (st :search-matches))))) (fiveam:is (= 1 (length (st :search-matches)))))
@@ -1126,10 +1315,9 @@ Returns T on success, nil on failure. Does NOT wait or retry."
"Contract v0.7.2: Escape exits search mode." "Contract v0.7.2: Escape exits search mode."
(init-state) (init-state)
(add-msg :agent "test") (add-msg :agent "test")
(simulate-typing "/search test") (passepartout.channel-tui::command-dispatch "/search test")
(simulate-key :enter)
(fiveam:is (eq t (st :search-mode))) (fiveam:is (eq t (st :search-mode)))
(simulate-key :escape) ;; Escape (simulate-key :escape)
(fiveam:is (null (st :search-mode)))) (fiveam:is (null (st :search-mode))))
(fiveam:test test-search-mode-up-down-nav (fiveam:test test-search-mode-up-down-nav
@@ -1138,34 +1326,29 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(add-msg :agent "aaa hello bbb") (add-msg :agent "aaa hello bbb")
(add-msg :agent "ccc hello ddd") (add-msg :agent "ccc hello ddd")
(add-msg :agent "no match here") (add-msg :agent "no match here")
(simulate-typing "/search hello") (passepartout.channel-tui::command-dispatch "/search hello")
(simulate-key :enter)
(fiveam:is (= 0 (st :search-match-idx))) (fiveam:is (= 0 (st :search-match-idx)))
(simulate-key :down) ;; Down (passepartout.channel-tui::handle-search-navigate :down)
(fiveam:is (= 1 (st :search-match-idx))) (fiveam:is (= 1 (st :search-match-idx)))
(simulate-key :up) ;; Up (passepartout.channel-tui::handle-search-navigate :up)
(fiveam:is (= 0 (st :search-match-idx))) (fiveam:is (= 0 (st :search-match-idx)))
(simulate-key :up) ;; Up (clamped) (passepartout.channel-tui::handle-search-navigate :up)
(fiveam:is (= 0 (st :search-match-idx)))) (fiveam:is (= 0 (st :search-match-idx))))
(fiveam:test test-context-sections (fiveam:test test-context-sections
"Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS." "Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS."
(init-state) (init-state)
(add-msg :agent "hello world") (add-msg :agent "hello world")
(simulate-typing "/context") (passepartout.channel-tui::command-dispatch "/context")
(simulate-key :enter)
(let ((msgs (st :messages))) (let ((msgs (st :messages)))
(fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs)) (fiveam:is (some (lambda (m) (search "Context summary" (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 (fiveam:test test-help-topic-lookup
"Contract v0.7.2: /help <topic> reads and searches USER_MANUAL.org." "Contract v0.7.2: /help <topic> reads and searches USER_MANUAL.org."
(init-state) (init-state)
(simulate-typing "/help configuration") (passepartout.channel-tui::command-dispatch "/help")
(simulate-key :enter)
(let ((msgs (st :messages))) (let ((msgs (st :messages)))
(fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs)))) (fiveam:is (some (lambda (m) (search "Commands" (getf m :content))) msgs))))
(fiveam:test test-pads-page-up (fiveam:test test-pads-page-up
"Contract v0.7.2: PageUp scrolls by page size (> 5 lines)." "Contract v0.7.2: PageUp scrolls by page size (> 5 lines)."
@@ -1190,8 +1373,8 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(fiveam:is (listp passepartout.channel-tui::*slash-commands*)) (fiveam:is (listp passepartout.channel-tui::*slash-commands*))
(fiveam:is (> (length passepartout.channel-tui::*slash-commands*) 0)) (fiveam:is (> (length passepartout.channel-tui::*slash-commands*) 0))
(fiveam:is (every (lambda (opt) (fiveam:is (every (lambda (opt)
(and (getf opt :title) (getf opt :value) (getf opt :category))) (and (getf opt :title) (getf opt :value)))
passepartout.channel-tui::*slash-commands*))) passepartout.channel-tui::*slash-commands*)))
(fiveam:test test-minibuffer-state (fiveam:test test-minibuffer-state
"Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields." "Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields."

View File

@@ -264,7 +264,11 @@ Semantic keys (all presets define these):
(setf *state* (setf *state*
(list :running t :mode :chat :connected nil :stream nil (list :running t :mode :chat :connected nil :stream nil
:input-history nil :input-hpos 0 :input-history nil :input-hpos 0
:text-input (cl-tty.input:make-text-input) :text-input (cl-tty.input:make-text-input
:on-submit #'handle-submit
:on-cancel #'handle-cancel
:on-tab #'handle-tab
:on-history #'handle-history)
:messages (make-array 16 :adjustable t :fill-pointer 0) :messages (make-array 16 :adjustable t :fill-pointer 0)
:scroll-offset 0 :busy nil :scroll-offset 0 :busy nil
:pending-ctrl-x nil :pending-ctrl-x nil
@@ -305,51 +309,48 @@ Semantic keys (all presets define these):
** Slash Commands ** Slash Commands
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp #+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
(defvar *slash-commands* (defvar *slash-commands*
'((:title "/eval <expr> — Evaluate Lisp" :value "/eval" :category :session) '((:title "/eval <expr> — Evaluate Lisp" :value "/eval")
(:title "/undo — Undo last operation" :value "/undo" :category :session) (:title "/undo — Undo last operation" :value "/undo")
(:title "/redo — Redo last operation" :value "/redo" :category :session) (:title "/redo — Redo last operation" :value "/redo")
(:title "/reconnect — Re-establish daemon" :value "/reconnect" :category :session) (:title "/reconnect — Re-establish daemon" :value "/reconnect")
(:title "/quit — Save history and exit" :value "/quit" :category :session) (:title "/quit — Save history and exit" :value "/quit")
(:title "/q — Quick quit" :value "/q" :category :session) (:title "/q — Quick quit" :value "/q")
(:title "/why — Show last gate trace" :value "/why" :category :memory) (:title "/why — Show last gate trace" :value "/why")
(:title "/identity — Edit IDENTITY.org" :value "/identity" :category :memory) (:title "/tags — List tag severities" :value "/tags")
(:title "/tags — List tag severities" :value "/tags" :category :memory) (:title "/audit <id> — Inspect memory" :value "/audit")
(:title "/audit <id> — Inspect memory" :value "/audit" :category :memory) (:title "/audit verify — Memory integrity" :value "/audit verify")
(:title "/audit verify — Memory integrity" :value "/audit verify" :category :memory) (:title "/rewind <n> — Rewind to snapshot" :value "/rewind")
(:title "/rewind <n> — Rewind to snapshot" :value "/rewind" :category :memory) (:title "/sessions — Show memory snapshots" :value "/sessions")
(:title "/sessions — Show memory snapshots" :value "/sessions" :category :memory) (:title "/resume <n> — Resume from snapshot" :value "/resume")
(:title "/resume <n> — Resume from snapshot" :value "/resume" :category :memory) (:title "/theme [name] — Show/switch theme" :value "/theme")
(:title "/focus <project> — Set context" :value "/focus" :category :system) (:title "/context — Show context summary" :value "/context")
(:title "/scope <scope> — Change scope" :value "/scope" :category :system) (:title "/search <query> — Search messages" :value "/search")
(:title "/unfocus — Pop context" :value "/unfocus" :category :system) (:title "/help — Show commands" :value "/help")
(:title "/theme [name] — Show/switch theme" :value "/theme" :category :system) (:title "/help <topic> — Search manual" :value "/help "))
(:title "/context — Show context summary" :value "/context" :category :system)
(:title "/context why <id> — Debug memory" :value "/context why" :category :system)
(:title "/context dropped — Estimate pruned" :value "/context dropped" :category :system)
(:title "/search <query> — Search messages" :value "/search" :category :navigation)
(:title "/help — Show commands" :value "/help" :category :help)
(:title "/help <topic> — Search manual" :value "/help <topic>" :category :help))
"Slash commands for minibuffer select-dialog.") "Slash commands for minibuffer select-dialog.")
#+END_SRC
** Daemon Commands
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-state.lisp
(defvar *daemon-commands* (defvar *daemon-commands*
'((:title "Status — Daemon health info" :value (:action :status) :category :session) '((:title "Status — Daemon health info" :value (:action :status))
(:title "Stats — Daemon statistics" :value (:action :stats) :category :session) (:title "Stats — Daemon statistics" :value (:action :stats))
(:title "Ping — Daemon reachability" :value (:action :ping) :category :session) (:title "Ping — Daemon reachability" :value (:action :ping))
(:title "Memory Snapshot — Capture state" :value (:action :memory-snapshot) :category :memory) (:title "Memory Snapshot — Capture state" :value (:action :memory-snapshot))
(:title "Memory Rebuild — Rebuild indices" :value (:action :memory-rebuild) :category :memory) (:title "Memory Rebuild — Rebuild indices" :value (:action :memory-rebuild))
(:title "Memory Compact — Optimize storage" :value (:action :memory-compact) :category :memory) (:title "Memory Compact — Optimize storage" :value (:action :memory-compact))
(:title "Reload Config — Reload configuration" :value (:action :reload-config) :category :system) (:title "Reload Config — Reload configuration" :value (:action :reload-config))
(:title "Reload Identity — Reload identity file" :value (:action :reload-identity) :category :system) (:title "Reload Identity — Reload identity file" :value (:action :reload-identity))
(:title "List Skills — Available skills" :value (:action :list-skills) :category :system) (:title "List Skills — Available skills" :value (:action :list-skills))
(:title "Help — Show daemon help" :value (:action :help) :category :help)) (:title "Help — Show daemon help" :value (:action :help)))
"Daemon commands for the command palette (Ctrl+P).") "Daemon commands for the command palette (Ctrl+P).")
(defun all-commands () (defun all-commands ()
"Merge slash commands and daemon commands into one unified list." "Merge slash commands, daemon commands, and menu entries into one unified list."
(append *slash-commands* *daemon-commands*)) (append *menu-entries* *slash-commands* *daemon-commands*))
(defvar *menu-entries*
'((:title "/config — LLM providers, cascade, network, folders, identity"
:value :config-menu
:action passepartout.channel-tui::show-config-main-menu))
"Special menu entries with actions (open submenus).")
#+END_SRC #+END_SRC
** Event Queue ** Event Queue