1333 lines
64 KiB
Common Lisp
1333 lines
64 KiB
Common Lisp
(in-package :passepartout.channel-tui)
|
|
|
|
(defun on-key (&rest args)
|
|
;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
|
|
;; backspace). Croatoan's code-key + key-name convert them to keywords
|
|
;; so the cond below can use eq.
|
|
(let* ((raw (car args))
|
|
(ch (if (and (integerp raw) (> raw 255))
|
|
(let* ((k (code-key raw))
|
|
(name (and k (key-name k))))
|
|
(or name raw))
|
|
raw)))
|
|
(cond
|
|
;; v0.7.1: Esc — interrupt streaming
|
|
((and (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))))
|
|
;; v0.7.0: Ctrl key bindings
|
|
((eql ch 21) ; Ctrl+U — clear line
|
|
(setf (st :input-buffer) nil)
|
|
(setf (st :dirty) (list nil nil t)))
|
|
((eql ch 23) ; Ctrl+W — delete word backward
|
|
(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))))
|
|
((eql ch 1) ; Ctrl+A — home
|
|
(setf (st :cursor-pos) 0))
|
|
((eql ch 5) ; Ctrl+E — end
|
|
(setf (st :cursor-pos) (length (st :input-buffer))))
|
|
((eql ch 12) ; Ctrl+L — redraw
|
|
(setf (st :dirty) (list t t t)))
|
|
((eql ch 4) ; Ctrl+D — quit on empty
|
|
(when (or (null (st :input-buffer)) (string= "" (input-string)))
|
|
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
|
|
((eql ch 6) ; v0.7.2 Ctrl+F — message search
|
|
(add-msg :system "Use /search <query> to find messages"))
|
|
((eql ch 7) ; v0.7.2 Ctrl+G — toggle gate trace collapse
|
|
(let ((gate-idx nil))
|
|
(loop for i from (1- (length (st :messages))) downto 0
|
|
for m = (aref (st :messages) i)
|
|
when (and (getf m :gate-trace) (listp (getf m :gate-trace)))
|
|
do (setf gate-idx i) (loop-finish))
|
|
(if gate-idx
|
|
(let ((cg (st :collapsed-gates)))
|
|
(if (member gate-idx cg)
|
|
(setf (st :collapsed-gates) (remove gate-idx cg))
|
|
(push gate-idx (st :collapsed-gates)))
|
|
(add-msg :system (format nil "Gate trace ~a for msg ~a"
|
|
(if (member gate-idx (st :collapsed-gates)) "hidden" "shown")
|
|
gate-idx))
|
|
(setf (st :dirty) (list nil t nil)))
|
|
(add-msg :system "No gate trace to toggle"))))
|
|
((eql ch 24) ; Ctrl+X prefix
|
|
(setf (st :pending-ctrl-x) t))
|
|
((and (st :pending-ctrl-x) (eql ch 5)) ; Ctrl+X+E — editor
|
|
(setf (st :pending-ctrl-x) nil)
|
|
(add-msg :system "Opening $EDITOR... save and exit to return.")
|
|
(setf (st :dirty) (list t t nil)))
|
|
((and (st :pending-ctrl-x) (not (eql ch 5))) ; cancel Ctrl+X
|
|
(setf (st :pending-ctrl-x) nil)
|
|
(on-key ch)
|
|
(return-from on-key nil))
|
|
;; Enter
|
|
((or (eq ch :enter) (eql ch 13) (eql ch 10)
|
|
(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)))
|
|
(focus (or (st :foveal-id) "none"))
|
|
(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: ~a — user=~a agent=~a system=~a input=~a"
|
|
*tui-theme-current-name*
|
|
(getf *tui-theme* :user)
|
|
(getf *tui-theme* :agent)
|
|
(getf *tui-theme* :system)
|
|
(getf *tui-theme* :input)))
|
|
(add-msg :system "Presets: /theme dark | light | solarized | gruvbox"))
|
|
((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: dark light solarized gruvbox" 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)
|
|
(connect-daemon))
|
|
;; 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 '("dark" "light" "solarized" "gruvbox"))
|
|
(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 #\Backspace))
|
|
(input-delete-char)
|
|
(setf (st :dirty) (list nil nil t)))
|
|
;; Left arrow
|
|
((or (eq ch :left) (eql ch 260))
|
|
(when (> (or (st :cursor-pos) 0) 0)
|
|
(decf (st :cursor-pos))
|
|
(setf (st :dirty) (list nil nil t))))
|
|
;; Right arrow
|
|
((or (eq ch :right) (eql ch 261))
|
|
(when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
|
|
(incf (st :cursor-pos))
|
|
(setf (st :dirty) (list nil nil t))))
|
|
;; Up arrow
|
|
((or (eq ch :up) (eql ch 259))
|
|
(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
|
|
((or (eq ch :down) (eql ch 258))
|
|
(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)
|
|
((or (eq ch :ppage) (eql ch 339))
|
|
(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
|
|
((or (eq ch :npage) (eql ch 338))
|
|
(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 (code-char ch))
|
|
(t nil))))
|
|
(when (and chr (graphic-char-p chr))
|
|
(input-insert-char chr)
|
|
(setf (st :dirty) (list nil nil t))))))))
|
|
|
|
;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
|
|
(defun resolve-hitl-panel (decision)
|
|
"Mark the most recent HITL panel message as resolved with DECISION."
|
|
(loop for i from (1- (length (st :messages))) downto 0
|
|
for m = (aref (st :messages) i)
|
|
when (and (getf m :panel) (not (getf m :panel-resolved)))
|
|
do (setf (getf m :panel-resolved) decision)
|
|
(setf (aref (st :messages) i) m)
|
|
(setf (st :dirty) (list nil t nil))
|
|
(loop-finish)))
|
|
|
|
;; v0.7.2 — self-help-lookup: read USER_MANUAL.org and find matching sections
|
|
(defun self-help-lookup (topic)
|
|
"Search USER_MANUAL.org for headlines matching TOPIC, return content previews."
|
|
(let* ((manual-path (merge-pathnames "projects/passepartout/docs/USER_MANUAL.org"
|
|
(merge-pathnames "memex/" (user-homedir-pathname))))
|
|
(results nil))
|
|
(handler-case
|
|
(let* ((text (uiop:read-file-string manual-path))
|
|
(lines (uiop:split-string text :separator '(#\Newline)))
|
|
(in-section nil)
|
|
(section-content nil))
|
|
(dolist (line lines)
|
|
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
|
(cond
|
|
;; New headline
|
|
((and (>= (length trimmed) 2) (eql (char trimmed 0) #\*))
|
|
;; Flush previous section if in one
|
|
(when (and in-section section-content)
|
|
(push (cons in-section (string-trim '(#\Space #\Newline)
|
|
(format nil "~{~a~^ ~}" (reverse section-content))))
|
|
results))
|
|
;; Check if this headline matches topic
|
|
(let ((title (string-trim '(#\Space #\*) trimmed)))
|
|
(if (search topic title :test #'char-equal)
|
|
(setf in-section title
|
|
section-content nil)
|
|
(setf in-section nil
|
|
section-content nil))))
|
|
;; Content line in matching section
|
|
(in-section
|
|
(when (and (> (length trimmed) 0)
|
|
(not (eql (char trimmed 0) #\#)))
|
|
(push trimmed section-content))))))
|
|
;; Flush last section
|
|
(when (and in-section section-content)
|
|
(push (cons in-section (string-trim '(#\Space #\Newline)
|
|
(format nil "~{~a~^ ~}" (reverse section-content))))
|
|
results))
|
|
(nreverse results))
|
|
(error (c) (list (cons "Error" (format nil "Cannot read manual: ~a" c)))))))
|
|
|
|
(defun on-daemon-msg (msg)
|
|
(let* ((payload (getf msg :payload))
|
|
(text (getf payload :text))
|
|
(msg-type (getf msg :type))
|
|
(action (getf payload :action))
|
|
(level (getf msg :level))
|
|
(sensor (getf payload :sensor))
|
|
(gate-trace (getf msg :gate-trace))
|
|
(rule-count (getf payload :rule-count))
|
|
(foveal-id (getf payload :foveal-id)))
|
|
;; v0.7.2: HITL approval-required panel
|
|
(when (eq level :approval-required)
|
|
(let* ((hitl-msg (or (getf payload :message)
|
|
(getf payload :text)
|
|
"HITL approval required"))
|
|
(hitl-action (getf (getf payload :action) :payload))
|
|
(tool-name (getf hitl-action :tool))
|
|
(explanation (or tool-name "unknown action")))
|
|
(add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx"
|
|
hitl-msg explanation)
|
|
:panel t))
|
|
(setf (st :dirty) (list nil t nil))
|
|
(return-from on-daemon-msg nil))
|
|
;; v0.7.1: streaming chunk
|
|
(when (eq msg-type :stream-chunk)
|
|
(cond
|
|
((string= text "")
|
|
;; Final chunk: stamp time, clear streaming
|
|
(when (> (length (st :messages)) 0)
|
|
(let ((idx (1- (length (st :messages)))))
|
|
(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 nil t nil))
|
|
(return-from on-daemon-msg nil))
|
|
((null (st :streaming-text))
|
|
;; First chunk: add new streaming message
|
|
(setf (st :streaming-text) "")
|
|
(setf (st :busy) nil)
|
|
(add-msg :agent text)
|
|
(let ((idx (1- (length (st :messages)))))
|
|
(setf (getf (aref (st :messages) idx) :streaming) t))
|
|
(setf (st :streaming-text) text)
|
|
(setf (st :dirty) (list nil t nil))
|
|
(return-from on-daemon-msg nil))
|
|
(t
|
|
;; Subsequent chunk: append
|
|
(let* ((new-text (concatenate 'string (st :streaming-text) text))
|
|
(idx (1- (length (st :messages)))))
|
|
(setf (st :streaming-text) new-text)
|
|
(setf (getf (aref (st :messages) idx) :content) new-text)
|
|
(setf (st :dirty) (list nil t nil)))
|
|
(return-from on-daemon-msg nil))))
|
|
(when rule-count (setf (st :rule-count) rule-count))
|
|
(when foveal-id (setf (st :foveal-id) foveal-id))
|
|
(cond
|
|
(text (setf (st :busy) nil)
|
|
(add-msg :agent text :gate-trace gate-trace))
|
|
((eq action :handshake)
|
|
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
|
|
(t (add-msg :agent (format nil "~a" msg))))))
|
|
|
|
(defun send-daemon (msg)
|
|
(let ((s (st :stream)))
|
|
(when (and s (open-stream-p s))
|
|
(handler-case
|
|
(progn
|
|
(format s "~a" (frame-message msg))
|
|
(finish-output s))
|
|
(error () nil)))))
|
|
|
|
(defun recv-daemon (s)
|
|
(handler-case
|
|
(let* ((hdr (make-string 6)) (n 0))
|
|
(loop while (< n 6)
|
|
do (let ((ch (read-char s nil)))
|
|
(unless ch (return-from recv-daemon nil))
|
|
(setf (char hdr n) ch) (incf n)))
|
|
(let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
|
|
(buf (make-string (or len 0))))
|
|
(when (and len (> len 0))
|
|
(loop for i from 0 below len
|
|
do (let ((ch (read-char s nil)))
|
|
(unless ch (return-from recv-daemon nil))
|
|
(setf (char buf i) ch)))
|
|
(let ((*read-eval* nil))
|
|
(read-from-string buf)))))
|
|
(error () nil)))
|
|
|
|
(defun reader-loop (s)
|
|
(let ((consecutive-nils 0))
|
|
(loop while (and (st :running) (open-stream-p s))
|
|
do (let ((msg (recv-daemon s)))
|
|
(if msg
|
|
(progn (queue-event (list :type :daemon :payload msg))
|
|
(setf consecutive-nils 0))
|
|
(progn (sleep 0.5)
|
|
(incf consecutive-nils)
|
|
(when (> consecutive-nils 10)
|
|
(queue-event (list :type :disconnected))
|
|
(return))))))))
|
|
|
|
(defun load-history ()
|
|
"Load input history from disk on TUI startup."
|
|
(let ((hist-file (merge-pathnames ".cache/passepartout/history"
|
|
(user-homedir-pathname))))
|
|
(when (uiop:file-exists-p hist-file)
|
|
(with-open-file (in hist-file :direction :input)
|
|
(loop for line = (read-line in nil nil)
|
|
while line
|
|
do (push line (st :input-history))))
|
|
(setf (st :input-history) (nreverse (st :input-history))))))
|
|
|
|
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
|
(add-msg :system "* Connecting to daemon... *")
|
|
(loop for attempt from 1 to 3
|
|
for backoff = 0 then 3
|
|
do (sleep backoff)
|
|
(handler-case
|
|
(let ((s (usocket:socket-connect host port :timeout 5)))
|
|
(setf (st :stream) (usocket:socket-stream s)
|
|
(st :connected) t)
|
|
(bt:make-thread (lambda () (reader-loop (st :stream)))
|
|
:name "tui-reader")
|
|
(add-msg :system (format nil "* Connected v~a *" "0.5.0"))
|
|
(return-from connect-daemon t))
|
|
(usocket:connection-refused-error (c)
|
|
(when (= attempt 3)
|
|
(add-msg :system (format nil "* No daemon on port ~a after ~a attempts *"
|
|
port attempt))))
|
|
(error (c)
|
|
(add-msg :system (format nil "* Connection attempt ~a failed: ~a *"
|
|
attempt c))
|
|
(when (= attempt 3)
|
|
(add-msg :system "* TIP: run 'passepartout daemon' first *")))))
|
|
nil)
|
|
|
|
(defun disconnect-daemon ()
|
|
(when (st :stream)
|
|
(ignore-errors (close (st :stream)))
|
|
(setf (st :stream) nil (st :connected) nil)
|
|
(add-msg :system "* Disconnected *")))
|
|
|
|
(defun tui-main ()
|
|
(init-state)
|
|
(load-history)
|
|
(theme-load)
|
|
(let* ((swank-port (or (ignore-errors
|
|
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
|
4006)))
|
|
(setf (st :dirty) (list t t t))
|
|
(connect-daemon)
|
|
(when (> swank-port 0)
|
|
(handler-case
|
|
(progn
|
|
(ql:quickload :swank :silent t)
|
|
(funcall (find-symbol "CREATE-SERVER" "SWANK")
|
|
:port swank-port :dont-close t)
|
|
(add-msg :system
|
|
(format nil "* Swank ~d M-x slime-connect *" swank-port)))
|
|
(error ()
|
|
(add-msg :system "* Swank unavailable *"))))
|
|
(cl-tty.input:with-raw-terminal
|
|
(cl-tty.backend:with-terminal (be w h)
|
|
(let ((prev-fb (cl-tty.rendering:make-framebuffer w h))
|
|
(curr-fb (cl-tty.rendering:make-framebuffer w h)))
|
|
;; Initial render
|
|
(redraw be curr-fb w h)
|
|
(cl-tty.rendering:flush-framebuffer prev-fb curr-fb be)
|
|
(rotatef prev-fb curr-fb)
|
|
(loop while (st :running) do
|
|
(dolist (ev (drain-queue))
|
|
(cond
|
|
((eq (getf ev :type) :daemon)
|
|
(on-daemon-msg (getf ev :payload)))
|
|
((eq (getf ev :type) :disconnected)
|
|
(setf (st :connected) nil
|
|
(st :busy) nil)
|
|
(add-msg :system "* Connection lost — type /reconnect to retry *"))))
|
|
(multiple-value-bind (type data)
|
|
(cl-tty.input:read-event be :timeout 0)
|
|
(cond
|
|
((eq type :resize)
|
|
(multiple-value-setq (w h) (cl-tty.backend:backend-size be))
|
|
(setf prev-fb (cl-tty.rendering:make-framebuffer w h)
|
|
curr-fb (cl-tty.rendering:make-framebuffer w h))
|
|
(setf (st :dirty) (list t t t)))
|
|
(data
|
|
(let ((ch (typecase data
|
|
(cl-tty.input:key-event
|
|
(cl-tty.input:key-event-key data))
|
|
(t data))))
|
|
(cond
|
|
((eql ch :escape)
|
|
(when (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)))
|
|
(when (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")))
|
|
(t (on-key ch)))))))
|
|
(when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty)))
|
|
(cl-tty.backend:backend-clear curr-fb)
|
|
(redraw be curr-fb w h)
|
|
(cl-tty.rendering:flush-framebuffer prev-fb curr-fb be)
|
|
(rotatef prev-fb curr-fb))
|
|
(sleep 0.1))))
|
|
(disconnect-daemon))))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-tui-tests
|
|
(:use :cl :passepartout :passepartout.channel-tui)
|
|
(:export #:tui-suite))
|
|
|
|
(in-package :passepartout-tui-tests)
|
|
|
|
(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling")
|
|
(fiveam:in-suite tui-suite)
|
|
|
|
(fiveam:test test-init-state
|
|
"Contract model.1: init-state returns fresh state plist with required keys."
|
|
(init-state)
|
|
(fiveam:is (eq t (st :running)))
|
|
(fiveam:is (eq :chat (st :mode)))
|
|
(fiveam:is (eq nil (st :connected)))
|
|
(fiveam:is (eq nil (st :stream)))
|
|
(fiveam:is (zerop (length (st :messages))))
|
|
(fiveam:is (eq 0 (st :scroll-offset)))
|
|
(fiveam:is (eq nil (st :busy))))
|
|
|
|
(fiveam:test test-add-msg
|
|
"Contract model.2: add-msg appends a message with role, content, and time."
|
|
(init-state)
|
|
(add-msg :user "hello")
|
|
(let* ((msgs (st :messages))
|
|
(msg (aref msgs 0)))
|
|
(fiveam:is (eq :user (getf msg :role)))
|
|
(fiveam:is (string= "hello" (getf msg :content)))
|
|
(fiveam:is (stringp (getf msg :time)))
|
|
(fiveam:is (= 5 (length (getf msg :time))))))
|
|
|
|
(fiveam:test test-add-msg-dirty-flag
|
|
"Contract model.2: add-msg sets dirty flags for status and chat."
|
|
(init-state)
|
|
(setf (st :dirty) (list nil nil nil))
|
|
(add-msg :system "boot")
|
|
(let ((dirty (st :dirty)))
|
|
(fiveam:is (eq t (first dirty)))
|
|
(fiveam:is (eq t (second dirty)))
|
|
(fiveam:is (eq nil (third dirty)))))
|
|
|
|
(fiveam:test test-queue-event-roundtrip
|
|
"Contract model.3: queue-event + drain-queue preserves events in order."
|
|
(init-state)
|
|
(queue-event '(:type :key :payload (:ch 13)))
|
|
(queue-event '(:type :daemon :payload (:text "hi")))
|
|
(let ((evs (drain-queue)))
|
|
(fiveam:is (= 2 (length evs)))
|
|
(fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs)))
|
|
(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)
|
|
(fiveam:is (eq nil (st :busy)))
|
|
;; Simulate sending a normal message (sets busy)
|
|
(dolist (ch (coerce "hello" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 343)
|
|
(fiveam:is (eq t (st :busy)))
|
|
;; Simulate receiving an agent response (clears busy)
|
|
(on-daemon-msg '(:type :event :payload (:text "hi back")))
|
|
(fiveam:is (eq nil (st :busy))))
|
|
|
|
(fiveam:test test-theme
|
|
"Contract view: *tui-theme* provides color mappings."
|
|
(fiveam:is (eq :green (getf *tui-theme* :user)))
|
|
(fiveam:is (eq :white (getf *tui-theme* :agent)))
|
|
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
|
|
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
|
|
(fiveam:is (eq :white (theme-color :unknown-role))))
|
|
|
|
(fiveam:test test-on-key-ctrl-u-clears
|
|
"Contract 1/v0.7.0: Ctrl+U clears the input buffer."
|
|
(init-state)
|
|
(dolist (ch '(#\h #\i)) (on-key (char-code ch)))
|
|
(on-key 21) ; Ctrl+U
|
|
(fiveam:is (string= "" (input-string))))
|
|
|
|
(fiveam:test test-on-key-ctrl-l-redraws
|
|
"Contract 1/v0.7.0: Ctrl+L sets all dirty flags."
|
|
(init-state)
|
|
(setf (st :dirty) (list nil nil nil))
|
|
(on-key 12) ; Ctrl+L
|
|
(let ((d (st :dirty)))
|
|
(fiveam:is (eq t (first d)))
|
|
(fiveam:is (eq t (second d)))))
|
|
|
|
(fiveam:test test-scroll-notify
|
|
"Contract/v0.7.0: add-msg sets scroll-notify when scrolled up."
|
|
(init-state)
|
|
(setf (st :scroll-at-bottom) nil)
|
|
(add-msg :agent "hi")
|
|
(fiveam:is (eq t (st :scroll-notify)))
|
|
(setf (st :scroll-at-bottom) t (st :scroll-notify) nil)
|
|
(add-msg :agent "hi2")
|
|
(fiveam:is (eq nil (st :scroll-notify))))
|
|
|
|
(fiveam:test test-tab-subcommand
|
|
"Contract/v0.7.0: Tab completes subcommand for /theme."
|
|
(init-state)
|
|
(dolist (ch (coerce "/theme " 'list)) (on-key (char-code ch)))
|
|
(on-key 9)
|
|
(fiveam:is (search "dark" (input-string) :test #'char-equal)))
|
|
|
|
;; ── v0.7.1 Streaming ──
|
|
|
|
(fiveam:test test-stream-chunk-appends
|
|
"Contract/v0.7.1: stream-chunk frame appends to last message."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :stream-chunk :payload (:text "Hello")))
|
|
(on-daemon-msg '(:type :stream-chunk :payload (:text " world")))
|
|
(let ((msgs (st :messages)))
|
|
(fiveam:is (= 1 (length msgs)))
|
|
(let ((msg (aref msgs 0)))
|
|
(fiveam:is (eq :agent (getf msg :role)))
|
|
(fiveam:is (string= "Hello world" (getf msg :content)))
|
|
(fiveam:is (eq t (getf msg :streaming))))))
|
|
|
|
(fiveam:test test-stream-chunk-final
|
|
"Contract/v0.7.1: final empty chunk stamps timestamp and clears streaming flag."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :stream-chunk :payload (:text "Hi")))
|
|
(on-daemon-msg '(:type :stream-chunk :payload (:text "")))
|
|
(let ((msg (aref (st :messages) 0)))
|
|
(fiveam:is (stringp (getf msg :time)))
|
|
(fiveam:is (string= "Hi" (getf msg :content)))
|
|
(fiveam:is (null (st :streaming-text)))))
|
|
|
|
(fiveam:test test-stream-interrupt
|
|
"Contract/v0.7.1: Esc during streaming appends [interrupted] and finalizes."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :stream-chunk :payload (:text "partial")))
|
|
(on-key 27)
|
|
(let ((msg (aref (st :messages) 0)))
|
|
(fiveam:is (stringp (getf msg :time)))
|
|
(fiveam:is (search "[interrupted]" (getf msg :content)))
|
|
(fiveam:is (null (st :streaming-text)))
|
|
(fiveam:is (null (st :busy)))))
|
|
|
|
(fiveam:test test-stream-check-skip
|
|
"Contract/v0.7.1: Esc without active streaming does nothing."
|
|
(init-state)
|
|
(on-key 27)
|
|
(fiveam:is (null (st :streaming-text)))
|
|
(fiveam:is (= 0 (length (st :messages)))))
|
|
|
|
(fiveam:test test-tab-open-url
|
|
"Contract/v0.7.1: Tab on empty input with URL message extracts URL."
|
|
(init-state)
|
|
(add-msg :agent "visit https://example.com for info")
|
|
(on-key 9)
|
|
(fiveam:is (string= "https://example.com" (st :url-buffer))))
|
|
|
|
;; ── v0.7.2 HITL Panels ──
|
|
|
|
(fiveam:test test-hitl-panel-in-on-daemon-msg
|
|
"Contract v0.7.2: approval-required messages render as HITL panels."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :EVENT :level :approval-required
|
|
:payload (:sensor :approval-required
|
|
:action (:TYPE :REQUEST :PAYLOAD (:TOOL "shell"))
|
|
:message "rm -rf blocked")))
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (eq :system (getf m :role)))
|
|
(fiveam:is (getf m :panel))
|
|
(fiveam:is (search "rm -rf" (getf m :content)))))
|
|
|
|
(fiveam:test test-hitl-panel-after-approve
|
|
"Contract v0.7.2: /approve adds confirmation and marks panel resolved."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :EVENT :level :approval-required
|
|
:payload (:sensor :approval-required :message "test")))
|
|
(dolist (ch (coerce "/approve HITL-test" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
;; Panel message (index 0) should be marked resolved
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (getf m :panel))
|
|
(fiveam:is (eq :approved (getf m :panel-resolved))))
|
|
;; Last message should be the approval confirmation
|
|
(let ((m (aref (st :messages) (1- (length (st :messages))))))
|
|
(fiveam:is (search "Approved" (getf m :content)))))
|
|
|
|
(fiveam:test test-hitl-panel-after-deny
|
|
"Contract v0.7.2: /deny marks panel as denied."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :EVENT :level :approval-required
|
|
:payload (:sensor :approval-required :message "blocked")))
|
|
(dolist (ch (coerce "/deny HITL-deny" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (getf m :panel))
|
|
(fiveam:is (eq :denied (getf m :panel-resolved)))))
|
|
|
|
(fiveam:test test-hitl-approve-parsed
|
|
"Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text."
|
|
(init-state)
|
|
(dolist (ch (coerce "/approve HITL-abcd" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 343)
|
|
;; Should add a system message confirming approval, not a user message
|
|
(let ((msgs (st :messages)))
|
|
(fiveam:is (>= (length msgs) 1))
|
|
(let ((m (aref msgs 0)))
|
|
(fiveam:is (eq :system (getf m :role)))
|
|
(fiveam:is (search "Approved" (getf m :content))))))
|
|
|
|
(fiveam:test test-hitl-deny-parsed
|
|
"Contract v0.7.2: /deny HITL-xxxx sends structured denial."
|
|
(init-state)
|
|
(dolist (ch (coerce "/deny HITL-xyz" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 343)
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (eq :system (getf m :role)))
|
|
(fiveam:is (search "Denied" (getf m :content)))))
|
|
|
|
;; ── v0.7.2 Undo/Redo ──
|
|
|
|
(fiveam:test test-undo-command
|
|
"Contract v0.7.2: /undo sends undo event."
|
|
(init-state)
|
|
(dolist (ch (coerce "/undo" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 343)
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (eq :system (getf m :role)))
|
|
(fiveam:is (search "Undo" (getf m :content)))))
|
|
|
|
(fiveam:test test-redo-command
|
|
"Contract v0.7.2: /redo sends redo event."
|
|
(init-state)
|
|
(dolist (ch (coerce "/redo" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 343)
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (eq :system (getf m :role)))
|
|
(fiveam:is (search "Redo" (getf m :content)))))
|
|
|
|
;; ── v0.7.2 Self-help ──
|
|
|
|
(fiveam:test test-why-command
|
|
"Contract v0.7.2: /why shows gate trace from last message."
|
|
(init-state)
|
|
(add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf")))
|
|
(dolist (ch (coerce "/why" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(let* ((msgs (st :messages))
|
|
(m (aref msgs (1- (length msgs)))))
|
|
(fiveam:is (eq :system (getf m :role)))
|
|
(fiveam:is (search "[BLOCKED]" (getf m :content)))
|
|
(fiveam:is (search "shell" (getf m :content)))))
|
|
|
|
(fiveam:test test-why-no-trace
|
|
"Contract v0.7.2: /why with no gate trace shows fallback message."
|
|
(init-state)
|
|
(dolist (ch (coerce "/why" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(let* ((msgs (st :messages))
|
|
(m (aref msgs (1- (length msgs)))))
|
|
(fiveam:is (search "No recent" (getf m :content)))))
|
|
|
|
;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ──
|
|
|
|
(fiveam:test test-ctrlg-toggle-gate-trace
|
|
"Contract v0.7.2: Ctrl+G toggles gate-trace collapse state."
|
|
(init-state)
|
|
(add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed)))
|
|
(on-key 7) ;; Ctrl+G — first press hides
|
|
(let* ((msgs (st :messages))
|
|
(m (aref msgs (1- (length msgs)))))
|
|
(fiveam:is (search "hidden" (getf m :content))))
|
|
(on-key 7) ;; second press shows
|
|
(let* ((msgs (st :messages))
|
|
(m (aref msgs (1- (length msgs)))))
|
|
(fiveam:is (search "shown" (getf m :content)))))
|
|
|
|
(fiveam:test test-ctrlg-no-gate-trace
|
|
"Contract v0.7.2: Ctrl+G with no gate trace shows fallback."
|
|
(init-state)
|
|
(on-key 7)
|
|
(let ((m (aref (st :messages) 0)))
|
|
(fiveam:is (search "No gate trace" (getf m :content)))))
|
|
|
|
;; ── v0.7.2 Message Search Mode ──
|
|
|
|
(fiveam:test test-search-mode-activate
|
|
"Contract v0.7.2: /search enters search mode."
|
|
(init-state)
|
|
(add-msg :agent "hello world")
|
|
(add-msg :agent "goodbye")
|
|
(dolist (ch (coerce "/search hello" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(fiveam:is (eq t (st :search-mode)))
|
|
(fiveam:is (string= "hello" (st :search-query)))
|
|
(fiveam:is (= 1 (length (st :search-matches)))))
|
|
|
|
(fiveam:test test-search-mode-escape-exits
|
|
"Contract v0.7.2: Escape exits search mode."
|
|
(init-state)
|
|
(add-msg :agent "test")
|
|
(dolist (ch (coerce "/search test" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(fiveam:is (eq t (st :search-mode)))
|
|
(on-key 27) ;; Escape
|
|
(fiveam:is (null (st :search-mode))))
|
|
|
|
(fiveam:test test-search-mode-up-down-nav
|
|
"Contract v0.7.2: Up/Down navigates between search matches."
|
|
(init-state)
|
|
(add-msg :agent "aaa hello bbb")
|
|
(add-msg :agent "ccc hello ddd")
|
|
(add-msg :agent "no match here")
|
|
(dolist (ch (coerce "/search hello" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(fiveam:is (= 0 (st :search-match-idx)))
|
|
(on-key 258) ;; Down
|
|
(fiveam:is (= 1 (st :search-match-idx)))
|
|
(on-key 259) ;; Up
|
|
(fiveam:is (= 0 (st :search-match-idx)))
|
|
(on-key 259) ;; Up (clamped)
|
|
(fiveam:is (= 0 (st :search-match-idx))))
|
|
|
|
(fiveam:test test-context-sections
|
|
"Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS."
|
|
(init-state)
|
|
(add-msg :agent "hello world")
|
|
(dolist (ch (coerce "/context" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(let ((msgs (st :messages)))
|
|
(fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs))
|
|
(fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs))
|
|
(fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs))))
|
|
|
|
(fiveam:test test-help-topic-lookup
|
|
"Contract v0.7.2: /help <topic> reads and searches USER_MANUAL.org."
|
|
(init-state)
|
|
(dolist (ch (coerce "/help configuration" 'list))
|
|
(on-key (char-code ch)))
|
|
(on-key 13)
|
|
(let ((msgs (st :messages)))
|
|
(fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs))))
|
|
|
|
(fiveam:test test-pads-page-up
|
|
"Contract v0.7.2: PageUp scrolls by page size (> 5 lines)."
|
|
(init-state)
|
|
(dotimes (i 30) (add-msg :system (format nil "msg ~d" i)))
|
|
(setf (st :scroll-offset) 0)
|
|
(on-key :ppage)
|
|
(fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines"))
|
|
|
|
(fiveam:test test-pads-page-down-clamp
|
|
"Contract v0.7.2: PageDown clamps to 0."
|
|
(init-state)
|
|
(dotimes (i 5) (add-msg :system (format nil "msg ~d" i)))
|
|
(setf (st :scroll-offset) 3)
|
|
(on-key :npage)
|
|
(fiveam:is (= 0 (st :scroll-offset))))
|