amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

migrate on-key to text-input callbacks

Browse Source 
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.
This commit is contained in:
Amr Gharbeia
2026-05-20 13:36:21 -04:00
parent 0629f8c6d3
commit e763768122
1 changed files with 284 additions and 678 deletions
Download Patch File Download Diff File Expand all files Collapse all files

816
org/channel-tui-main.org
View File

@@ -34,68 +34,55 @@ Event handlers + daemon I/O + main loop.
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp #+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp
(in-package :passepartout.channel-tui) (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 (cond
;; v0.7.1: Esc — interrupt streaming ((st :streaming-text)
((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text))
(send-daemon (list :type :event :payload '(:action :cancel-stream))) (send-daemon (list :type :event :payload '(:action :cancel-stream)))
(when (> (length (st :messages)) 0) (when (> (length (st :messages)) 0)
(let ((idx (1- (length (st :messages))))) (let ((idx (1- (length (st :messages)))))
(setf (getf (aref (st :messages) idx) :content) (setf (getf (aref (st :messages) idx) :content)
(concatenate 'string (concatenate 'string (getf (aref (st :messages) idx) :content) " [interrupted]"))
(getf (aref (st :messages) idx) :content) (setf (getf (aref (st :messages) idx) :streaming) nil
" [interrupted]")) (getf (aref (st :messages) idx) :time) (now))))
(setf (getf (aref (st :messages) idx) :streaming) nil) (setf (st :streaming-text) nil (st :busy) 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))) (setf (st :dirty) (list t t nil)))
;; v0.7.2: Esc — exit search mode ((st :search-mode)
((and (eql ch 27) (st :search-mode)) (setf (st :search-mode) nil (st :search-matches) nil (st :search-query) "")
(setf (st :search-mode) nil
(st :search-matches) nil
(st :search-query) "")
(setf (st :dirty) (list nil t nil)) (setf (st :dirty) (list nil t nil))
(add-msg :system "Search exited")) (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))) (defun handle-tab (text pos)
(let* ((matches (st :search-matches)) "Called when user presses Tab in the text-input widget.
(idx (st :search-match-idx)) Returns two values: new-text and new-cursor-pos (or nil if no completion)."
(new-idx (max 0 (1- idx)))) (declare (ignore pos))
(setf (st :search-match-idx) new-idx) (cond
(when matches ;; URL extraction on empty input
(setf (st :scroll-offset) (nth new-idx matches)) ((string= "" text)
(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) (if (st :url-buffer)
;; Already extracted — now open it (progn (add-msg :system (format nil "Opening ~a" (st :url-buffer)))
(progn (setf (st :url-buffer) nil)
(add-msg :system (format nil "Opening ~a" (st :url-buffer))) nil)
(setf (st :url-buffer) nil))
;; Extract URL from last agent message
(let ((url nil)) (let ((url nil))
(loop for i from (1- (length (st :messages))) downto 0 (loop for i from (1- (length (st :messages))) downto 0
for msg = (aref (st :messages) i) for msg = (aref (st :messages) i)
@@ -105,356 +92,16 @@ Event handlers + daemon I/O + main loop.
when content when content
do (let ((pos (or (search "https://" content) (search "http://" content)))) do (let ((pos (or (search "https://" content) (search "http://" content))))
(when pos (when pos
(let ((end (or (position-if (lambda (c) (find c (list #\Space #\Newline #\Tab (code-char 41)))) (let ((end (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab))
content :start pos) content :start pos)
(length content)))) (length content))))
(setf url (subseq content pos end)) (setf url (subseq content pos end))
(return))))) (return)))))
(if url (when url
(progn
(setf (st :url-buffer) url) (setf (st :url-buffer) url)
(add-msg :system (format nil "Press Tab to open ~a" url)) (add-msg :system (format nil "Press Tab to open ~a" url))
(setf (st :dirty) (list t t nil))) (setf (st :dirty) (list t t nil)))
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 <id> — 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 <number>"))))
;; /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 <n> — 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 <number>"))))
;; /help <topic> — 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 <expr> 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 <id> Inspect memory object")
(add-msg :system "/search <q> Search messages")
(add-msg :system "/context Show context summary")
(add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/sessions Show snapshots")
(add-msg :system "/resume <n> Resume from snapshot")
(add-msg :system "/focus <proj> 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 <project> — 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 <project-name>"))))
;; /scope <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 ;; @ prefix — file path completion
((and (>= (length text) 1) (eql (char text 0) #\@)) ((and (>= (length text) 1) (eql (char text 0) #\@))
(let* ((partial (subseq text 1)) (let* ((partial (subseq text 1))
@@ -469,17 +116,16 @@ Event handlers + daemon I/O + main loop.
(string-equal n partial :end2 (length partial)))) (string-equal n partial :end2 (length partial))))
names))) names)))
(when match (when match
(setf (st :input-buffer) (reverse (coerce (concatenate 'string "@" match) 'list))) (values (concatenate 'string "@" match) (length (concatenate 'string "@" match))))))
(setf (st :dirty) (list nil nil t)))))
;; /theme subcommand ;; /theme subcommand
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme ")) ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/theme "))
(let* ((partial (string-trim '(#\Space) (subseq text 7))) (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")) (names '("amber" "gold" "terracotta" "sepia" "nord-warm" "monokai-warm"
"gruvbox-warm" "light-amber" "catppuccin" "tokyonight" "dracula"
"gemini" "mono"))
(match (if (string= partial "") (first names) (match (if (string= partial "") (first names)
(find partial names :test #'string-equal)))) (find partial names :test #'string-equal))))
(when match (when match (values (concatenate 'string "/theme " match)))))
(setf (st :input-buffer) (reverse (coerce (concatenate 'string "/theme " match) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; /focus subcommand ;; /focus subcommand
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus ")) ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/focus "))
(let* ((partial (string-trim '(#\Space) (subseq text 7))) (let* ((partial (string-trim '(#\Space) (subseq text 7)))
@@ -493,9 +139,7 @@ Event handlers + daemon I/O + main loop.
(find-if (lambda (d) (and (>= (length d) (length partial)) (find-if (lambda (d) (and (>= (length d) (length partial))
(string-equal d partial :end2 (length partial)))) (string-equal d partial :end2 (length partial))))
dirs)))) dirs))))
(when match (when match (values (concatenate 'string "/focus " match)))))
(setf (st :input-buffer) (reverse (coerce (concatenate 'string "/focus " match) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; Command prefix / ;; Command prefix /
((and (> (length text) 1) (eql (char text 0) #\/)) ((and (> (length text) 1) (eql (char text 0) #\/))
(let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit")) (let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit"))
@@ -503,68 +147,156 @@ Event handlers + daemon I/O + main loop.
(lambda (in cmd) (and (>= (length cmd) (length in)) (lambda (in cmd) (and (>= (length cmd) (length in))
(string-equal cmd in :end1 (length in))))))) (string-equal cmd in :end1 (length in)))))))
(when match (when match
(setf (st :input-buffer) (reverse (coerce match 'list))) (if (member match '("/eval" "/focus" "/scope") :test #'string=)
(when (member match '("/eval" "/focus" "/scope") :test #'string=) (values (concatenate 'string match " "))
(push #\Space (st :input-buffer))) (values match)))))
(setf (st :dirty) (list nil nil t)))))))) (t nil))))
;; Backspace
((or (eq ch :backspace) (eql ch 127) (eql ch 8) (eql ch 263)
(eql ch #\Backspace)) (defun handle-history (direction)
(input-delete-char) "Called when user presses Up/Down in the text-input widget.
(setf (st :dirty) (list nil nil t))) Returns two values: new-text and new-cursor-pos (or nil if no movement)."
;; Left arrow (let ((h (st :input-history)) (p (st :input-hpos)))
((eq ch :left) (if (eq direction :up)
(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)))) (when (and h (< p (1- (length h))))
(incf (st :input-hpos)) (incf (st :input-hpos))
(setf (st :input-buffer) (values (nth (st :input-hpos) h) (length (nth (st :input-hpos) h))))
(reverse (coerce (nth (st :input-hpos) h) 'list)))
(setf (st :dirty) (list nil nil t)))))
;; Down arrow
((eq ch :down)
(when (> (st :input-hpos) 0) (when (> (st :input-hpos) 0)
(decf (st :input-hpos)) (decf (st :input-hpos))
(let ((h (st :input-history)))
(setf (st :input-buffer)
(if (and h (< (st :input-hpos) (length h))) (if (and h (< (st :input-hpos) (length h)))
(reverse (coerce (nth (st :input-hpos) h) 'list)) (values (nth (st :input-hpos) h) (length (nth (st :input-hpos) h)))
nil)) (values "" 0))))))
(setf (st :dirty) (list nil nil t)))))
;; PageUp — scroll back by page (10 lines) (defun handle-ppage ()
((eq ch :ppage) "Scroll chat up by one page."
(let ((max-offset (max 0 (- (length (st :messages)) 1)))) (let ((max-offset (max 0 (- (length (st :messages)) 1))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
(setf (st :dirty) (list nil t nil))) (setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page
((eq ch :npage) (defun handle-npage ()
"Scroll chat down by one page."
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(setf (st :dirty) (list nil t nil))) (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 "/")))))))
;; v0.9.0 — unified command minibuffer (replaces separate palette and slash menus) (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 <id> 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 <n> /resume <n>" 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 <number>"))))
((and (>= (length text) 7) (string-equal (subseq text 0 7) "/resume "))
(let ((n (ignore-errors (parse-integer (string-trim '(#\Space) (subseq text 7))))))
(if (and n (< n (length (symbol-value 'passepartout::*memory-snapshots*))))
(progn (passepartout::rollback-memory n) (add-msg :system (format nil "Resumed snapshot ~d" n)))
(add-msg :system "Usage: /resume <number>"))))
((or (string-equal text "/q") (string-equal text "/quit"))
(save-history)
(add-msg :system "* Goodbye *")
(send-daemon (list :type :event :payload '(:action :quit)))
(setf (st :running) nil))
((string-equal text "/reconnect")
(disconnect-daemon) (add-msg :system "* Reconnecting... *") (connect-daemon)
(setf (st :dirty) (list t t nil)))
((string-equal text "/context")
(add-msg :system "Context summary: /context why <id> or /context dropped"))
((string-equal text "/tags")
(let ((tags (or (uiop:getenv "TAG_CATEGORIES") (uiop:getenv "PRIVACY_FILTER_TAGS") "@personal")))
(add-msg :system (format nil "Tags: ~a" tags))))
(t
(add-msg :user text)
(setf (st :busy) t)
(send-daemon (list :type :event :payload (list :sensor :user-input :text text)))))))
(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."
@@ -573,8 +305,7 @@ supplied (e.g. \"/\"), pre-fill the select filter with it."
(let ((val (getf opt :value))) (let ((val (getf opt :value)))
(cond ((stringp val) (cond ((stringp val)
;; Slash command — fill input buffer ;; Slash command — fill input buffer
(setf (st :input-buffer) (reverse (coerce val 'list))) (setf (input-text) val)
(setf (st :cursor-pos) 0)
(setf (st :dirty) (list nil nil t))) (setf (st :dirty) (list nil nil t)))
((listp val) ((listp val)
;; Daemon action — send immediately ;; Daemon action — send immediately
@@ -786,8 +517,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))))
((cl-tty.input:dispatch-key-event event) ((cl-tty.input:dispatch-key-event event)
(setf (st :dirty) (list t t nil))) (setf (st :dirty) (list t t nil)))
((member k '(:enter :tab :escape :up :down)) ((member k '(:ppage :npage))
(on-key k)) (if (eq k :ppage) (handle-ppage) (handle-npage)))
(t (handler-case (t (handler-case
(progn (progn
(cl-tty.input:handle-text-input (st :text-input) event) (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)) (:npage (lambda (e) (declare (ignore e))
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
(setf (st :dirty) (list nil t nil)))) (setf (st :dirty) (list nil t nil))))
;; v0.9.0 — Readline keybindings ;; v0.9.0 — Readline keybindings (Ctrl+A/E/U/W/K handled by text-input widget)
(: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)))))
(:ctrl+y (lambda (e) (declare (ignore e)) (:ctrl+y (lambda (e) (declare (ignore e))
(let ((killed (st :kill-ring))) (let ((killed (st :kill-ring)))
(when killed (when killed
(dolist (ch (reverse (coerce killed 'list))) (let ((cur (input-text)))
(push ch (st :input-buffer))) (setf (input-text) (concatenate 'string cur killed)))
(setf (st :cursor-pos) (length (st :input-buffer)))
(setf (st :dirty) (list nil nil t)))))) (setf (st :dirty) (list nil nil t))))))
(:ctrl+l (lambda (e) (declare (ignore e)) (:ctrl+l (lambda (e) (declare (ignore e))
(setf (st :dirty) (list t t t)))) (setf (st :dirty) (list t t t))))
(:ctrl+d (lambda (e) (declare (ignore e)) (: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.")))) (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit."))))
(:ctrl+f (lambda (e) (declare (ignore e)) (:ctrl+f (lambda (e) (declare (ignore e))
(add-msg :system "Use /search <query> to find messages"))) (add-msg :system "Use /search <query> 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))) (setf (st :dirty) (list nil t nil)))
(add-msg :system "No gate trace to toggle"))))) (add-msg :system "No gate trace to toggle")))))
(:alt+enter (lambda (e) (declare (ignore e)) (: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)))) (setf (st :dirty) (list nil nil t))))
;; v0.9.0 — Ctrl+X prefix + help ;; v0.9.0 — Ctrl+X prefix + help
(:ctrl+x (lambda (e) (declare (ignore e)) (: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) ;; v0.8.0 — Prompt/local keymap (for when input is active)
(eval-when (:load-toplevel :execute) (eval-when (:load-toplevel :execute)
(cl-tty.input:defkeymap :local (cl-tty.input:defkeymap :local
(:up (lambda (e) (declare (ignore e)) (on-key :up))) (:ppage (lambda (e) (declare (ignore e)) (handle-ppage)))
(:down (lambda (e) (declare (ignore e)) (on-key :down))) (:npage (lambda (e) (declare (ignore e)) (handle-npage))))
(:escape (lambda (e) (declare (ignore e)) (on-key :escape)))))
(defvar *cat-proc* nil "Cat subprocess for keyboard input (unused — direct stdin reads)") (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)") (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 () (defun tui-main ()
(init-state) (init-state)
(setf (st :text-input) (make-text-input-with-callbacks))
(load-history) (load-history)
(theme-load) (theme-load)
(let* ((swank-port (or (ignore-errors (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) (when (> (length f) 0)
(setf (cl-tty.dialog:select-filter sel) (setf (cl-tty.dialog:select-filter sel)
(subseq f 0 (1- f)))))))) (subseq f 0 (1- f))))))))
(on-key ch)))))))) nil))))))))
;; Keyboard reader via cl-tty.input:read-event (handles CSI, SS3, UTF-8, resize) ;; Keyboard reader via cl-tty.input:read-event (handles CSI, SS3, UTF-8, resize)
(handler-case (handler-case
(multiple-value-bind (ev resize-data) (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 (equal '(:type :daemon :payload (:text "hi")) (second evs)))
(fiveam:is (null (drain-queue))))) (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 (fiveam:test test-activity-indicator
"Contract model: :busy flag is set on send and cleared on agent response." "Contract model: :busy flag is set on send and cleared on agent response."
(init-state) (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= "#e8e8e8" (theme-color :input-fg)))
(fiveam:is (string= "#FFFFFF" (theme-color :unknown-role)))) (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 (fiveam:test test-on-key-ctrl-l-redraws
"Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags." "Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags."
(init-state) (init-state)
@@ -1301,7 +907,7 @@ Returns T on success, nil on failure. Does NOT wait or retry."
(init-state) (init-state)
(dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch))) (dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch)))
(on-key 9) (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 ── ;; ── v0.7.1 Streaming ──