From e763768122a242553525505dd761a97355408e36 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Wed, 20 May 2026 13:36:21 -0400 Subject: [PATCH] migrate on-key to text-input callbacks Replace the 400-line on-key function with cl-tty text-input callbacks. Add on-cancel, on-tab, on-history slots to cl-tty's text-input widget. Remove defkeymap :local up/down/escape handlers. Remove (member k '(:enter :tab :escape :up :down)) from process-key-event. PageUp/PageDown stay in keymap, routed to handle-ppage/handle-npage. Fix XDG cl-tty.asd to remove stale select-package/select references and add missing markdown-package/markdown entries. Fix #\) character literal (not valid in all contexts). Fix several missing closing parentheses in handle-tab and command-dispatch. --- org/channel-tui-main.org | 962 ++++++++++++--------------------------- 1 file changed, 284 insertions(+), 678 deletions(-) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index 3da375f..e617904 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -34,548 +34,279 @@ Event handlers + daemon I/O + main loop. #+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp (in-package :passepartout.channel-tui) -(defun on-key (ch) +(defun input-text () + "Get current input text from the text-input widget." + (cl-tty.input:text-input-value (st :text-input))) + +(defun (setf input-text) (value) + "Set current input text and reset cursor." + (setf (cl-tty.input:text-input-value (st :text-input)) value + (cl-tty.input:text-input-cursor (st :text-input)) (length value))) + +(defun handle-submit (text) + "Called when user presses Enter in the text-input widget." + (let ((trimmed (string-trim '(#\Space #\Tab) text))) + (when (> (length trimmed) 0) + (push trimmed (st :input-history)) + (setf (st :input-hpos) 0 (st :scroll-offset) 0) + (command-dispatch trimmed) + ;; Clear input text — replace with a fresh widget with same callbacks + (setf (st :text-input) (make-text-input-with-callbacks)) + (setf (st :dirty) (list t t t))))) + +(defun handle-cancel () + "Called when user presses Escape in the text-input widget." (cond - ;; v0.7.1: Esc — interrupt streaming - ((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text)) - (send-daemon (list :type :event :payload '(:action :cancel-stream))) - (when (> (length (st :messages)) 0) - (let ((idx (1- (length (st :messages))))) - (setf (getf (aref (st :messages) idx) :content) - (concatenate 'string - (getf (aref (st :messages) idx) :content) - " [interrupted]")) - (setf (getf (aref (st :messages) idx) :streaming) nil) - (setf (getf (aref (st :messages) idx) :time) (now)))) - (setf (st :streaming-text) nil) - (setf (st :busy) nil) - (setf (st :dirty) (list t t nil))) - ;; v0.7.2: Esc — exit search mode - ((and (eql ch 27) (st :search-mode)) - (setf (st :search-mode) nil - (st :search-matches) nil - (st :search-query) "") - (setf (st :dirty) (list nil t nil)) - (add-msg :system "Search exited")) - ;; v0.7.2: search mode — Up/Down navigate matches - ((and (st :search-mode) (or (eql ch 259) (eq ch :up))) - (let* ((matches (st :search-matches)) - (idx (st :search-match-idx)) - (new-idx (max 0 (1- idx)))) - (setf (st :search-match-idx) new-idx) - (when matches - (setf (st :scroll-offset) (nth new-idx matches)) - (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) - (setf (st :dirty) (list nil t nil))))) - ((and (st :search-mode) (or (eql ch 258) (eq ch :down))) - (let* ((matches (st :search-matches)) - (idx (st :search-match-idx)) - (new-idx (min (1- (length matches)) (1+ idx)))) - (setf (st :search-match-idx) new-idx) - (when matches - (setf (st :scroll-offset) (nth new-idx matches)) - (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) - (setf (st :dirty) (list nil t nil))))) - ;; v0.7.2: search mode — Enter jumps to current match - ((and (st :search-mode) (or (eql ch 13) (eql ch 10) (eq ch :enter))) - (let ((matches (st :search-matches)) - (idx (st :search-match-idx))) - (when (and matches (>= (length matches) (1+ idx))) - (setf (st :scroll-offset) (nth idx matches)) - (setf (st :search-mode) nil - (st :search-matches) nil - (st :search-query) "") - (add-msg :system (format nil "Jumped to match ~d" (1+ idx))) - (setf (st :dirty) (list nil t nil))))) - ;; v0.7.1: Tab on empty input — extract then open URL from agent message - ((and (or (eql ch 9) (eq ch :tab)) - (null (st :input-buffer))) - (if (st :url-buffer) - ;; Already extracted — now open it - (progn - (add-msg :system (format nil "Opening ~a" (st :url-buffer))) - (setf (st :url-buffer) nil)) - ;; Extract URL from last agent message - (let ((url nil)) - (loop for i from (1- (length (st :messages))) downto 0 - for msg = (aref (st :messages) i) - for content = (getf msg :content) - for role = (getf msg :role) - while (eq role :agent) - when content - do (let ((pos (or (search "https://" content) (search "http://" content)))) - (when pos - (let ((end (or (position-if (lambda (c) (find c (list #\Space #\Newline #\Tab (code-char 41)))) - content :start pos) - (length content)))) - (setf url (subseq content pos end)) - (return))))) - (if url - (progn - (setf (st :url-buffer) url) - (add-msg :system (format nil "Press Tab to open ~a" url)) - (setf (st :dirty) (list t t nil))) - nil)))) - ;; Enter - ((or (eq ch :enter) (eql ch 13) (eql ch 10) (eql ch 343) - (eql ch #\Newline) (eql ch #\Return)) - ;; Multi-line: if buffer ends with \, strip it and insert newline - (if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\)) - (progn (pop (st :input-buffer)) - (push #\Newline (st :input-buffer)) - (setf (st :dirty) (list nil nil t))) - (let ((text (string-trim '(#\Space #\Tab) (input-string)))) - (when (> (length text) 0) - (push text (st :input-history)) - (setf (st :input-hpos) 0) - (setf (st :scroll-offset) 0) - (cond - ;; v0.7.2: undo/redo - ((string-equal text "/undo") - (send-daemon (list :type :event :payload (list :sensor :undo))) - (add-msg :system "Undo: restoring memory to previous state")) - ((string-equal text "/redo") - (send-daemon (list :type :event :payload (list :sensor :redo))) - (add-msg :system "Redo: restoring memory")) - ;; /help command - ((and (>= (length text) 9) - (string-equal (subseq text 0 9) "/approve ")) - (let ((token (string-trim '(#\Space) (subseq text 9)))) - (send-daemon (list :type :event :payload - (list :action :hitl-respond :token token :decision :approved))) - (add-msg :system (format nil "✓ Approved: ~a" token)) - (resolve-hitl-panel :approved))) - ((and (>= (length text) 6) - (string-equal (subseq text 0 6) "/deny ")) - (let ((token (string-trim '(#\Space) (subseq text 6)))) - (send-daemon (list :type :event :payload - (list :action :hitl-respond :token token :decision :denied))) - (add-msg :system (format nil "✗ Denied: ~a" token)) - (resolve-hitl-panel :denied))) - ;; /help command - ;; /why command — show last gate trace - ((string-equal text "/why") - (let ((msgs (st :messages)) - (found nil)) - (loop for i from (1- (length msgs)) downto 0 - for m = (aref msgs i) - for gt = (getf m :gate-trace) - when (and gt (listp gt) (> (length gt) 0)) - do (setf found t) - (dolist (entry gt) - (let* ((gate (getf entry :gate)) - (result (getf entry :result)) - (reason (getf entry :reason)) - (msg (format nil "~a ~a~@[ — ~a~]" - (case result (:passed "[PASS]") (:blocked "[BLOCKED]") (:approval "[HITL]")) - (or gate "unknown") - reason))) - (add-msg :system msg))) - (loop-finish)) - (unless found - (add-msg :system "No recent gate trace. Run a tool to see gate decisions.")))) - ;; /identity command — edit and reload identity file - ((string-equal text "/identity") - (let* ((editor (or (uiop:getenv "EDITOR") "emacs")) - (path (merge-pathnames "memex/IDENTITY.org" (user-homedir-pathname)))) - (add-msg :system (format nil "Opening ~a in ~a..." (namestring path) editor)) - (uiop:run-program (list editor (namestring path)) :output t :error-output t) - (when (fboundp 'load-identity-file) - (funcall 'load-identity-file)) - (add-msg :system "Identity reloaded"))) - ;; /audit command — Merkle provenance - ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit ")) - (if (fboundp 'audit-node) - (let* ((node-id (string-trim '(#\Space) (subseq text 7))) - (info (funcall 'audit-node node-id))) - (if info - (add-msg :system (format nil "Node ~a: type=~a scope=~a hash=~a" - (getf info :id) (getf info :type) - (getf info :scope) - (subseq (or (getf info :hash) "(none)") 0 16))) - (add-msg :system (format nil "Node ~a not found" node-id)))) - (add-msg :system "Memory audit not available"))) - ;; /tags command — tag stack with trigger counts - ((string-equal text "/tags") - (let ((cats passepartout::*tag-categories*) - (counts passepartout::*tag-trigger-count*)) - (if cats - (dolist (entry cats) - (let* ((tag (car entry)) - (sev (cdr entry)) - (n (gethash (string-downcase tag) counts 0))) - (add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n)))) - (add-msg :system "No tags configured. Set TAG_CATEGORIES env var.")))) - ;; /context command — section breakdown with token estimates - ((string-equal text "/context") - (let* ((msg-count (length (st :messages))) - (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4))) - (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*) - (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4) - 50)) - (log-tokens (min 4000 (floor (* msg-count 60) 4))) - ;; rough estimate: TIME, CONTEXT overhead - (overhead-tokens 200) - (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) - (total-limit 8192) - (pct-used (floor (* 100 total-est) total-limit)) - (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) - :initial-element #\#))) - (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) - (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) - (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) - (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) - (add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count)) - (add-msg :system (format nil " [~a~a] ~d%" - bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used)) - (when (> pct-used 80) - (add-msg :system "⚠ Context near limit — older messages may be dropped")))) - ;; /context why — debug node with full attributes - ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) - (let ((node-id (string-trim '(#\Space) (subseq text 13)))) - (if (fboundp 'passepartout::memory-object-get) - (let ((obj (funcall 'passepartout::memory-object-get node-id))) - (if obj - (let ((attrs (passepartout::memory-object-attributes obj)) - (parent (passepartout::memory-object-parent-id obj)) - (children (passepartout::memory-object-children obj)) - (hash (or (passepartout::memory-object-hash obj) "(none)"))) - (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" - node-id - (passepartout::memory-object-type obj) - (passepartout::memory-object-scope obj) - (passepartout::memory-object-version obj))) - (when parent - (add-msg :system (format nil " parent: ~a" parent))) - (when children - (add-msg :system (format nil " children: ~d" (length children)))) - (add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash))))) - (when attrs - (add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)"))))) - (add-msg :system (format nil "Node ~a not found in memory" node-id)))) - (add-msg :system "Memory not available")))) - ;; /context dropped — estimate pruned nodes from budget - ((string-equal text "/context dropped") - (let* ((msg-count (length (st :messages))) - (est-total (* msg-count 60)) - (budget 8192) - (dropped-msgs (if (> est-total budget) - (floor (- est-total budget) 60) - 0))) - (if (> dropped-msgs 0) - (add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)" - dropped-msgs (- est-total budget) budget - (floor (* 100 est-total) budget))) - (add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)" - est-total budget (floor (* 100 est-total) budget)))))) - ;; /search command — message search - ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search ")) - (let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8)))) - (msgs (st :messages)) - (total (length msgs)) - (matches nil)) - (loop for i from 0 below total - for m = (aref msgs i) - for content = (getf m :content) - when (search query (string-downcase content)) - do (push i matches)) - (setf matches (nreverse matches)) - ;; Enter search mode - (setf (st :search-mode) t - (st :search-query) query - (st :search-matches) matches - (st :search-match-idx) 0) - (if matches - (add-msg :system (format nil "Search: ~d matches for '~a' (1/~d) — Up/Down nav, Enter jump, Esc exit" - (length matches) query (length matches))) - (add-msg :system (format nil "0 matches for '~a'" query))))) - ;; /rewind command — session rewind - ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind ")) - (let* ((n-str (string-trim '(#\Space) (subseq text 8))) - (n (handler-case (parse-integer n-str) (error () nil)))) - (if n - (if (fboundp 'passepartout::rollback-memory) - (let* ((idx (1- n)) - (snaps passepartout::*memory-snapshots*) - (ts (when (< idx (length snaps)) - (getf (nth idx snaps) :timestamp)))) - (funcall 'passepartout::rollback-memory idx) - (add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts))) - (add-msg :system "Memory rollback not available")) - (add-msg :system "Usage: /rewind ")))) - ;; /sessions command — list snapshots - ((string-equal text "/sessions") - (let ((snaps passepartout::*memory-snapshots*)) - (if snaps - (let ((shown (subseq snaps 0 (min 10 (length snaps))))) - (add-msg :system (format nil "~d snapshots (showing ~d):" - (length snaps) (length shown))) - (loop for s in shown - for i from 0 - for ts = (getf s :timestamp) - for data = (getf s :data) - for size = (hash-table-size data) - do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d" - (1+ i) size ts)))) - (add-msg :system "No snapshots available")))) - ;; /audit verify — memory integrity - ((string-equal text "/audit verify") - (if (fboundp 'passepartout::audit-verify-hash) - (let* ((result (funcall 'passepartout::audit-verify-hash)) - (total (car result)) - (missing (cdr result))) - (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" - total missing - (length passepartout::*memory-snapshots*) - (zerop missing) - (unless (zerop missing) missing)))) - (add-msg :system "Memory audit not available"))) - ;; /resume — resume from snapshot - ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) - (let* ((n-str (string-trim '(#\Space) (subseq text 8))) - (n (handler-case (parse-integer n-str) (error () nil)))) - (if n - (if (fboundp 'passepartout::rollback-memory) - (progn (funcall 'passepartout::rollback-memory (1- n)) - (add-msg :system (format nil "Resumed from snapshot ~d" n))) - (add-msg :system "Memory rollback not available")) - (add-msg :system "Usage: /resume ")))) - ;; /help — search user manual - ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) - (let ((topic (string-trim '(#\Space) (subseq text 6))) - (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) - (if sections - (dolist (entry sections) - (let* ((title (car entry)) - (content (cdr entry)) - (preview (if (> (length content) 300) - (concatenate 'string (subseq content 0 297) "...") - content))) - (add-msg :system (format nil "~a: ~a" title preview)))) - (add-msg :system (format nil "No manual section found for '~a'" topic))))) - ((string-equal text "/help") - (add-msg :system "/eval Evaluate Lisp") - (add-msg :system "/undo Undo last operation") - (add-msg :system "/redo Redo last operation") - (add-msg :system "/why Show last gate trace") - (add-msg :system "/identity Edit IDENTITY.org") - (add-msg :system "/tags List tag severities") - (add-msg :system "/audit Inspect memory object") - (add-msg :system "/search Search messages") - (add-msg :system "/context Show context summary") - (add-msg :system "/rewind Rewind to snapshot N") - (add-msg :system "/sessions Show snapshots") - (add-msg :system "/resume Resume from snapshot") - (add-msg :system "/focus Set project context") - (add-msg :system "/theme Show theme") - (add-msg :system "/help [topic] Show this help") - (add-msg :system "\\ + Enter Multi-line input") - (add-msg :system "Ctrl+G Toggle gate trace")) - ;; /theme command - ((string-equal text "/theme") - (add-msg :system (format nil "Theme — 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: /theme amber | gold | terracotta | sepia | nord-warm | monokai-warm | gruvbox-warm | light-amber | catppuccin | tokyonight | dracula | gemini | mono")) - ((and (>= (length text) 7) - (string-equal (subseq text 0 7) "/theme ")) - (let ((name (string-trim '(#\Space) (subseq text 7)))) - (if (theme-switch name) - (add-msg :system (format nil "Theme switched to ~a" name)) - (add-msg :system (format nil "Unknown theme '~a'. Try: amber gold terracotta sepia nord-warm monokai-warm gruvbox-warm light-amber catppuccin tokyonight dracula gemini mono" name))))) - ;; /eval command - ((and (>= (length text) 6) - (string-equal (subseq text 0 6) "/eval ")) - (handler-case - (let* ((*read-eval* t) - (*package* (find-package :passepartout.channel-tui)) - (r (eval (read-from-string (subseq text 6))))) - (add-msg :system (format nil "=> ~s" r))) - (error (c) (add-msg :system (format nil "=> ✗ ~a" c))))) - ;; /focus — set project context - ((and (>= (length text) 7) - (string-equal (subseq text 0 7) "/focus ")) - (let ((project (string-trim '(#\Space) (subseq text 7)))) - (if (and (fboundp 'focus-project) (> (length project) 0)) - (progn (funcall 'focus-project project nil) - (add-msg :system (format nil "Focused on project: ~a" project))) - (add-msg :system "Usage: /focus ")))) - ;; /scope — change context scope - ((and (>= (length text) 7) - (string-equal (subseq text 0 7) "/scope ")) - (let ((scope-str (string-trim '(#\Space) (subseq text 7)))) - (cond - ((and (fboundp 'focus-session) (string-equal scope-str "session")) - (funcall 'focus-session) - (add-msg :system "Scope: session")) - ((and (fboundp 'focus-project) (string-equal scope-str "project")) - (funcall 'focus-project nil nil) - (add-msg :system "Scope: project")) - ((and (fboundp 'focus-memex) (string-equal scope-str "memex")) - (funcall 'focus-memex) - (add-msg :system "Scope: memex")) - (t (add-msg :system "Usage: /scope memex|session|project"))))) - ;; /unfocus — pop context - ((and (>= (length text) 8) - (string-equal (subseq text 0 8) "/unfocus")) - (if (fboundp 'unfocus) - (progn (funcall 'unfocus) - (add-msg :system "Popped context")) - (add-msg :system "Context manager not loaded"))) - ;; /quit — save history and exit - ((or (string-equal text "/quit") (string-equal text "/q")) - (let ((hist-file (merge-pathnames ".cache/passepartout/history" - (user-homedir-pathname)))) - (uiop:ensure-all-directories-exist (list hist-file)) - (with-open-file (out hist-file :direction :output - :if-exists :supersede :if-does-not-exist :create) - (dolist (entry (reverse (st :input-history))) - (write-line entry out)))) - (add-msg :system "* Goodbye *") - (send-daemon (list :type :event :payload '(:action :quit))) - (setf (st :running) nil)) - ;; /reconnect — re-establish daemon connection - ((string-equal text "/reconnect") - (disconnect-daemon) - (add-msg :system "* Reconnecting... *") - (connect-daemon) - (setf (st :dirty) (list t t nil))) - ;; Normal message - (t - (add-msg :user text) - (setf (st :busy) t) - (send-daemon (list :type :event - :payload (list :sensor :user-input :text text))))) - (setf (st :input-buffer) nil) - (setf (st :cursor-pos) 0) - (setf (st :dirty) (list t t t)))))) - ;; Tab — command completion (v0.7.0: extended with subcommand + file paths) - ((or (eql ch 9) (eq ch :tab)) - (let ((text (input-string))) - (cond - ;; @ prefix — file path completion - ((and (>= (length text) 1) (eql (char text 0) #\@)) - (let* ((partial (subseq text 1)) - (memex (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) - (files (handler-case (append (uiop:directory-files proj "**/*.org") - (uiop:directory-files proj "**/*.lisp")) - (error () nil))) - (names (mapcar (lambda (f) (subseq (namestring f) (1+ (length (namestring proj))))) files)) - (match (find-if (lambda (n) (and (>= (length n) (length partial)) - (string-equal n partial :end2 (length partial)))) - names))) - (when match - (setf (st :input-buffer) (reverse (coerce (concatenate 'string "@" match) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; /theme subcommand - ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme ")) - (let* ((partial (string-trim '(#\Space) (subseq text 7))) - (names '("amber" "gold" "terracotta" "sepia" "nord-warm" "monokai-warm" "gruvbox-warm" "light-amber" "catppuccin" "tokyonight" "dracula" "gemini" "mono")) - (match (if (string= partial "") (first names) - (find partial names :test #'string-equal)))) - (when match - (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/theme " match) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; /focus subcommand - ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus ")) - (let* ((partial (string-trim '(#\Space) (subseq text 7))) - (memex (or (uiop:getenv "MEMEX_DIR") - (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) - (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) - (dirs (handler-case (mapcar (lambda (d) (car (last (pathname-directory d)))) - (uiop:subdirectories proj)) - (error () nil))) - (match (if (string= partial "") (first dirs) - (find-if (lambda (d) (and (>= (length d) (length partial)) - (string-equal d partial :end2 (length partial)))) - dirs)))) - (when match - (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/focus " match) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; Command prefix / - ((and (> (length text) 1) (eql (char text 0) #\/)) - (let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit")) - (match (find text cmds :test - (lambda (in cmd) (and (>= (length cmd) (length in)) - (string-equal cmd in :end1 (length in))))))) - (when match - (setf (st :input-buffer) (reverse (coerce match 'list))) - (when (member match '("/eval" "/focus" "/scope") :test #'string=) - (push #\Space (st :input-buffer))) - (setf (st :dirty) (list nil nil t)))))))) - ;; Backspace - ((or (eq ch :backspace) (eql ch 127) (eql ch 8) (eql ch 263) - (eql ch #\Backspace)) - (input-delete-char) - (setf (st :dirty) (list nil nil t))) - ;; Left arrow - ((eq ch :left) - (when (> (or (st :cursor-pos) 0) 0) - (decf (st :cursor-pos)) - (setf (st :dirty) (list nil nil t)))) - ;; Right arrow - ((eq ch :right) - (when (< (or (st :cursor-pos) 0) (length (st :input-buffer))) - (incf (st :cursor-pos)) - (setf (st :dirty) (list nil nil t)))) - ;; Up arrow - ((eq ch :up) - (let* ((h (st :input-history)) (p (st :input-hpos))) - (when (and h (< p (1- (length h)))) - (incf (st :input-hpos)) - (setf (st :input-buffer) - (reverse (coerce (nth (st :input-hpos) h) 'list))) - (setf (st :dirty) (list nil nil t))))) - ;; Down arrow - ((eq ch :down) + ((st :streaming-text) + (send-daemon (list :type :event :payload '(:action :cancel-stream))) + (when (> (length (st :messages)) 0) + (let ((idx (1- (length (st :messages))))) + (setf (getf (aref (st :messages) idx) :content) + (concatenate 'string (getf (aref (st :messages) idx) :content) " [interrupted]")) + (setf (getf (aref (st :messages) idx) :streaming) nil + (getf (aref (st :messages) idx) :time) (now)))) + (setf (st :streaming-text) nil (st :busy) nil) + (setf (st :dirty) (list t t nil))) + ((st :search-mode) + (setf (st :search-mode) nil (st :search-matches) nil (st :search-query) "") + (setf (st :dirty) (list nil t nil)) + (add-msg :system "Search exited")))) + +(defun handle-tab (text pos) + "Called when user presses Tab in the text-input widget. +Returns two values: new-text and new-cursor-pos (or nil if no completion)." + (declare (ignore pos)) + (cond + ;; URL extraction on empty input + ((string= "" text) + (if (st :url-buffer) + (progn (add-msg :system (format nil "Opening ~a" (st :url-buffer))) + (setf (st :url-buffer) nil) + nil) + (let ((url 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))))) + (when url + (setf (st :url-buffer) url) + (add-msg :system (format nil "Press Tab to open ~a" url)) + (setf (st :dirty) (list t t nil))) + nil))) + ;; @ prefix — file path completion + ((and (>= (length text) 1) (eql (char text 0) #\@)) + (let* ((partial (subseq text 1)) + (memex (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) + (files (handler-case (append (uiop:directory-files proj "**/*.org") + (uiop:directory-files proj "**/*.lisp")) + (error () nil))) + (names (mapcar (lambda (f) (subseq (namestring f) (1+ (length (namestring proj))))) files)) + (match (find-if (lambda (n) (and (>= (length n) (length partial)) + (string-equal n partial :end2 (length partial)))) + names))) + (when match + (values (concatenate 'string "@" match) (length (concatenate 'string "@" match)))))) + ;; /theme subcommand + ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme ")) + (let* ((partial (string-trim '(#\Space) (subseq text 7))) + (names '("amber" "gold" "terracotta" "sepia" "nord-warm" "monokai-warm" + "gruvbox-warm" "light-amber" "catppuccin" "tokyonight" "dracula" + "gemini" "mono")) + (match (if (string= partial "") (first names) + (find partial names :test #'string-equal)))) + (when match (values (concatenate 'string "/theme " match))))) + ;; /focus subcommand + ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus ")) + (let* ((partial (string-trim '(#\Space) (subseq text 7))) + (memex (or (uiop:getenv "MEMEX_DIR") + (namestring (merge-pathnames "memex/" (user-homedir-pathname))))) + (proj (merge-pathnames (make-pathname :directory '(:relative "projects")) memex)) + (dirs (handler-case (mapcar (lambda (d) (car (last (pathname-directory d)))) + (uiop:subdirectories proj)) + (error () nil))) + (match (if (string= partial "") (first dirs) + (find-if (lambda (d) (and (>= (length d) (length partial)) + (string-equal d partial :end2 (length partial)))) + dirs)))) + (when match (values (concatenate 'string "/focus " match))))) + ;; Command prefix / + ((and (> (length text) 1) (eql (char text 0) #\/)) + (let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit")) + (match (find text cmds :test + (lambda (in cmd) (and (>= (length cmd) (length in)) + (string-equal cmd in :end1 (length in))))))) + (when match + (if (member match '("/eval" "/focus" "/scope") :test #'string=) + (values (concatenate 'string match " ")) + (values match))))) + (t nil)))) + + +(defun handle-history (direction) + "Called when user presses Up/Down in the text-input widget. +Returns two values: new-text and new-cursor-pos (or nil if no movement)." + (let ((h (st :input-history)) (p (st :input-hpos))) + (if (eq direction :up) + (when (and h (< p (1- (length h)))) + (incf (st :input-hpos)) + (values (nth (st :input-hpos) h) (length (nth (st :input-hpos) h)))) (when (> (st :input-hpos) 0) (decf (st :input-hpos)) - (let ((h (st :input-history))) - (setf (st :input-buffer) - (if (and h (< (st :input-hpos) (length h))) - (reverse (coerce (nth (st :input-hpos) h) 'list)) - nil)) - (setf (st :dirty) (list nil nil t))))) - ;; PageUp — scroll back by page (10 lines) - ((eq ch :ppage) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) - (setf (st :dirty) (list nil t nil))) - ;; PageDown — scroll forward by page - ((eq ch :npage) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) - (setf (st :dirty) (list nil t nil))) - ;; Printable - (t - (let ((chr (typecase ch - (character ch) - ((integer 32 126) (code-char ch)) - (keyword (let ((s (string ch))) - (and (= (length s) 1) (char-downcase (char s 0))))) - (t nil)))) - (when (and chr (graphic-char-p chr)) - (input-insert-char chr) - (setf (st :dirty) (list nil nil t)) - (when (and (char= chr #\/) (null (st :dialog-stack)) - (= (length (st :input-buffer)) 1)) - (unified-menu-show "/"))))))) + (if (and h (< (st :input-hpos) (length h))) + (values (nth (st :input-hpos) h) (length (nth (st :input-hpos) h))) + (values "" 0)))))) + +(defun handle-ppage () + "Scroll chat up by one page." + (let ((max-offset (max 0 (- (length (st :messages)) 1)))) + (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) + (setf (st :dirty) (list nil t nil))) + +(defun handle-npage () + "Scroll chat down by one page." + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) + (setf (st :dirty) (list nil t nil))) + +(defun handle-search-navigate (direction) + "Search mode: move to prev/next match." + (let* ((matches (st :search-matches)) + (idx (st :search-match-idx)) + (new-idx (if (eq direction :up) + (max 0 (1- idx)) + (min (1- (length matches)) (1+ idx))))) + (setf (st :search-match-idx) new-idx) + (when matches + (setf (st :scroll-offset) (nth new-idx matches)) + (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches))) + (setf (st :dirty) (list nil t nil))))) + +(defun command-dispatch (text) + "Handle a submitted command or message. TEXT is the trimmed input. +Called from handle-submit." + (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))) + (add-msg :system (format nil "✓ Approved: ~a" token)) + (resolve-hitl-panel :approved))) + ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/deny ")) + (let ((token (string-trim '(#\Space) (subseq text 6)))) + (send-daemon (list :type :event :payload (list :action :hitl-respond :token token :decision :denied))) + (add-msg :system (format nil "✗ Denied: ~a" token)) + (resolve-hitl-panel :denied))) + ((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")) + ((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")) + ((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.")) + ((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)))) + ((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 ")))) + ((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))))))) -;; v0.9.0 — unified command minibuffer (replaces separate palette and slash menus) (defun unified-menu-show (&optional initial-filter) "Open the command minibuffer with ALL commands. If INITIAL-FILTER is supplied (e.g. \"/\"), pre-fill the select filter with it." (let* ((on-select (lambda (opt) (pop (st :dialog-stack)) (let ((val (getf opt :value))) - (cond ((stringp val) - ;; Slash command — fill input buffer - (setf (st :input-buffer) (reverse (coerce val 'list))) - (setf (st :cursor-pos) 0) - (setf (st :dirty) (list nil nil t))) + (cond ((stringp val) + ;; Slash command — fill input buffer + (setf (input-text) val) + (setf (st :dirty) (list nil nil t))) ((listp val) ;; Daemon action — send immediately (send-daemon (list :type :event :payload val)) @@ -786,8 +517,8 @@ supplied (e.g. \"/\"), pre-fill the select filter with it." (setf (st :dirty) (list t t nil)))) ((cl-tty.input:dispatch-key-event event) (setf (st :dirty) (list t t nil))) - ((member k '(:enter :tab :escape :up :down)) - (on-key k)) + ((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) @@ -841,39 +572,17 @@ Returns T on success, nil on failure. Does NOT wait or retry." (:npage (lambda (e) (declare (ignore e)) (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) (setf (st :dirty) (list nil t nil)))) - ;; v0.9.0 — Readline keybindings - (:ctrl+a (lambda (e) (declare (ignore e)) - (setf (st :cursor-pos) 0))) - (:ctrl+e (lambda (e) (declare (ignore e)) - (setf (st :cursor-pos) (length (st :input-buffer))))) - (:ctrl+u (lambda (e) (declare (ignore e)) - (setf (st :input-buffer) nil) - (setf (st :cursor-pos) 0) - (setf (st :dirty) (list nil nil t)))) - (:ctrl+w (lambda (e) (declare (ignore e)) - (let ((buf (st :input-buffer))) - (loop while (and buf (char= (first buf) #\Space)) do (pop buf)) - (loop while (and buf (char/= (first buf) #\Space)) do (pop buf)) - (setf (st :input-buffer) buf) - (setf (st :dirty) (list nil nil t))))) - (:ctrl+k (lambda (e) (declare (ignore e)) - (let* ((s (input-string)) - (pos (or (st :cursor-pos) 0)) - (killed (subseq s pos))) - (setf (st :kill-ring) killed) - (setf (st :input-buffer) (reverse (coerce (subseq s 0 pos) 'list))) - (setf (st :dirty) (list nil nil t))))) + ;; v0.9.0 — Readline keybindings (Ctrl+A/E/U/W/K handled by text-input widget) (:ctrl+y (lambda (e) (declare (ignore e)) (let ((killed (st :kill-ring))) (when killed - (dolist (ch (reverse (coerce killed 'list))) - (push ch (st :input-buffer))) - (setf (st :cursor-pos) (length (st :input-buffer))) + (let ((cur (input-text))) + (setf (input-text) (concatenate 'string cur killed))) (setf (st :dirty) (list nil nil t)))))) (:ctrl+l (lambda (e) (declare (ignore e)) (setf (st :dirty) (list t t t)))) (:ctrl+d (lambda (e) (declare (ignore e)) - (when (or (null (st :input-buffer)) (string= "" (input-string))) + (when (string= "" (input-text)) (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))) (:ctrl+f (lambda (e) (declare (ignore e)) (add-msg :system "Use /search to find messages"))) @@ -894,7 +603,8 @@ Returns T on success, nil on failure. Does NOT wait or retry." (setf (st :dirty) (list nil t nil))) (add-msg :system "No gate trace to toggle"))))) (:alt+enter (lambda (e) (declare (ignore e)) - (push #\Newline (st :input-buffer)) + (let ((cur (input-text))) + (setf (input-text) (concatenate 'string cur (string #\Newline)))) (setf (st :dirty) (list nil nil t)))) ;; v0.9.0 — Ctrl+X prefix + help (:ctrl+x (lambda (e) (declare (ignore e)) @@ -907,15 +617,23 @@ Returns T on success, nil on failure. Does NOT wait or retry." ;; v0.8.0 — Prompt/local keymap (for when input is active) (eval-when (:load-toplevel :execute) (cl-tty.input:defkeymap :local - (:up (lambda (e) (declare (ignore e)) (on-key :up))) - (:down (lambda (e) (declare (ignore e)) (on-key :down))) - (:escape (lambda (e) (declare (ignore e)) (on-key :escape))))) + (:ppage (lambda (e) (declare (ignore e)) (handle-ppage))) + (:npage (lambda (e) (declare (ignore e)) (handle-npage)))) (defvar *cat-proc* nil "Cat subprocess for keyboard input (unused — direct stdin reads)") (defvar *tty-in* nil "Stream from cat subprocess stdout (unused — direct stdin reads)") +(defun make-text-input-with-callbacks () + "Create a text-input widget with the standard passepartout callbacks." + (cl-tty.input:make-text-input + :on-submit #'handle-submit + :on-cancel #'handle-cancel + :on-tab #'handle-tab + :on-history #'handle-history)) + (defun tui-main () (init-state) + (setf (st :text-input) (make-text-input-with-callbacks)) (load-history) (theme-load) (let* ((swank-port (or (ignore-errors @@ -1008,7 +726,7 @@ Returns T on success, nil on failure. Does NOT wait or retry." (when (> (length f) 0) (setf (cl-tty.dialog:select-filter sel) (subseq f 0 (1- f)))))))) - (on-key ch)))))))) + nil)))))))) ;; Keyboard reader via cl-tty.input:read-event (handles CSI, SS3, UTF-8, resize) (handler-case (multiple-value-bind (ev resize-data) @@ -1143,110 +861,6 @@ Returns T on success, nil on failure. Does NOT wait or retry." (fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs))) (fiveam:is (null (drain-queue))))) -(fiveam:test test-on-key-enter-sends-user-message - "Contract 1: on-key with Enter extracts input, adds user message, clears buffer." - (init-state) - ;; Simulate typing "test" - (dolist (ch '(#\t #\e #\s #\t)) - (on-key (char-code ch))) - (fiveam:is (string= "test" (input-string))) - ;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled - (on-key 343) - ;; Input buffer should be cleared - (fiveam:is (string= "" (input-string))) - ;; A user message should be in the message list - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((last (aref msgs 0))) - (fiveam:is (eq :user (getf last :role))) - (fiveam:is (string= "test" (getf last :content)))))) - -(fiveam:test test-on-key-eval-command - "Contract 1: on-key handles /eval command and displays result." - (init-state) - ;; Type "/eval (+ 1 2)" - (dolist (ch (coerce "/eval (+ 1 2)" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 1)) - (let ((last-msg (aref msgs 0))) - (fiveam:is (eq :system (getf last-msg :role))) - (fiveam:is (search "=> 3" (getf last-msg :content)))))) - -(fiveam:test test-on-key-backspace - "Contract 1: on-key with Backspace removes last character from buffer." - (init-state) - (dolist (ch '(#\a #\b #\c)) - (on-key (char-code ch))) - (fiveam:is (string= "abc" (input-string))) - ;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled - (on-key 263) - (fiveam:is (string= "ab" (input-string)))) - -(fiveam:test test-on-key-focus-command - "Contract 1: /focus command parses project name." - (init-state) - (dolist (ch (coerce "/focus myapp" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-scope-command - "Contract 1: /scope command with valid argument." - (init-state) - (dolist (ch (coerce "/scope memex" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-unfocus-command - "Contract 1: /unfocus command dispatches correctly." - (init-state) - (dolist (ch (coerce "/unfocus" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msg (aref (st :messages) 0))) - (fiveam:is (eq :system (getf msg :role))))) - -(fiveam:test test-on-key-tab-completion - "Contract 1: Tab completes / commands when input starts with /." - (init-state) - (dolist (ch (coerce "/ev" 'list)) - (on-key (char-code ch))) - (on-key 9) - (fiveam:is (string= "/eval " (input-string)))) - -(fiveam:test test-on-key-tab-no-slash - "Contract 1: Tab does nothing when input doesn't start with /." - (init-state) - (dolist (ch (coerce "hello" 'list)) - (on-key (char-code ch))) - (on-key 9) - (fiveam:is (string= "hello" (input-string)))) - -(fiveam:test test-on-key-multiline - "Contract 1: \\ + Enter inserts newline instead of sending." - (init-state) - (dolist (ch (coerce "line1" 'list)) - (on-key (char-code ch))) - (on-key (char-code #\\)) - (on-key 343) - (fiveam:is (search "line1" (input-string))) - (fiveam:is (search (string #\Newline) (input-string)))) - -(fiveam:test test-on-key-help - "Contract 1: /help displays command list." - (init-state) - (dolist (ch (coerce "/help" 'list)) - (on-key (char-code ch))) - (on-key 343) - (let ((msgs (st :messages))) - (fiveam:is (>= (length msgs) 3)) - (fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs)))) - (fiveam:test test-activity-indicator "Contract model: :busy flag is set on send and cleared on agent response." (init-state) @@ -1268,14 +882,6 @@ Returns T on success, nil on failure. Does NOT wait or retry." (fiveam:is (string= "#e8e8e8" (theme-color :input-fg))) (fiveam:is (string= "#FFFFFF" (theme-color :unknown-role)))) -(fiveam:test test-on-key-ctrl-u-clears - "Contract v0.9.0: Ctrl+U (via dispatch-key-event) clears the input buffer." - (init-state) - (dolist (ch '(#\h #\i)) (on-key (char-code ch))) - (cl-tty.input:dispatch-key-event - (cl-tty.input:make-key-event :key :u :ctrl t :code 21)) - (fiveam:is (string= "" (input-string)))) - (fiveam:test test-on-key-ctrl-l-redraws "Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags." (init-state) @@ -1301,7 +907,7 @@ Returns T on success, nil on failure. Does NOT wait or retry." (init-state) (dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch))) (on-key 9) - (fiveam:is (search "amber" (input-string) :test #'char-equal))) + (fiveam:is (search "amber" (input-text) :test #'char-equal))) ;; ── v0.7.1 Streaming ──