diff --git a/docs/.#ROADMAP.org b/docs/.#ROADMAP.org new file mode 120000 index 0000000..8ab6b0e --- /dev/null +++ b/docs/.#ROADMAP.org @@ -0,0 +1 @@ +user@amr.1407003:1778162380 \ No newline at end of file diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp index cf3fbc8..15e5fdb 100644 --- a/lisp/channel-tui-main.lisp +++ b/lisp/channel-tui-main.lisp @@ -1,34 +1,9 @@ (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)) - (or (let* ((k (code-key raw)) - (name (and k (key-name k)))) - name) - ;; Fallback for known ncurses codes when Croatoan - ;; key tables aren't available (e.g. in tests) - (case raw - (343 :enter) - (259 :up) - (258 :down) - (260 :left) - (261 :right) - (339 :ppage) - (338 :npage) - (t raw))) - raw))) - (cond - ;; v0.8.0: minibuffer dialog active — route through cl-tty select - ((and (boundp 'cl-tty.dialog:*dialog-stack*) - cl-tty.dialog:*dialog-stack* - (minibuffer-handle-key ch)) - (setf (st :dirty) (list t t nil))) - ;; v0.7.1: Esc — interrupt streaming - ((and (eql ch 27) (st :streaming-text)) +(defun on-key (ch) + (cond + ;; v0.7.1: Esc — interrupt streaming + ((and (eq ch :escape) (st :streaming-text)) (send-daemon (list :type :event :payload '(:action :cancel-stream))) (when (> (length (st :messages)) 0) (let ((idx (1- (length (st :messages))))) @@ -42,14 +17,14 @@ (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)) + ((and (eq ch :escape) (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))) + ((and (st :search-mode) (eq ch :up)) (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) (new-idx (max 0 (1- idx)))) @@ -58,7 +33,7 @@ (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))) + ((and (st :search-mode) (eq ch :down)) (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) (new-idx (min (1- (length matches)) (1+ idx)))) @@ -68,7 +43,7 @@ (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))) + ((and (st :search-mode) (eq ch :enter)) (let ((matches (st :search-matches)) (idx (st :search-match-idx))) (when (and matches (>= (length matches) (1+ idx))) @@ -79,7 +54,7 @@ (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)) + ((and (eq ch :tab) (null (st :input-buffer))) (if (st :url-buffer) ;; Already extracted — now open it @@ -96,7 +71,7 @@ when content do (let ((pos (or (search "https://" content) (search "http://" content)))) (when pos - (let ((end (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab #\)))) + (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)) @@ -108,35 +83,27 @@ (setf (st :dirty) (list t t nil))) nil)))) ;; v0.7.0: Ctrl key bindings - ((eql ch 21) ; Ctrl+U — clear line + ((eq ch :ctrl-u) (setf (st :input-buffer) nil) (setf (st :dirty) (list nil nil t))) - ((eql ch 23) ; Ctrl+W — delete word backward + ((eq ch :ctrl-w) (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 + ((eq ch :ctrl-a) (setf (st :cursor-pos) 0)) - ((eql ch 5) ; Ctrl+E — end + ((eq ch :ctrl-e) (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 + ((eq ch :ctrl-l) + (setf (st :dirty) (list t t t))) + ((eq ch :ctrl-d) (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 to find messages")) - ((eql ch 28) ; v0.8.0 Ctrl+\ — open setup minibuffer - (open-minibuffer) - ;; If minibuffer opens, simulate typing /setup to filter to it - (when cl-tty.dialog:*dialog-stack* - (let ((sel (cl-tty.dialog:dialog-content (first cl-tty.dialog:*dialog-stack*)))) - (when (typep sel 'select) - (setf (cl-tty.select:select-filter sel) "setup")))) - (setf (st :dirty) (list t t nil))) - ((eql ch 7) ; v0.7.2 Ctrl+G — toggle gate collapse + ((eq ch :ctrl-f) + (add-msg :system "Use /search to find messages")) + ((eq ch :ctrl-g) (let ((gate-idx nil)) (loop for i from (1- (length (st :messages))) downto 0 for m = (aref (st :messages) i) @@ -152,50 +119,18 @@ gate-idx)) (setf (st :dirty) (list nil t nil))) (add-msg :system "No gate trace to toggle")))) - ((eql ch 24) ; Ctrl+X prefix + ((eq ch :ctrl-x) (setf (st :pending-ctrl-x) t)) - ((and (st :pending-ctrl-x) (eql ch 2)) ; Ctrl+X+B — toggle sidebar - (setf (st :pending-ctrl-x) nil) - (passepartout.channel-tui::sidebar-toggle) - (add-msg :system (if (st :sidebar-visible) "Sidebar shown (Ctrl+X+B to hide)" "Sidebar hidden"))) - ((eql ch 16) ; v0.8.0 Ctrl+P — open command palette (daemon commands) - (progn - (open-command-palette) - (setf (st :dirty) (list t t nil)))) - ((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 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 + ((and (st :pending-ctrl-x) (eq ch :ctrl-e)) ; 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 + ((and (st :pending-ctrl-x) (not (eq ch :ctrl-e))) ; 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)) + ((eq ch :enter) ;; 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)) @@ -272,49 +207,80 @@ (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 - ;; /tags command — tag stack + ;; /tags command — tag stack with trigger counts ((string-equal text "/tags") - (let ((cats *tag-categories*)) + (let ((cats passepartout::*tag-categories*) + (counts passepartout::*tag-trigger-count*)) (if cats (dolist (entry cats) - (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) + (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 — context visibility - ((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 '*cognitive-tool-registry*) - (floor (* (hash-table-count *cognitive-tool-registry*) 40) 4) + ;; /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))) - (overhead-tokens 200) - (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) - (total-limit 8192) - (pct-used (floor (* 100 total-est) total-limit))) - (add-msg :system (format nil "Context: ~d msgs, focus=~a, ~d/~d tokens (~d%)" - msg-count focus total-est total-limit pct-used)) - (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) - (add-msg :system (format nil "LOGS ~5d tokens" log-tokens)) - (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) - (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)))) - ;; /context why — debug node + (log-tokens (min 4000 (floor (* msg-count 60) 4))) + ;; rough estimate: TIME, CONTEXT overhead + (overhead-tokens 200) + (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) + (total-limit 8192) + (pct-used (floor (* 100 total-est) total-limit)) + (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) + :initial-element #\#))) + (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) + (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) + (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) + (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) + (add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count)) + (add-msg :system (format nil " [~a~a] ~d%" + bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used)) + (when (> pct-used 80) + (add-msg :system "⚠ Context near limit — older messages may be dropped")))) + ;; /context why — debug node with full attributes ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) (let ((node-id (string-trim '(#\Space) (subseq text 13)))) - (if (fboundp 'memory-object-get) - (let ((obj (funcall 'memory-object-get node-id))) + (if (fboundp 'passepartout::memory-object-get) + (let ((obj (funcall 'passepartout::memory-object-get node-id))) (if obj - (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" - node-id - (memory-object-type obj) - (memory-object-scope obj) - (memory-object-version obj))) - (add-msg :system (format nil "Node ~a not found" node-id)))) + (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 — pruned nodes + ;; /context dropped — estimate pruned nodes from budget ((string-equal text "/context dropped") - (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)")) + (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)))) @@ -341,18 +307,18 @@ (let* ((n-str (string-trim '(#\Space) (subseq text 8))) (n (handler-case (parse-integer n-str) (error () nil)))) (if n - (if (fboundp 'rollback-memory) + (if (fboundp 'passepartout::rollback-memory) (let* ((idx (1- n)) - (snaps *memory-snapshots*) + (snaps passepartout::*memory-snapshots*) (ts (when (< idx (length snaps)) (getf (nth idx snaps) :timestamp)))) - (funcall 'rollback-memory idx) + (funcall 'passepartout::rollback-memory idx) (add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts))) (add-msg :system "Memory rollback not available")) (add-msg :system "Usage: /rewind ")))) ;; /sessions command — list snapshots ((string-equal text "/sessions") - (let ((snaps *memory-snapshots*)) + (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):" @@ -367,45 +333,50 @@ (add-msg :system "No snapshots available")))) ;; /audit verify — memory integrity ((string-equal text "/audit verify") - (let ((count 0) (hashed 0)) - (maphash (lambda (k v) (declare (ignore k)) - (when v - (incf count) - (when (memory-object-hash v) - (incf hashed)))) - *memory-store*) - (add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots" - count hashed - (length *memory-snapshots*))))) + (if (fboundp 'passepartout::audit-verify-hash) + (let* ((result (funcall 'passepartout::audit-verify-hash)) + (total (car result)) + (missing (cdr result))) + (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" + total missing + (length passepartout::*memory-snapshots*) + (zerop missing) + (unless (zerop missing) missing)))) + (add-msg :system "Memory audit not available"))) ;; /resume — resume from snapshot ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) (let* ((n-str (string-trim '(#\Space) (subseq text 8))) (n (handler-case (parse-integer n-str) (error () nil)))) (if n - (if (fboundp 'rollback-memory) - (progn (funcall 'rollback-memory (1- n)) + (if (fboundp 'passepartout::rollback-memory) + (progn (funcall 'passepartout::rollback-memory (1- n)) (add-msg :system (format nil "Resumed from snapshot ~d" n))) (add-msg :system "Memory rollback not available")) (add-msg :system "Usage: /resume ")))) ;; /help — search user manual ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) - (let* ((topic (string-trim '(#\Space) (subseq text 6))) - (results (self-help-lookup topic))) - (dolist (entry results) - (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) - (unless results - (add-msg :system (format nil "Topic '~a' not found in USER_MANUAL.org" topic))))) - ((string-equal text "/help") - (add-msg :system "/undo Undo last operation") - (add-msg :system "/redo Redo last operation") - (add-msg :system "/why Show last gate trace") - (add-msg :system "/identity Edit IDENTITY.org") - (add-msg :system "/tags List tag severities") - (add-msg :system "/audit Inspect memory object") - (add-msg :system "/search Search messages") - (add-msg :system "/context Show context summary") - (add-msg :system "/eval Evaluate Lisp") - (add-msg :system "/rewind Rewind to snapshot N") + (let ((topic (string-trim '(#\Space) (subseq text 6))) + (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) + (if sections + (dolist (entry sections) + (let* ((title (car entry)) + (content (cdr entry)) + (preview (if (> (length content) 300) + (concatenate 'string (subseq content 0 297) "...") + content))) + (add-msg :system (format nil "~a: ~a" title preview)))) + (add-msg :system (format nil "No manual section found for '~a'" topic))))) + ((string-equal text "/help") + (add-msg :system "/eval Evaluate Lisp") + (add-msg :system "/undo Undo last operation") + (add-msg :system "/redo Redo last operation") + (add-msg :system "/why Show last gate trace") + (add-msg :system "/identity Edit IDENTITY.org") + (add-msg :system "/tags List tag severities") + (add-msg :system "/audit Inspect memory object") + (add-msg :system "/search Search messages") + (add-msg :system "/context Show context summary") + (add-msg :system "/rewind Rewind to snapshot N") (add-msg :system "/sessions Show snapshots") (add-msg :system "/resume Resume from snapshot") (add-msg :system "/focus Set project context") @@ -413,15 +384,7 @@ (add-msg :system "/help [topic] Show this help") (add-msg :system "\\ + Enter Multi-line input") (add-msg :system "Ctrl+G Toggle gate trace")) - ;; /setup command — open minibuffer filtered to setup - ((string-equal text "/setup") - (open-minibuffer) - (when cl-tty.dialog:*dialog-stack* - (let ((sel (cl-tty.dialog:dialog-content (first cl-tty.dialog:*dialog-stack*)))) - (when (typep sel 'select) - (setf (cl-tty.select:select-filter sel) "setup")))) - (setf (st :dirty) (list t t nil))) - ;; /theme command + ;; /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* @@ -501,7 +464,7 @@ (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)) + ((eq ch :tab) (let ((text (input-string))) (cond ;; @ prefix — file path completion @@ -557,22 +520,21 @@ (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)) + ((eq ch :backspace) (input-delete-char) (setf (st :dirty) (list nil nil t))) ;; Left arrow - ((or (eq ch :left) (eql ch 260)) + ((eq ch :left) (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)) + ((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 - ((or (eq ch :up) (eql ch 259)) + ((eq ch :up) (let* ((h (st :input-history)) (p (st :input-hpos))) (when (and h (< p (1- (length h)))) (incf (st :input-hpos)) @@ -580,7 +542,7 @@ (reverse (coerce (nth (st :input-hpos) h) 'list))) (setf (st :dirty) (list nil nil t))))) ;; Down arrow - ((or (eq ch :down) (eql ch 258)) + ((eq ch :down) (when (> (st :input-hpos) 0) (decf (st :input-hpos)) (let ((h (st :input-history))) @@ -589,354 +551,27 @@ (reverse (coerce (nth (st :input-hpos) h) 'list)) nil)) (setf (st :dirty) (list nil nil t))))) - ;; PageUp - ((or (eq ch :ppage) (eql ch 339)) - (let ((page-size (max 10 (floor (length (st :messages)) 3)))) - (setf (st :scroll-offset) (+ (st :scroll-offset) page-size))) + ;; PageUp — scroll back by page (10 lines) + ((eq ch :ppage) + (let ((max-offset (max 0 (- (length (st :messages)) 1)))) + (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) (setf (st :dirty) (list nil t nil))) - ;; PageDown - ((or (eq ch :npage) (eql ch 338)) - (let ((page-size (max 10 (floor (length (st :messages)) 3)))) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) page-size)))) + ;; PageDown — scroll forward by page + ((eq ch :npage) + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) (setf (st :dirty) (list nil t nil))) - ;; Printable - (t - (let ((chr (typecase ch - (character ch) - (integer (code-char ch)) - (t nil)))) - (when (and chr (graphic-char-p chr)) - (input-insert-char chr) - (setf (st :dirty) (list nil nil t)))))))) - - -;; v0.8.0 — Minibuffer: *slash-commands*, open-minibuffer, minibuffer-handle-key, make-wizard-dialog - -(defvar *slash-commands* - (list (list :name "/focus" :desc "Set project context" - :action (lambda () (add-msg :system "/focus"))) - (list :name "/scope" :desc "Change context scope" - :action (lambda () (add-msg :system "/scope memex|session|project"))) - (list :name "/unfocus" :desc "Pop context stack" - :action (lambda () (send-daemon (list :type :event :payload (list :sensor :unfocus))))) - (list :name "/search" :desc "Search messages" - :action (lambda () (add-msg :system "Use /search "))) - (list :name "/why" :desc "Show last gate trace" - :action (lambda () (add-msg :system "Gate trace: use /why"))) - (list :name "/audit" :desc "Inspect memory object" - :action (lambda () (add-msg :system "/audit "))) - (list :name "/context" :desc "Show context budget" - :action (lambda () (add-msg :system "/context"))) - (list :name "/theme" :desc "Switch color theme" - :action (lambda () (add-msg :system "Presets: dark light solarized gruvbox"))) - (list :name "/sidebar" :desc "Toggle sidebar" - :action #'sidebar-toggle) - (list :name "/help" :desc "Show all commands" - :action (lambda () (add-msg :system "Commands: /focus /scope /search /theme /eval /setup /quit ..."))) - (list :name "/setup" :desc "Run setup wizard" - :action (lambda () (make-wizard-dialog))) - (list :name "/eval" :desc "Evaluate Lisp expression" - :action (lambda () (add-msg :system "/eval "))) - (list :name "/reconnect" :desc "Reconnect to daemon" - :action (lambda () (disconnect-daemon) (connect-daemon))) - (list :name "/quit" :desc "Save history and exit" - :action (lambda () (add-msg :system "* Goodbye *") - (send-daemon (list :type :event :payload '(:action :quit))) - (setf (st :running) nil)))) - "~25 slash commands driving cl-tty's Select widget in the minibuffer.") - -(defun open-minibuffer () - "Push a cl-tty.dialog:select-dialog with *slash-commands* onto cl-tty's dialog stack." - (cl-tty.dialog:push-dialog - (cl-tty.dialog:select-dialog - "Commands" - (loop for cmd in *slash-commands* - collect (list :title (getf cmd :name) - :value cmd - :desc (getf cmd :desc))) - :on-select (lambda (opt) - (let ((cmd (getf opt :value)) - (action (when cmd (getf cmd :action)))) - (when action (funcall action))))))) - -(defvar *daemon-commands* - (list - ;; Category: Session - (list :title "── Session ──" :category t) - (list :title "Focus Project" :value :focus :desc "Set project context" - :action (lambda () (add-msg :system "Usage: /focus "))) - (list :title "Change Scope" :value :scope :desc "Switch scope: memex|session|project" - :action (lambda () (add-msg :system "Usage: /scope memex|session|project"))) - (list :title "Unfocus" :value :unfocus :desc "Pop context stack" - :action (lambda () (send-daemon (list :type :event :payload (list :sensor :unfocus))))) - (list :title "Show Context" :value :context :desc "Show context budget summary" - :action (lambda () (add-msg :system "Use /context for budget or /context why for node details"))) - ;; Category: Memory - (list :title "── Memory ──" :category t) - (list :title "List Sessions" :value :sessions :desc "List memory snapshots" - :action (lambda () (add-msg :system "Use /sessions to list snapshots"))) - (list :title "Rewind" :value :rewind :desc "Rewind to snapshot" - :action (lambda () (add-msg :system "Usage: /rewind "))) - (list :title "Audit Node" :value :audit :desc "Inspect memory object" - :action (lambda () (add-msg :system "Usage: /audit "))) - ;; Category: System - (list :title "── System ──" :category t) - (list :title "Reconnect" :value :reconnect :desc "Reconnect to daemon" - :action (lambda () (disconnect-daemon) (connect-daemon))) - (list :title "Quit" :value :quit :desc "Save history and exit" - :action (lambda () (add-msg :system "* Goodbye *") - (send-daemon (list :type :event :payload '(:action :quit))) - (setf (st :running) nil))) - ;; Category: Help - (list :title "── Help ──" :category t) - (list :title "Show Help" :value :help :desc "Show all commands" - :action (lambda () (add-msg :system "Commands: /focus /scope /search /theme /eval /setup /quit ..."))) - (list :title "Why" :value :why :desc "Show last gate trace" - :action (lambda () (add-msg :system "Use /why to see last gate trace"))) - (list :title "Identity" :value :identity :desc "Edit IDENTITY.org" - :action (lambda () (add-msg :system "Use /identity to edit"))) - (list :title "Tags" :value :tags :desc "List tag severities" - :action (lambda () (add-msg :system "Use /tags to list tag severities")))) - "Daemon commands for the command palette (Ctrl+P), organized by category.") - -(defun open-command-palette () - "Push a select-dialog with *daemon-commands* onto cl-tty's dialog stack. - Ctrl+P opens this palette. Categories: Session, Memory, System, Help." - (cl-tty.dialog:push-dialog - (cl-tty.dialog:select-dialog - "Command Palette" - (loop for cmd in *daemon-commands* - collect (list :title (getf cmd :title) - :value cmd - :desc (getf cmd :desc) - :category (getf cmd :category))) - :on-select (lambda (opt) - (let ((cmd (getf opt :value)) - (action (when cmd (getf cmd :action)))) - (when action (funcall action))))))) - -(defun croatoan-to-tty-event (ch) - "Convert a Croatoan key code to a cl-tty key-event struct." - (typecase ch - (keyword - (case ch - (:up (cl-tty.input:make-key-event :key :up)) - (:down (cl-tty.input:make-key-event :key :down)) - (:enter (cl-tty.input:make-key-event :key :enter)) - (:escape (cl-tty.input:make-key-event :key :escape)) - (:backspace (cl-tty.input:make-key-event :key :backspace)) - (:ppage (cl-tty.input:make-key-event :key :page-up)) - (:npage (cl-tty.input:make-key-event :key :page-down)) - (t (cl-tty.input:make-key-event :key ch)))) - (integer - (cond - ((= ch 27) (cl-tty.input:make-key-event :key :escape)) - ((or (= ch 13) (= ch 10)) (cl-tty.input:make-key-event :key :enter)) - ((or (= ch 263) (= ch 127) (= ch 8)) (cl-tty.input:make-key-event :key :backspace)) - ((= ch 259) (cl-tty.input:make-key-event :key :up)) - ((= ch 258) (cl-tty.input:make-key-event :key :down)) - ((= ch 260) (cl-tty.input:make-key-event :key :left)) - ((= ch 261) (cl-tty.input:make-key-event :key :right)) - ((= ch 339) (cl-tty.input:make-key-event :key :page-up)) - ((= ch 338) (cl-tty.input:make-key-event :key :page-down)) - ((<= 1 ch 26) (cl-tty.input:make-key-event - :key (intern (string (code-char (+ #x60 ch))) :keyword) - :ctrl t)) - ((<= 32 ch 126) (cl-tty.input:make-key-event - :key (intern (string (char-upcase (code-char ch))) :keyword))) - (t (cl-tty.input:make-key-event :key :unknown :code ch)))) - (t nil))) - -(defun minibuffer-handle-key (ch) - "Route Croatoan key through the active dialog's select widget. - Printable chars update the filter; special keys route through cl-tty.select:select-handle-key. - Returns T if the dialog consumed the key." - (let ((stack cl-tty.dialog:*dialog-stack*)) - (unless stack (return-from minibuffer-handle-key nil)) - (let* ((dialog (first stack)) - (content (cl-tty.dialog:dialog-content dialog))) - (unless (typep content 'cl-tty.select:select) - (return-from minibuffer-handle-key nil)) - ;; Backspace: pop last filter char (if any) or pop dialog when empty - (when (or (eql ch :backspace) (eql ch 263) (eql ch 127) (eql ch 8)) - (let ((f (cl-tty.select:select-filter content))) - (if (and f (> (length f) 0)) - (progn (setf (cl-tty.select:select-filter content) (subseq f 0 (1- (length f)))) - (cl-tty.select::select-clamp-index content) - t) - (progn (cl-tty.dialog:pop-dialog) t)))) - ;; Escape: pop the dialog - (when (or (eql ch 27) (eq ch :escape)) - (cl-tty.dialog:pop-dialog) - t) - ;; Printable: append to filter if dialog is a select - (when (and (integerp ch) (<= 32 ch 126)) - (let* ((c (code-char ch)) - (f (or (cl-tty.select:select-filter content) ""))) - (setf (cl-tty.select:select-filter content) - (concatenate 'string f (string c))) - (cl-tty.select::select-clamp-index content) - t)) - ;; Route through cl-tty.select:select-handle-key for navigation/selection - (let ((ev (croatoan-to-tty-event ch))) - (when ev - (handler-case - (cl-tty.select:select-handle-key content ev) - (error () nil))))))) - -(defun make-wizard-dialog () - "Create a setup wizard dialog daisy-chain: provider select → API key → save. - Validates at each step; final step writes ~/.passepartout/config.lisp." - (let* ((state (list :provider nil :api-key nil :memory "1000" :step 0)) - (step-labels '("Provider" "API Key" "Memory" "Review & Save")) - (step-fns - (list - ;; Step 0: provider selection - (lambda (input) - (let ((p (string-downcase (string-trim '(#\Space) input)))) - (if (member p '("openai" "anthropic" "ollama" "openrouter" "deepseek" "groq") :test #'string=) - (progn (setf (getf state :provider) p) nil) - (format nil "Unknown provider: ~a" input)))) - ;; Step 1: API key - (lambda (input) - (let ((k (string-trim '(#\Space) input))) - (if (> (length k) 4) - (progn (setf (getf state :api-key) k) nil) - "Key too short"))) - ;; Step 2: memory limit - (lambda (input) - (let ((v (string-trim '(#\Space) input))) - (if (or (string= v "") (string= v "1000")) - nil - (if (every #'digit-char-p v) - (progn (setf (getf state :memory) v) nil) - "Enter a number")))) - ;; Step 3: save - (lambda (input) - (let ((v (string-downcase (string-trim '(#\Space) input)))) - (cond ((string= v "yes") - (let ((env-path (merge-pathnames ".passepartout/config.lisp" - (user-homedir-pathname)))) - (handler-case - (progn - (uiop:ensure-all-directories-exist (list env-path)) - (with-open-file (out env-path :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (format out ";; Passepartout configuration~%") - (format out "(setf *provider* ~s)~%" (getf state :provider)) - (format out "(setf *api-key* ~s)~%" (getf state :api-key)) - (format out "(setf *memory-max-entries* ~s)~%" (getf state :memory)))) - (error (c) (format nil "Write failed: ~a" c)))) - nil) - ((string= v "no") nil) - (t "Type 'yes' or 'no'"))))))) - (labels ((advance () - (let* ((step (getf state :step)) - (fn (nth step step-fns)) - (err (funcall fn "ignored"))) - (declare (ignore fn)) - ;; Push next prompt dialog or finish - (if (< step (1- (length step-labels))) - (progn - (setf (getf state :step) (1+ step)) - (cl-tty.dialog:push-dialog - (cl-tty.dialog:prompt-dialog - (format nil "~a — ~a" (nth (getf state :step) step-labels) - (getf state :provider)) - :on-submit (lambda (val) - (let ((validation (funcall (nth (getf state :step) step-fns) val))) - (if validation - (progn - (cl-tty.dialog:push-dialog - (cl-tty.dialog:alert-dialog "Error" validation)) - (setf (getf state :step) (1- step))) - (advance))))))) - (add-msg :system (format nil "Configuration saved (~a). Run /reconnect." - (getf state :provider))))))) - ;; Push the first prompt dialog - (cl-tty.dialog:push-dialog - (cl-tty.dialog:prompt-dialog - "Setup — LLM Provider" - :on-submit (lambda (val) - (let ((err (funcall (first step-fns) val))) - (if err - (cl-tty.dialog:push-dialog - (cl-tty.dialog:alert-dialog "Invalid" err)) - (advance))))))))) - -(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))) - -(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)) + ;; Printable (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)))))) + (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)))))))) ;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny (defun resolve-hitl-panel (decision) @@ -1044,13 +679,8 @@ (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)) - ;; v0.8.0: sidebar enrichment fields - (when (getf payload :block-counts) (setf (st :block-counts) (getf payload :block-counts))) - (when (getf payload :context-usage) (setf (st :context-usage) (getf payload :context-usage))) - (when (getf payload :modified-files) (setf (st :modified-files) (getf payload :modified-files))) - (when (getf payload :session-cost) (setf (st :session-cost) (getf payload :session-cost))) + (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)) @@ -1139,169 +769,67 @@ (setf (st :stream) nil (st :connected) nil) (add-msg :system "* Disconnected *"))) -(defun tui-run-screen (scr) - "The full TUI event loop. Called from tui-main inside with-screen." - (let* ((h (or (height scr) 24)) - (w (or (width scr) 80)) - (sidebar-w (when (>= w 120) - (make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44)))) - (content-w (if sidebar-w (- w 44) (- w 2))) - (ch (- h 5)) - (sw (make-instance 'window :height 3 :width content-w :y 0 :x 1)) - (cw (make-instance 'window :height ch :width content-w :y 3 :x 1)) - (iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1)) - (swank-port (or (ignore-errors - (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) - 4006))) - (setf (function-keys-enabled-p iw) t - (input-blocking iw) nil - (st :dirty) (list t t t) - (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw) - (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 *")))) - (flet ((recreate-windows (scr-width scr-height) - (let* ((new-w scr-width) - (new-h scr-height) - (has-sidebar (and (>= new-w 120) (st :sidebar-visible))) - (new-sidebar-w (when has-sidebar - (make-instance 'window :height (- new-h 5) - :width 42 :y 3 :x (- new-w 44)))) - (new-content-w (if new-sidebar-w (- new-w 44) (- new-w 2))) - (new-ch (- new-h 5))) - (setq sw (make-instance 'window :height 3 :width new-content-w :y 0 :x 1) - ch new-ch - cw (make-instance 'window :height new-ch :width new-content-w :y 3 :x 1) - iw (make-instance 'window :height 1 :width new-content-w :y (- new-h 1) :x 1) - sidebar-w new-sidebar-w - w new-w - h new-h) - (setf (function-keys-enabled-p iw) t - (input-blocking iw) nil - (st :dirty) (list t t t) - (st :sw) sw (st :cw) cw (st :iw) iw)))) - (let ((initial-sidebar (and (>= w 120) (st :sidebar-visible)))) - (when initial-sidebar - (view-sidebar (or sidebar-w - (make-instance 'window :height (- h 5) :width 42 - :y 3 :x (- w 44)))) - (refresh (or sidebar-w - (make-instance 'window :height (- h 5) :width 42 - :y 3 :x (- w 44)))))) - (redraw sw cw ch iw) - (when sidebar-w - (view-sidebar sidebar-w) - (refresh sidebar-w)) - ;; v0.8.0: render cl-tty dialog overlay when stack is non-empty - (when (and (boundp 'cl-tty.dialog:*dialog-stack*) - cl-tty.dialog:*dialog-stack*) - (render-dialog-overlay scr w h)) - (refresh scr) - (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 *")))) - (let ((ch (get-char iw))) - (cond - ((or (not ch) (equal ch -1)) nil) - ((eql ch 410) - (recreate-windows (or (width scr) 80) (or (height scr) 24)) - (redraw sw cw ch iw) - (refresh scr)) - (t (ignore-errors (on-key ch))))) - (redraw sw cw ch iw) - (when sidebar-w - (view-sidebar sidebar-w) - (refresh sidebar-w)) - ;; Recreate windows when sidebar visibility or terminal width changes - (let ((sidebar-wanted (and (st :sidebar-visible) (>= w 120)))) - (when (or (and sidebar-wanted (not sidebar-w)) - (and (not sidebar-wanted) sidebar-w)) - (recreate-windows w h) - (redraw sw cw ch iw))) - ;; v0.8.0: render cl-tty dialog overlay - (when (and (boundp 'cl-tty.dialog:*dialog-stack*) - cl-tty.dialog:*dialog-stack*) - (render-dialog-overlay scr w h)) - (refresh scr) - (sleep 0.03)) - (disconnect-daemon)))) - -(defun render-dialog-overlay (scr w h) - "Render the top cl-tty dialog as a Croatoan overlay. - Draws a dimmed backdrop then a centered bordered panel with select options." - (let* ((dialog (first cl-tty.dialog:*dialog-stack*)) - (title (cl-tty.dialog:dialog-title dialog)) - (content (cl-tty.dialog:dialog-content dialog)) - (ww (min 60 (- w 4))) - (wh (min 18 (- h 4))) - (wx (floor (- w ww) 2)) - (wy (floor (- h wh) 2))) - ;; Dimmed backdrop - (dotimes (row h) - (add-string scr (make-string w :initial-element #\Space) - :y row :x 0 :fgcolor (theme-color :dim) :bgcolor (theme-color :background))) - ;; Dialog panel window - (let ((win (make-instance 'window :height wh :width ww :y wy :x wx))) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (add-string win (format nil " ~a " title) :y 0 :x 2 :fgcolor (theme-color :accent)) - ;; Render select widget options - (when (typep content 'cl-tty.select:select) - (let* ((filtered (cl-tty.select:select-filtered-options content)) - (sel-idx (cl-tty.select:select-selected-index content)) - (filter-str (cl-tty.select:select-filter content)) - (y 1)) - ;; Show filter line - (add-string win (format nil " > ~a_" (or filter-str "")) - :y y :x 2 :n (- ww 4) :fgcolor (theme-color :input)) - (incf y) - ;; Show filtered options - (dolist (item filtered) - (when (< y (1- wh)) - (let* ((display-idx (first item)) - (option (third item)) - (title-str (getf option :title)) - (desc (getf option :desc)) - (is-selected (= display-idx sel-idx)) - (fg (if is-selected (theme-color :highlight) (theme-color :agent)))) - (when is-selected - (setf (color-pair win) (list (theme-color :highlight) (theme-color :dim))) - (add-string win (make-string (- ww 2) :initial-element #\Space) - :y y :x 1 :n (- ww 2)) - (setf (color-pair win) (list (theme-color :border) (theme-color :background)))) - (add-string win (format nil "~a ~a" (if is-selected ">" " ") title-str) - :y y :x 2 :n (min 25 (- ww 4)) :fgcolor fg) - (when (and desc (not is-selected)) - (add-string win (format nil " ~a" desc) :y y :x 28 :n (- ww 30) - :fgcolor (theme-color :dim))) - (incf y)))) - ;; Footer hint - (add-string win (format nil " ~a/~a | ↑↓ Navigate Enter Execute Esc Close" - (1+ sel-idx) (length filtered)) - :y (1- wh) :x 1 :n (- ww 2) :fgcolor (theme-color :dim)))) - (refresh win) - (close win)))) - (defun tui-main () (init-state) (load-history) (theme-load) - (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) - (tui-run-screen scr))) + (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 + (let ((k (cl-tty.input:key-event-key data)) + (ctrl (cl-tty.input:key-event-ctrl data))) + (if ctrl + (intern (format nil "CTRL-~a" k) :keyword) + k))) + (t data)))) + (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)) @@ -1777,104 +1305,3 @@ (setf (st :scroll-offset) 3) (on-key :npage) (fiveam:is (= 0 (st :scroll-offset)))) - -(in-package :passepartout-tui-tests) - -(fiveam:test test-theme-hex-to-rgb - "Contract 4: theme-hex-to-rgb parses #RRGGBB to integer triple." - (multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "#5E81AC") - (fiveam:is (= 94 r)) - (fiveam:is (= 129 g)) - (fiveam:is (= 172 b)))) - -(fiveam:test test-theme-hex-to-rgb-invalid - "Contract 4: theme-hex-to-rgb returns white for invalid input." - (multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "not-a-color") - (fiveam:is (= 255 r)) - (fiveam:is (= 255 g)) - (fiveam:is (= 255 b)))) - -(fiveam:test test-sidebar-toggle - "Contract 7: sidebar-toggle flips :sidebar-visible and sets dirty flags." - (init-state) - (setf (st :dirty) (list nil nil nil)) - (passepartout.channel-tui::sidebar-toggle) - (fiveam:is (eq t (st :sidebar-visible))) - (fiveam:is (eq t (first (st :dirty)))) - (fiveam:is (eq t (second (st :dirty))))) - -(fiveam:test test-ctrl-x-b-toggles-sidebar - "Contract 5: Ctrl+X then Ctrl+B toggles sidebar." - (init-state) - (on-key 24) ; Ctrl+X - (fiveam:is (eq t (st :pending-ctrl-x))) - (on-key 2) ; Ctrl+B - (fiveam:is (eq t (st :sidebar-visible)))) - -(fiveam:test test-ctrl-p-opens-command-palette - "Contract 6: Ctrl+P opens command palette (pushes dialog with daemon commands)." - (init-state) - (on-key 16) ; Ctrl+P - (fiveam:is-true (and cl-tty.dialog:*dialog-stack*))) - -(fiveam:test test-open-minibuffer-pushes-dialog - "Contract 7: open-minibuffer pushes a dialog with a select content." - (let ((cl-tty.dialog:*dialog-stack* nil)) - (passepartout.channel-tui::open-minibuffer) - (fiveam:is (= 1 (length cl-tty.dialog:*dialog-stack*))) - (let ((item (first cl-tty.dialog:*dialog-stack*))) - (fiveam:is (string= "DIALOG" (symbol-name (class-name (class-of item))))) - (let ((content (cl-tty.dialog:dialog-content item))) - (fiveam:is (not (null content))))))) - -(fiveam:test test-slash-commands-count - "Contract 6: *slash-commands* has at least 14 entries with :name, :desc, :action." - (let ((cmds passepartout.channel-tui::*slash-commands*)) - (fiveam:is (>= (length cmds) 14)) - (dolist (c cmds) - (fiveam:is (stringp (getf c :name))) - (fiveam:is (stringp (getf c :desc))) - (fiveam:is (functionp (getf c :action)))))) - -(fiveam:test test-daemon-commands-count - "Contract 8: *daemon-commands* has at least 14 entries with :title, :desc, :action, category headers." - (let ((cmds passepartout.channel-tui::*daemon-commands*)) - (fiveam:is (>= (length cmds) 14)) - (dolist (c cmds) - (if (getf c :category) - (fiveam:is (stringp (getf c :title))) - (progn - (fiveam:is (stringp (getf c :title))) - (fiveam:is (stringp (getf c :desc))) - (fiveam:is (functionp (getf c :action)))))))) - -(fiveam:test test-minibuffer-handle-key-escape - "Contract 8: minibuffer-handle-key with Esc pops dialog." - (let ((cl-tty.dialog:*dialog-stack* nil)) - (passepartout.channel-tui::open-minibuffer) - (fiveam:is (= 1 (length cl-tty.dialog:*dialog-stack*))) - (passepartout.channel-tui::minibuffer-handle-key 27) ; Esc - (fiveam:is (null cl-tty.dialog:*dialog-stack*)))) - -(fiveam:test test-minibuffer-handle-key-backspace - "Contract 8: Backspace pops filter char, then pops dialog on empty." - (let ((cl-tty.dialog:*dialog-stack* nil)) - (passepartout.channel-tui::open-minibuffer) - (let ((sel (cl-tty.dialog:dialog-content (first cl-tty.dialog:*dialog-stack*)))) - (setf (cl-tty.select:select-filter sel) "te") - (passepartout.channel-tui::minibuffer-handle-key 263) ; Backspace - (fiveam:is (string= "t" (cl-tty.select:select-filter sel))) - (passepartout.channel-tui::minibuffer-handle-key 263) ; Backspace - (fiveam:is (string= "" (or (cl-tty.select:select-filter sel) "")))))) - -(fiveam:test test-croatoan-to-tty-event-arrows - "Contract 8: croatoan-to-tty-event converts Croatoan key codes to cl-tty key-events." - (let ((up (passepartout.channel-tui::croatoan-to-tty-event 259))) - (fiveam:is (cl-tty.input:key-event-p up)) - (fiveam:is (eql :up (cl-tty.input:key-event-key up)))) - (let ((down (passepartout.channel-tui::croatoan-to-tty-event 258))) - (fiveam:is (eql :down (cl-tty.input:key-event-key down)))) - (let ((enter (passepartout.channel-tui::croatoan-to-tty-event 13))) - (fiveam:is (eql :enter (cl-tty.input:key-event-key enter)))) - (let ((esc (passepartout.channel-tui::croatoan-to-tty-event 27))) - (fiveam:is (eql :escape (cl-tty.input:key-event-key esc))))) diff --git a/lisp/channel-tui-state.lisp b/lisp/channel-tui-state.lisp index 168b165..0f7b3c6 100644 --- a/lisp/channel-tui-state.lisp +++ b/lisp/channel-tui-state.lisp @@ -1,14 +1,11 @@ (defpackage :passepartout.channel-tui - (:use :cl :croatoan :passepartout :usocket :bordeaux-threads) + (:use :cl :passepartout :usocket :bordeaux-threads) (:export :tui-main :st :add-msg :now :input-string :queue-event :drain-queue :init-state :view-status :view-chat :view-input :redraw :on-key :on-daemon-msg :send-daemon :connect-daemon :disconnect-daemon - :*tui-theme* :theme-color - :*slash-commands* :open-minibuffer :minibuffer-handle-key - :view-conversation :render-user-msg :render-agent-msg - :render-sys-msg :render-tool-call :render-gate-trace)) + :*tui-theme* :theme-color)) (in-package :passepartout.channel-tui) (defvar *state* nil) @@ -33,7 +30,7 @@ :rule-count :cyan :focus-map :yellow ;; UI :dim :white :highlight :cyan :accent :green) - "Color theme plist. 27 semantic keys → Croatoan color values. + "Color theme plist. 27 semantic keys → hex color strings. See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") (defvar *tui-theme-presets* @@ -68,43 +65,7 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") :tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496" :scroll-indicator "#2aa198" :border "#657b83" :background "#002b36" :rule-count "#2aa198" :focus-map "#b58900" - :dim "#586e75" :highlight "#2aa198" :accent "#859900") - :nord (:user "#81a1c1" :agent "#d8dee9" :system "#ebcb8b" - :input "#d8dee9" :timestamp "#4c566a" :help "#88c0d0" :error "#bf616a" :warning "#ebcb8b" - :connected "#a3be8c" :disconnected "#bf616a" :busy "#b48ead" :idle "#616e88" - :gate-passed "#a3be8c" :gate-blocked "#bf616a" :gate-approval "#ebcb8b" - :hitl "#b48ead" - :tool-running "#b48ead" :tool-success "#a3be8c" :tool-failure "#bf616a" :tool-output "#d8dee9" - :scroll-indicator "#88c0d0" :border "#4c566a" :background "#2e3440" - :rule-count "#88c0d0" :focus-map "#ebcb8b" - :dim "#616e88" :highlight "#88c0d0" :accent "#5e81ac") - :tokyonight (:user "#7aa2f7" :agent "#c0caf5" :system "#e0af68" - :input "#c0caf5" :timestamp "#565f89" :help "#7dcfff" :error "#f7768e" :warning "#e0af68" - :connected "#9ece6a" :disconnected "#f7768e" :busy "#bb9af7" :idle "#565f89" - :gate-passed "#9ece6a" :gate-blocked "#f7768e" :gate-approval "#e0af68" - :hitl "#bb9af7" - :tool-running "#bb9af7" :tool-success "#9ece6a" :tool-failure "#f7768e" :tool-output "#c0caf5" - :scroll-indicator "#7dcfff" :border "#1f2335" :background "#1a1b26" - :rule-count "#7dcfff" :focus-map "#e0af68" - :dim "#565f89" :highlight "#7dcfff" :accent "#7aa2f7") - :catppuccin (:user "#89b4fa" :agent "#cdd6f4" :system "#f9e2af" - :input "#cdd6f4" :timestamp "#585b70" :help "#94e2d5" :error "#f38ba8" :warning "#f9e2af" - :connected "#a6e3a1" :disconnected "#f38ba8" :busy "#cba6f7" :idle "#6c7086" - :gate-passed "#a6e3a1" :gate-blocked "#f38ba8" :gate-approval "#f9e2af" - :hitl "#cba6f7" - :tool-running "#cba6f7" :tool-success "#a6e3a1" :tool-failure "#f38ba8" :tool-output "#cdd6f4" - :scroll-indicator "#94e2d5" :border "#45475a" :background "#1e1e2e" - :rule-count "#94e2d5" :focus-map "#f9e2af" - :dim "#6c7086" :highlight "#94e2d5" :accent "#89b4fa") - :monokai (:user "#a6e22e" :agent "#f8f8f2" :system "#e6db74" - :input "#f8f8f2" :timestamp "#75715e" :help "#66d9ef" :error "#f92672" :warning "#e6db74" - :connected "#a6e22e" :disconnected "#f92672" :busy "#ae81ff" :idle "#75715e" - :gate-passed "#a6e22e" :gate-blocked "#f92672" :gate-approval "#e6db74" - :hitl "#ae81ff" - :tool-running "#ae81ff" :tool-success "#a6e22e" :tool-failure "#f92672" :tool-output "#f8f8f2" - :scroll-indicator "#66d9ef" :border "#49483e" :background "#272822" - :rule-count "#66d9ef" :focus-map "#e6db74" - :dim "#75715e" :highlight "#66d9ef" :accent "#a6e22e")) + :dim "#586e75" :highlight "#2aa198" :accent "#859900")) "Named theme presets. /theme loads one into *tui-theme*.") (defvar *tui-theme-current-name* :dark @@ -140,40 +101,15 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") key))) (defun theme-color (role) - "Returns the Croatoan color for a semantic role. - Keyword or hex string values are returned as-is; hex strings are - converted to integers that Croatoan can process." + "Returns a hex color string for a semantic role, suitable for cl-tty." (let ((val (or (getf *tui-theme* role) :white))) - (if (and (stringp val) (> (length val) 0) (eql (char val 0) #\#)) - (handler-case (parse-integer (subseq val 1) :radix 16) - (error () val)) - val))) - -;; v0.8.0: TrueColor helpers -(defun theme-hex-to-rgb (hex-string) - "Parse #RRGGBB to (values r g b). Returns (255 255 255) for invalid input." - (if (and (stringp hex-string) (= 7 (length hex-string)) (eql (char hex-string 0) #\#)) - (handler-case - (let ((r (parse-integer (subseq hex-string 1 3) :radix 16)) - (g (parse-integer (subseq hex-string 3 5) :radix 16)) - (b (parse-integer (subseq hex-string 5 7) :radix 16))) - (values r g b)) - (error () (values 255 255 255))) - (values 255 255 255))) - -(defun theme-init-truecolor () - "Register hex colors from *tui-theme* with Croatoan's init-color." - (handler-case - (loop for (key val) on *tui-theme* by #'cddr - when (and (stringp val) (= 7 (length val)) (eql (char val 0) #\#)) - do (multiple-value-bind (r g b) (theme-hex-to-rgb val) - (init-color key (/ r 255.0) (/ g 255.0) (/ b 255.0)))) - (error () nil))) - -(defun sidebar-toggle () - "Toggle sidebar visibility. Sets dirty flags for full redraw." - (setf (st :sidebar-visible) (not (st :sidebar-visible))) - (setf (st :dirty) (list t t t))) + (cond + ((stringp val) val) + (t (case val + (:green "#00FF00") (:red "#FF0000") (:cyan "#00FFFF") + (:yellow "#FFFF00") (:magenta "#FF00FF") (:blue "#0000FF") + (:white "#FFFFFF") (:black "#000000") + (t "#FFFFFF")))))) (defun st (key) (getf *state* key)) (defun (setf st) (val key) (setf (getf *state* key) val)) @@ -190,8 +126,6 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") :collapsed-gates nil ; v0.7.2 :search-mode nil :search-query "" ; v0.7.2 :search-matches nil :search-match-idx 0 - :sidebar-visible nil ; v0.8.0 - :expand-tool-calls nil ; v0.8.0 :dirty (list nil nil nil)))) (defun now () diff --git a/lisp/channel-tui-view.lisp b/lisp/channel-tui-view.lisp index 003601c..affabb8 100644 --- a/lisp/channel-tui-view.lisp +++ b/lisp/channel-tui-view.lisp @@ -1,27 +1,25 @@ (in-package :passepartout.channel-tui) -(defun view-status (win) - (clear win) - (box win 0 0) - (add-string win - (format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a" +(defun view-status (fb w) + (let ((line1 (format nil + " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a" (if (st :connected) "● Connected" "○ Disconnected") (string-upcase (string (st :mode))) (length (st :messages)) (if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0") (or (st :rule-count) 0) (if (st :streaming-text) " [streaming]" - (if (st :busy) " …thinking" ""))) - :y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected))) - ;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0) - (let ((focus-info (or (st :foveal-id) ""))) - (when (and focus-info (> (length focus-info) 0)) - (add-string win (format nil " [Focus: ~a]" focus-info) - :y 2 :x 1 :fgcolor (theme-color :timestamp)))) - (add-string win (format nil " ~a" (now)) - :y 2 :x (max 1 (- (width win) 12)) - :fgcolor (theme-color :timestamp)) - (refresh win)) + (if (st :busy) " …thinking" ""))))) + (cl-tty.backend:draw-text fb 1 1 line1 + (theme-color (if (st :connected) :connected :disconnected)) + nil) + ;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0) + (let ((focus-info (or (st :foveal-id) ""))) + (when (and focus-info (> (length focus-info) 0)) + (cl-tty.backend:draw-text fb 1 2 (format nil " [Focus: ~a]" focus-info) + (theme-color :timestamp) nil))) + (cl-tty.backend:draw-text fb (max 1 (- w 12)) 2 (format nil " ~a" (now)) + (theme-color :timestamp) nil))) ;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown (defun search-highlight (content query) @@ -40,98 +38,23 @@ (setf result (concatenate 'string result (subseq content pos))) (if (string= result "") content result)))) -(defun render-user-msg (win content time w y) - "Render a user message with green role-prefix and timestamp. Returns next y." - (let* ((prefix (format nil "⬆ [~a] " time)) - (line-text (concatenate 'string prefix content)) - (wrapped (word-wrap line-text (- w 2)))) - (dolist (line wrapped) - (when (< y 9999) - (add-string win line :y y :x 1 :n (1- w) :fgcolor (theme-color :user)) - (incf y))) - y)) - -(defun render-agent-msg (win content time w y) - "Render an agent message using cl-tty's markdown renderer. Returns next y." - (let* ((prefix (format nil "⬇ [~a] " time)) - (header-len (length prefix))) - ;; Role prefix line - (add-string win prefix :y y :x 1 :n header-len :fgcolor (theme-color :agent)) - (incf y) - ;; Markdown content — cl-tty's render-markdown produces ANSI-styled lines - (let ((md-lines (cl-tty.markdown:render-md - (cl-tty.markdown:parse-blocks content)))) - (dolist (line md-lines) - (when (< y 9999) - ;; Each line may contain ANSI escape codes; render through add-string - (add-string win line :y y :x 1 :n (- w 2) :fgcolor (theme-color :agent)) - (incf y)))) - y)) - -(defun render-sys-msg (win content w y) - "Render a system message in yellow, dim style. Returns next y." - (let* ((line-text (format nil " ~a" content)) - (wrapped (word-wrap line-text (- w 2)))) - (dolist (line wrapped) - (when (< y 9999) - (add-string win line :y y :x 1 :n (1- w) :fgcolor (theme-color :system)) - (incf y))) - y)) - -(defun render-tool-call (win tool-name status duration content w y tab-expanded) - "Render a tool call with status indicator. Tab toggles full output. Returns next y." - (let* ((status-char (case status (:running "…") (:success "✓") (:failure "✗") (t "?"))) - (status-color (case status (:running (theme-color :tool-running)) - (:success (theme-color :tool-success)) - (:failure (theme-color :tool-failure)) - (t (theme-color :dim)))) - (summary (format nil " ~a ~a~@[ (~,1fs)~]" status-char tool-name duration))) - ;; Summary line - (add-string win summary :y y :x 1 :n (- w 2) :fgcolor status-color) - (incf y) - ;; Expanded output (when Tab pressed) - (when tab-expanded - (dolist (line (word-wrap content (- w 6))) - (when (< y 9999) - (add-string win (format nil " ~a" line) :y y :x 1 :n (- w 4) :fgcolor (theme-color :tool-output)) - (incf y)))) - y)) - -(defun render-gate-trace (win trace w y collapsed) - "Render gate decisions as colored lines. Ctrl+G toggles. Returns next y." - (unless collapsed - (dolist (entry (gate-trace-lines trace)) - (when (< y 9999) - (add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim)) - (incf y)))) - y) - -(defun view-conversation (win h) - "Render scrolled message list using cl-tty ScrollBox model. - Sticky-scroll: auto-follows new content when at bottom. - Each message role dispatched to its dedicated render function." - (clear win) - (box win 0 0) - (let* ((w (or (width win) 78)) - (msgs (st :messages)) +(defun view-chat (fb w h) + (let* ((msgs (st :messages)) (total (length msgs)) (max-lines (- h 2)) (is-search (st :search-mode)) (y 1)) - ;; Search mode header + ;; v0.7.2: search mode header (when is-search (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) (query (st :search-query)) (header (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit" (length matches) query (1+ idx) (length matches)))) - (add-string win header :y y :x 1 :n (1- w) :fgcolor (theme-color :highlight)) + (cl-tty.backend:draw-text fb 1 y header (theme-color :highlight) nil) (incf y) (decf max-lines))) - ;; Sticky-scroll: if at bottom, auto-follow - (when (and (zerop (st :scroll-offset)) (> total 0)) - (setf (st :scroll-at-bottom) t)) - ;; Count visible messages from end + ;; Count visible messages from end, accounting for word wrap (let* ((msg-count 0) (lines-remaining max-lines)) (loop for i from (1- total) downto 0 @@ -140,16 +63,17 @@ (role (getf msg :role)) (content (getf msg :content)) (time (or (getf msg :time) "")) - (nlines (case role - (:user (length (word-wrap (format nil "⬆ [~a] ~a" time content) (- w 2)))) - (:agent (let ((header (format nil "⬇ [~a]" time))) - (+ 1 (length (cl-tty.markdown:render-md - (cl-tty.markdown:parse-blocks content)))))) - (t (length (word-wrap (format nil " ~a" content) (- w 2))))))) + (prefix (case role (:user "⬆") (:agent "⬇") (t " "))) + (content-show (if is-search + (search-highlight content (st :search-query)) + content)) + (line-text (format nil "~a [~a] ~a" prefix time content-show)) + (wrapped (word-wrap line-text (- w 2))) + (nlines (length wrapped))) (if (<= nlines lines-remaining) (progn (decf lines-remaining nlines) (incf msg-count)) (setf lines-remaining 0)))) - ;; Render from start message + ;; Render from the correct starting message (let* ((scroll-skip (st :scroll-offset)) (start (max 0 (- total msg-count scroll-skip)))) (loop for i from start below total @@ -158,156 +82,48 @@ (role (getf msg :role)) (content (getf msg :content)) (time (or (getf msg :time) "")) - (gate-trace (getf msg :gate-trace)) - (collapsed (member i (st :collapsed-gates))) - (tool-name (getf msg :tool)) - (tool-status (getf msg :tool-status)) - (tool-duration (getf msg :tool-duration)) - (tool-expanded (member i (st :expand-tool-calls)))) - (setf y (case role - (:user (render-user-msg win content time w y)) - (:agent (progn - (setf y (render-agent-msg win content time w y)) - (when gate-trace - (setf y (render-gate-trace win gate-trace w y collapsed))) - y)) - (t (render-sys-msg win content w y)))) - ;; Tool call block (attached to any role message) - (when tool-name - (setf y (render-tool-call win tool-name tool-status tool-duration - content w y tool-expanded))))))) - ;; Sticky-scroll update - (when (and (st :scroll-at-bottom) (plusp (length msgs))) - (setf (st :scroll-offset) 0)) - (refresh win))) + (color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent)))) + (prefix (case role (:user "⬆") (:agent "⬇") (t " "))) + (is-panel (getf msg :panel)) + (is-resolved (getf msg :panel-resolved)) + (content-show (if is-search + (search-highlight content (st :search-query)) + content)) + (line-text (format nil "~a [~a] ~a" prefix time content-show)) + (wrapped (word-wrap line-text (- w 2)))) + ;; HITL panel: render with colored border + (when is-panel + (setf color (if is-resolved + (theme-color :dim) + (theme-color :hitl)))) + (dolist (line wrapped) + (when (< y (1- h)) + (cl-tty.backend:draw-text fb 1 y line color nil) + (incf y))) + ;; v0.7.2: gate trace below agent messages + (let ((gate-trace (getf msg :gate-trace))) + (when (and gate-trace (not (member i (st :collapsed-gates)))) + (dolist (entry (passepartout::gate-trace-lines gate-trace)) + (when (< y (1- h)) + (cl-tty.backend:draw-text fb 3 y (car entry) + (or (getf (cdr entry) :fgcolor) :dim) nil) + (incf y))))))))))) -(defun view-input (win) +(defun view-input (fb w) (let* ((text (input-string)) - (w (or (width win) 78)) (pos (or (st :cursor-pos) 0)) (display-start (max 0 (- pos (1- w)))) (visible (subseq text display-start (min (length text) (+ display-start w))))) - (clear win) - (add-string win (format nil "~a " visible) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input)) - (setf (cursor-position win) (list 0 (min (- pos display-start) (1- w))))) - (refresh win)) + (cl-tty.backend:draw-text fb 0 0 (format nil "~a " visible) (theme-color :input) nil))) -(defun redraw (sw cw ch iw) +(defun redraw (fb w h) (destructuring-bind (sd cd id) (st :dirty) - (when sd (view-status sw)) - (when cd (view-conversation cw ch)) - (when id (view-input iw)) - (setf (st :dirty) (list nil nil nil)))) + (when sd (view-status fb w)) + (when cd (view-chat fb w (- h 5))) + (when id (view-input fb w)) + (setf (st :dirty) (list nil nil nil)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-view-tests - (:use :cl :fiveam :passepartout) - (:export #:tui-view-suite)) - -(in-package :passepartout-tui-view-tests) - -(def-suite tui-view-suite :description "TUI view rendering helpers") -(in-suite tui-view-suite) - -(test test-char-width-ascii - "Contract 5: ASCII characters (< 128) have width 1." - (is (= 1 (char-width #\a))) - (is (= 1 (char-width #\Space))) - (is (= 1 (char-width #\@)))) - -(test test-char-width-tab - "Contract 5: tab character has width 8." - (is (= 8 (char-width #\Tab)))) - -(test test-char-width-cjk - "Contract 5: CJK characters have width 2." - (is (= 2 (char-width #\日)))) - -(test test-char-width-null - "Contract 5: null has width 0." - (is (= 0 (char-width #\Nul)))) - -(test test-markdown-bold - "Contract 7: parse-markdown-spans detects **bold**." - (let ((segments (parse-markdown-spans "hello **world**!"))) - (is (= 3 (length segments))))) - -(test test-markdown-plain - "Contract 7: plain text returns single segment." - (let ((segments (parse-markdown-spans "plain"))) - (is (= 1 (length segments))) - (is (string= "plain" (caar segments))))) - -(test test-markdown-url - "Contract 7: parse-markdown-spans detects URLs." - (let ((segments (parse-markdown-spans "see https://example.com for more"))) - (is (>= (length segments) 2)) - (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) - -(test test-markdown-blocks - "Contract 8: parse-markdown-blocks detects code blocks." - (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) - (segs (parse-markdown-blocks text))) - (is (= 3 (length segs))) - (let ((code (second segs))) - (is (eq t (getf code :code-block))) - (is (string= "lisp" (getf code :lang))) - (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) - -(test test-markdown-blocks-no-close - "Contract 8: unclosed code block returns content." - (let* ((text (format nil "```~%unclosed code")) - (segs (parse-markdown-blocks text))) - (is (= 1 (length segs))) - (is (eq t (getf (first segs) :code-block))))) - -(test test-syntax-highlight - "Contract 9: syntax-highlight colors Lisp code." - (let ((segs (syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) - (is (>= (length segs) 3)))) - -(test test-syntax-highlight-keyword - "Contract 9: syntax-highlight colors keywords." - (let ((segs (syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) - (is (>= (length segs) 2)) - (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-syntax-highlight-function - "Contract 9: syntax-highlight colors function calls." - (let ((segs (syntax-highlight "(+ 1 2)" "lisp"))) - (is (>= (length segs) 2)) - (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-gate-trace-lines-passed - "Contract 9: gate-trace-lines for passed gate." - (let ((lines (gate-trace-lines - '((:gate "path" :result :passed))))) - (is (= 1 (length lines))) - (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) - -(test test-gate-trace-lines-blocked - "Contract 9: gate-trace-lines for blocked gate." - (let ((lines (gate-trace-lines - '((:gate "shell" :result :blocked :reason "rm"))))) - (is (= 1 (length lines))) - (is (search "rm" (caar lines))))) - -(test test-gate-trace-lines-approval - "Contract 9: gate-trace-lines for approval gate." - (let ((lines (gate-trace-lines - '((:gate "network" :result :approval))))) - (is (= 1 (length lines))) - (is (search "HITL" (caar lines))))) - -(test test-init-state-has-collapsed-gates - "Contract v0.7.2: init-state includes :collapsed-gates field." - (passepartout.channel-tui::init-state) - (let ((cg (passepartout.channel-tui::st :collapsed-gates))) - (is (null cg)))) - -(in-package :passepartout.channel-tui) +(in-package :passepartout) (defun char-width (ch) "Returns the terminal column width of character CH. @@ -331,35 +147,7 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." ((<= #xFE00 code #xFE0F) 0) (t 1)))) -(defun word-wrap (text max-width) - "Split TEXT into lines that fit within MAX-WIDTH columns. -Word-breaks at spaces when possible; breaks mid-word if necessary. -Respects CJK/emoji char widths via char-width." - (let ((lines nil) - (start 0) - (end (length text))) - (loop while (< start end) do - (let* ((col 0) - (pos start) - (last-break start)) - (loop while (< pos end) - for width = (char-width (char text pos)) do - (when (char= (char text pos) #\Space) - (setf last-break pos)) - (when (> (+ col width) max-width) - (return)) - (incf col width) - (incf pos) - (when (>= pos end) (return))) - (let ((line-end (if (> pos start) pos (1+ start)))) - (when (>= line-end end) (setf line-end end)) - (push (subseq text start line-end) lines) - (setf start (if (and (< line-end end) (char= (char text line-end) #\Space)) - (1+ line-end) - line-end))))) - (nreverse lines))) - -(in-package :passepartout.channel-tui) +(in-package :passepartout) (defun parse-markdown-spans (text) "Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))." @@ -399,28 +187,22 @@ Respects CJK/emoji char widths via char-width." (t (push (cons (subseq text pos) nil) results) (return)))))))) (nreverse results))) -(defun render-styled (win segments y x w) - "Render markdown segments to Croatoan window. Returns next y." +(defun render-styled (fb segments y x w) + "Render markdown segments to cl-tty backend. Returns next y." (dolist (seg segments) - (when (>= y (height win)) (return y)) (let* ((text (or (car seg) "")) (attrs (cdr seg)) (bold (getf attrs :bold)) (code (getf attrs :code)) - (underline (getf attrs :underline)) - (url (getf attrs :url)) - (style-bits (append (when bold '(:bold)) - (when underline '(:underline))))) - (when style-bits - (add-attributes win (get-bitmask style-bits))) - (add-string win text :y y :x x :n (max 1 (- w x)) - :bgcolor (when code (theme-color :dim)) - :fgcolor (cond (url (theme-color :highlight)) - (t (theme-color (or (getf attrs :role) :agent))))) - (when style-bits - (remove-attributes win (get-bitmask style-bits))) + (url (getf attrs :url))) + (declare (ignore code)) + (cl-tty.backend:draw-text fb x y text + (cond (url (theme-color :highlight)) + (t (theme-color (or (getf attrs :role) :agent)))) + nil + :bold bold) (incf x (length text)))) - (1+ y)) + y) (defun parse-markdown-blocks (text) "Split text at ``` code block boundaries." @@ -484,7 +266,7 @@ Respects CJK/emoji char widths via char-width." (setf p fe))))))))) (nreverse r))) -(in-package :passepartout.channel-tui) +(in-package :passepartout) (defun gate-trace-lines (trace) "Convert gate-trace plist to display lines." @@ -495,14 +277,14 @@ Respects CJK/emoji char widths via char-width." (reason (getf entry :reason)) (name (or gate "unknown")) (color (case result - (:passed (theme-color :gate-passed)) - (:blocked (theme-color :gate-blocked)) - (:approval (theme-color :gate-approval)) - (t (theme-color :dim)))) + (:passed :gate-passed) + (:blocked :gate-blocked) + (:approval :gate-approval) + (t :dim))) (prefix (case result - (:passed " ✓ ") - (:blocked " ✗ ") - (:approval " → ") + (:passed " \u2713 ") + (:blocked " \u2717 ") + (:approval " \u2192 ") (t " ? "))) (text (format nil "~a~a~@[~a~]~@[~a~]" prefix name @@ -511,339 +293,110 @@ Respects CJK/emoji char widths via char-width." (push (cons text (list :fgcolor color)) lines))) (nreverse lines))) -(in-package :passepartout.channel-tui) +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) -;; ── Sidebar Panel Slots ── -;; Each sidebar panel is a cl-tty slot registration with :mode :replace. -;; The sidebar orchestrates them in order, passing (win w h y) and -;; receiving the next y position. - -(defun render-sidebar-panel-header (win w y title) - (add-string win (format nil "── ~a ──" title) :y y :x 1 :n (- w 2) - :fgcolor (theme-color :accent)) - (1+ y)) - -(cl-tty.slot:defslot :sidebar-gate-trace :mode :replace - :render-fn - (lambda (win w h y) - (let ((trace (st :gate-trace))) - (setf y (render-sidebar-panel-header win w y "Gate Trace")) - (if trace - (dolist (entry (gate-trace-lines trace)) - (when (< y (1- h)) - (add-string win (car entry) :y y :x 2 :n (- w 4) - :fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim))) - (incf y))) - (add-string win " (no trace)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - y))) - -(cl-tty.slot:defslot :sidebar-focus :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (render-sidebar-panel-header win w y "Focus")) - (add-string win (format nil " ~a" (or (st :foveal-id) "(none)")) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map)) - (+ y 2))) - -(cl-tty.slot:defslot :sidebar-rules :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Rules")) - (add-string win (format nil " Rules: ~d" (or (st :rule-count) 0)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count)) - (1+ y))) - -(cl-tty.slot:defslot :sidebar-context :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Context")) - (let* ((pct (or (st :context-usage) 0)) - (bar-width 30) - (filled (min bar-width (floor (* pct bar-width) 100))) - (gauge-color (cond ((< pct 50) (theme-color :connected)) - ((< pct 80) (theme-color :warning)) - ((< pct 95) (theme-color :tool-running)) - (t (theme-color :error))))) - (add-string win (format nil " [~a~a] ~d%" - (make-string filled :initial-element #\█) - (make-string (- bar-width filled) :initial-element #\░) - pct) - :y y :x 2 :n (- w 4) :fgcolor gauge-color)) - (1+ y))) - -(cl-tty.slot:defslot :sidebar-files :mode :replace - :render-fn - (lambda (win w h y) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Files")) - (let ((files (st :modified-files))) - (if files - (dolist (f files) - (when (< y (1- h)) - (let ((fp (getf f :filepath)) - (added (getf f :lines-added)) - (removed (getf f :lines-removed))) - (add-string win (format nil " ~a~@[ +~d~]~@[ -~d~]" - (subseq fp (max 0 (- (length fp) 30))) - (when (> added 0) added) - (when (> removed 0) removed)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) - (incf y)))) - (add-string win " (no changes)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - y))) - -(cl-tty.slot:defslot :sidebar-cost :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Cost")) - (let ((cost (st :session-cost))) - (if cost - (progn - (add-string win (format nil " Total: $~,4f" (getf cost :total)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) - (incf y) - (add-string win (format nil " Calls: ~d" (getf cost :calls)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))) - (add-string win " (no data)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - (1+ y)))) - -(cl-tty.slot:defslot :sidebar-protection :mode :replace - :render-fn - (lambda (win w h y) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Protection")) - (let ((bc (st :block-counts))) - (if (and bc (> (getf bc :total) 0)) - (let ((by-gate (getf bc :by-gate))) - (dolist (entry (subseq by-gate 0 (min (length by-gate) 6))) - (when (< y (1- h)) - (add-string win (format nil " ~a: ~d" (car entry) (cdr entry)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :gate-blocked)) - (incf y)))) - (add-string win " (no blocks)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - y))) - -(defun view-sidebar (win) - "Render 42-column sidebar with panel slots: Gate Trace, Focus, Rules, Context, Files, Cost, Protection." - (clear win) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (let ((w (or (width win) 42)) - (h (or (height win) 24)) - (y 1)) - (dolist (panel '(:sidebar-gate-trace :sidebar-focus :sidebar-rules - :sidebar-context :sidebar-files :sidebar-cost - :sidebar-protection)) - (let ((result (cl-tty.slot:slot-render panel win w h y))) - (when result (setf y (min (1- h) result))))) - (refresh win) - (1- y))) - -(defun view-minibuffer (win) - "Render the bottom-anchored minibuffer panel. Dispatches on :minibuffer-mode." - (case (st :minibuffer-mode) - (:slash-menu (view-slash-menu win)) - (:wizard (view-wizard-in-panel win)) - (t nil))) - -(declaim (special *slash-commands*)) ; forward declaration — defined in channel-tui-main - -(defun view-slash-menu (win) - "Render the slash-command menu: filter bar, filtered command list, selection highlight." - (clear win) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (let* ((w (or (width win) 60)) - (h (or (height win) 10)) - (y 1) - (filter (or (st :minibuffer-filter) "")) - (commands passepartout.channel-tui::*slash-commands*) - (filtered (if (or (null filter) (string= filter "")) - (mapcar (lambda (c) (list :index (position c commands) :cmd c)) commands) - (let ((q (string-downcase filter)) (i 0) (r nil)) - (dolist (c commands (nreverse r)) - (when (or (search q (string-downcase (getf c :name))) - (search q (string-downcase (or (getf c :desc) "")))) - (push (list :index i :cmd c) r)) - (incf i))))) - (sel (or (st :minibuffer-selected-idx) 0)) - (max-visible (- h 3))) - ;; Header: filter bar - (add-string win (format nil " Commands") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) - (incf y) - (add-string win (format nil " > ~a_" (if (> (length filter) 0) filter "/")) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :input)) - (incf y) - ;; Command list - (if filtered - (let* ((start (max 0 (- sel (floor max-visible 2)))) - (end (min (length filtered) (+ start max-visible))) - (flat-i 0)) - (loop for entry across (subseq (coerce filtered 'vector) start end) - for fi from start - for cmd = (getf entry :cmd) - do (let* ((name (getf cmd :name)) - (desc (getf cmd :desc)) - (selected (= fi sel)) - (fg (if selected (theme-color :highlight) (theme-color :agent)))) - (when selected - (add-string win (make-string (- w 4) :initial-element #\Space) :y y :x 2 :n (- w 4) - :fgcolor (theme-color :dim) :bgcolor (theme-color :highlight))) - (let ((prefix (if selected " > " " "))) - (add-string win (format nil "~a~a" prefix name) :y y :x 3 :n (min (- w 6) 25) :fgcolor fg) - (when desc - (add-string win (format nil " — ~a" desc) :y y :x 28 :n (min (- w 30) (length desc)) :fgcolor (theme-color :dim)))) - (incf y)))) - (progn - (add-string win " (no matching commands)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (incf y))) - ;; Footer - (add-string win " ↑↓ Navigate Enter Execute Esc Close" - :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (refresh win) - (- h 0))) - -(defun view-wizard-in-panel (win) - "Render the setup wizard in the bottom-anchored minibuffer panel. Three modes: provider-list, key-entry, cascade-config." - (clear win) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (let* ((w (or (width win) 70)) - (h (or (height win) 14)) - (y 1) - (mode (st :wizard-mode)) - (error-msg (st :wizard-error)) - (selected-idx (st :wizard-selected-idx)) - (providers (passepartout.channel-tui::wizard-provider-list)) - (configured (st :wizard-providers))) - (add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) - (incf y 2) - (case mode - (:provider-list - (let ((count (/ (length configured) 2))) - (add-string win (format nil "Configure Providers~a" - (if (> count 0) (format nil " — ~d configured" count) "")) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (incf y) - (loop for p in providers - for i from 0 - do (let* ((meta (passepartout.channel-tui::wizard-provider-meta p)) - (name (car meta)) - (key (getf configured p)) - (prefix (if (= i selected-idx) "> " " ")) - (suffix (if key " ✓" "")) - (color (if (= i selected-idx) - (theme-color :highlight) - (theme-color :dim)))) - (add-string win (format nil "~a~a~a" prefix name suffix) - :y y :x 3 :n (- w 6) :fgcolor color) - (incf y))) - (incf y) - (add-string win " Done — configure cascade" - :y y :x 3 :n (- w 6) - :fgcolor (if (>= selected-idx (length providers)) - (theme-color :highlight) - (theme-color :dim))) - (when (>= selected-idx (length providers)) - (add-string win ">" :y y :x 1 :n 2 :fgcolor (theme-color :highlight)))) - (:key-entry - (let* ((provider (st :wizard-current-provider)) - (meta (passepartout.channel-tui::wizard-provider-meta provider)) - (name (car meta)) - (url (cadr meta)) - (input (or (st :wizard-input) ""))) - (add-string win (format nil "API Key: ~a" name) :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) - (incf y) - (when url - (add-string win (format nil "Get key at: ~a" url) :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)) - (incf y)) - (add-string win "Enter your API key." :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)) - (incf y 2) - (add-string win (format nil "Key: > ~a" input) :y y :x 3 :n (- w 6) :fgcolor (theme-color :input)) - (incf y) - (when error-msg - (add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error)) - (incf y)) - (incf y) - (add-string win "Enter=Save Esc=Back Bksp=Edit Ctrl+U=Clear" - :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (return-from view-wizard-in-panel))) - (:cascade-config - (let* ((slot (st :wizard-cascade-slot)) - (slot-providers (getf (st :wizard-cascade) slot)) - (slot-label (cadr (assoc slot passepartout.channel-tui::*wizard-cascade-labels*))) - (count (/ (length configured) 2))) - (add-string win (format nil "Configure Cascade — ~d provider~:p" count) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (incf y) - (add-string win (or slot-label "Unknown") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) - (incf y) - (let ((shown nil)) - (loop for p in providers - for i from 0 - do (when (getf configured p) - (let* ((meta (passepartout.channel-tui::wizard-provider-meta p)) - (name (car meta)) - (in-slot (member p slot-providers)) - (prefix (if (= i selected-idx) "> " " ")) - (mark (if in-slot " [✓]" " [ ]")) - (color (if (= i selected-idx) - (theme-color :highlight) - (if in-slot (theme-color :gate-passed) (theme-color :dim))))) - (add-string win (format nil "~a~a~a" prefix name mark) - :y y :x 3 :n (- w 6) :fgcolor color) - (incf y) - (push t shown)))) - (unless shown - (add-string win " (no providers configured)" - :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)) - (incf y))) - (incf y) - (add-string win (format nil "Cascade: ~{~a~^, ~}" - (or slot-providers '("(none)"))) - :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)))) - (when error-msg - (incf y) - (add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error))) - (let ((footer (case mode - (:provider-list "↑↓ Navigate Enter=Select Esc=Back Ctrl+D=Remove") - (:cascade-config "↑↓ Select Enter=Toggle Tab=Next Quadrant Ctrl+S=Save Esc=Back") - (t "")))) - (when footer - (add-string win footer :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim)))) - (- h 0))))) +(defpackage :passepartout-tui-view-tests + (:use :cl :fiveam :passepartout) + (:export #:tui-view-suite)) (in-package :passepartout-tui-view-tests) -(test test-theme-hex-string-keys-exist - "v0.8.0: all 27 theme keys are present in *tui-theme*." - (let* ((theme passepartout.channel-tui::*tui-theme*) - (required '(:user :agent :system :input :timestamp :help :error :warning - :connected :disconnected :busy :idle - :gate-passed :gate-blocked :gate-approval :hitl - :tool-running :tool-success :tool-failure :tool-output - :scroll-indicator :border :background - :rule-count :focus-map - :dim :highlight :accent))) - (dolist (key required) - (is (getf theme key) (format nil "~a should be defined" key))))) +(def-suite tui-view-suite :description "TUI view rendering helpers") +(in-suite tui-view-suite) -(test test-theme-presets-count - "v0.8.0: 8 presets defined: dark, light, solarized, gruvbox, nord, tokyonight, catppuccin, monokai." - (let* ((presets passepartout.channel-tui::*tui-theme-presets*) - (names '(:dark :light :solarized :gruvbox :nord :tokyonight :catppuccin :monokai))) - (dolist (name names) - (is (getf presets name) (format nil "~a preset should exist" name))))) +(test test-char-width-ascii + "Contract 5: ASCII characters (< 128) have width 1." + (is (= 1 (passepartout::char-width #\a))) + (is (= 1 (passepartout::char-width #\Space))) + (is (= 1 (passepartout::char-width #\@)))) -(test test-minibuffer-init-state-fields - "Contract v0.8.0: init-state no longer has legacy palette/wizard fields." +(test test-char-width-tab + "Contract 5: tab character has width 8." + (is (= 8 (passepartout::char-width #\Tab)))) + +(test test-char-width-cjk + "Contract 5: CJK characters have width 2." + (is (= 2 (passepartout::char-width #\日)))) + +(test test-char-width-null + "Contract 5: null has width 0." + (is (= 0 (passepartout::char-width #\Nul)))) + +(test test-markdown-bold + "Contract 7: parse-markdown-spans detects **bold**." + (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) + (is (= 3 (length segments))))) + +(test test-markdown-plain + "Contract 7: plain text returns single segment." + (let ((segments (passepartout::parse-markdown-spans "plain"))) + (is (= 1 (length segments))) + (is (string= "plain" (caar segments))))) + +(test test-markdown-url + "Contract 7: parse-markdown-spans detects URLs." + (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) + (is (>= (length segments) 2)) + (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) + +(test test-markdown-blocks + "Contract 8: parse-markdown-blocks detects code blocks." + (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 3 (length segs))) + (let ((code (second segs))) + (is (eq t (getf code :code-block))) + (is (string= "lisp" (getf code :lang))) + (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) + +(test test-markdown-blocks-no-close + "Contract 8: unclosed code block returns content." + (let* ((text (format nil "```~%unclosed code")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 1 (length segs))) + (is (eq t (getf (first segs) :code-block))))) + +(test test-syntax-highlight + "Contract 9: syntax-highlight colors Lisp code." + (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) + (is (>= (length segs) 3)))) + +(test test-syntax-highlight-keyword + "Contract 9: syntax-highlight colors keywords." + (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) + (is (>= (length segs) 2)) + (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-syntax-highlight-function + "Contract 9: syntax-highlight colors function calls." + (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) + (is (>= (length segs) 2)) + (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-gate-trace-lines-passed + "Contract 9: gate-trace-lines for passed gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "path" :result :passed))))) + (is (= 1 (length lines))) + (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) + +(test test-gate-trace-lines-blocked + "Contract 9: gate-trace-lines for blocked gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "shell" :result :blocked :reason "rm"))))) + (is (= 1 (length lines))) + (is (search "rm" (caar lines))))) + +(test test-gate-trace-lines-approval + "Contract 9: gate-trace-lines for approval gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "network" :result :approval))))) + (is (= 1 (length lines))) + (is (search "HITL" (caar lines))))) + +(test test-init-state-has-collapsed-gates + "Contract v0.7.2: init-state includes :collapsed-gates field." (passepartout.channel-tui::init-state) - (is (null (getf passepartout.channel-tui::*state* :mode))) - (is (null (getf passepartout.channel-tui::*state* :palette-visible)))) + (let ((cg (passepartout.channel-tui::st :collapsed-gates))) + (is (null cg)))) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index bfbe8ae..9d0f150 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -5,38 +5,18 @@ Event handlers + daemon I/O + main loop. -** v0.8.0 — Minibuffer (cl-tty Dialog Stack) - -Replaces ad-hoc palette + wizard overlays with cl-tty's Dialog stack. -Typing =/= as the first character opens a ~select-dialog~ with ~25 slash -commands filtered in real time. Selecting a command dispatches it; -selecting =/wizard= transitions to a ~prompt-dialog~ chain. cl-tty's -~cl-tty.dialog:*dialog-stack*~ handles push/pop; Esc dismisses the top dialog. - -~*slash-commands*~ is the single source of truth for available commands. -~open-minibuffer~ pushes the select-dialog. ~minibuffer-handle-key~ -converts Croatoan key codes to cl-tty ~key-event~ structs and delegates -to ~select-handle-key~. Printable characters update the Select's filter; -Backspace removes the last filter character; Enter/Up/Down/Esc route -through the select widget's navigation. - -The wizard-dialog subclass validates each step and writes config to -~/.passepartout/config.lisp~. Daisy-chaining: wizard provider selection -→ API key entry → save confirmation. Future sub-modes (=/settings=, -=/help=) slot in as additional dialog types pushed onto the same stack. - ** Contract 1. (on-key ch): dispatches key presses: Enter triggers send (extracts input buffer, pushes history, sends to daemon, clears buffer), ~\\ + Enter~ inserts a literal newline (multi-line input), + ~/help~ lists all commands, ~/eval ~ evaluates a Lisp + expression, ~/focus ~ switches project context, + ~/scope ~ changes context scope, ~/unfocus~ pops context, Tab completes command names, Backspace deletes, arrows scroll chat and history. v0.7.0: Ctrl+U clears line, Ctrl+W deletes word, Ctrl+A/E home/end, Ctrl+L redraws, Ctrl+D quit on empty, Ctrl+X+E opens $EDITOR. - v0.8.0: when a dialog is on cl-tty's ~cl-tty.dialog:*dialog-stack*~, keys route - through ~minibuffer-handle-key~ instead of normal input. Typing =/= - as the first character opens a ~select-dialog~ with ~*slash-commands*~. Non-printable keys are ignored. 2. (on-daemon-msg msg): processes inbound daemon messages. Routes text responses to chat display (:agent), handshake to system @@ -47,66 +27,17 @@ The wizard-dialog subclass validates each step and writes config to 3. (send-daemon msg): serializes and sends a message to the daemon over the framed TCP protocol. 4. (tui-main): the main loop — connects to daemon, initializes - Croatoan windows, optionally starts Swank REPL, runs - render/input event loop at ~30fps. Renders dialog overlays when - cl-tty's ~cl-tty.dialog:*dialog-stack*~ is non-nil. -5. (on-key-sidebar key): v0.8.0 — handles sidebar-specific - keybindings: Ctrl+X+B toggles sidebar, Esc dismisses overlay. -6. (*slash-commands*): v0.8.0 — list of ~25 command plists, each - with ~:name~ (display string), ~:desc~ (tooltip), and ~:action~ - (thunk that dispatches the command). Drives cl-tty's ~Select~ widget. -7. (open-minibuffer): v0.8.0 — pushes a ~select-dialog~ onto cl-tty's - ~cl-tty.dialog:*dialog-stack*~ with ~*slash-commands*~ as options. Sets the - select's ~:on-select~ to dispatch the chosen command. - 8. (minibuffer-handle-key ch): v0.8.0 — converts Croatoan key code CH - to a cl-tty ~key-event~, then routes through the active dialog's - ~select-handle-key~. Returns T if handled (dialog consumed the key). - 9. (make-wizard-dialog): v0.8.0 — creates a multi-step wizard dialog: - provider selection → API key entry → save confirmation. Returns a - ~dialog~ instance pushed onto ~cl-tty.dialog:*dialog-stack*~. Each step validates - before advancing. Final step writes ~/.passepartout/config.lisp~. -10. (*daemon-commands*): v0.8.0 — list of ~16 daemon command plists, - organized by category (Session, Memory, System, Help), each with - ~:title~, ~:value~, ~:desc~, ~:action~, and optional ~:category t~ - for headers. Drives the command palette (~ctrl-tty Select~). -11. (open-command-palette): v0.8.0 — pushes a ~select-dialog~ onto - ~cl-tty.dialog:*dialog-stack*~ with ~*daemon-commands*~ as options. - Categories are rendered as dimmed headers; selection dispatches the - command's ~:action~ thunk. Opens on Ctrl+P. + cl-tty terminal and framebuffer, optionally starts Swank REPL, runs + render/input event loop at ~10fps. ** Event Handlers -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-main.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)) - (or (let* ((k (code-key raw)) - (name (and k (key-name k)))) - name) - ;; Fallback for known ncurses codes when Croatoan - ;; key tables aren't available (e.g. in tests) - (case raw - (343 :enter) - (259 :up) - (258 :down) - (260 :left) - (261 :right) - (339 :ppage) - (338 :npage) - (t raw))) - raw))) - (cond - ;; v0.8.0: minibuffer dialog active — route through cl-tty select - ((and (boundp 'cl-tty.dialog:*dialog-stack*) - cl-tty.dialog:*dialog-stack* - (minibuffer-handle-key ch)) - (setf (st :dirty) (list t t nil))) - ;; v0.7.1: Esc — interrupt streaming - ((and (eql ch 27) (st :streaming-text)) +(defun on-key (ch) + (cond + ;; v0.7.1: Esc — interrupt streaming + ((and (eq ch :escape) (st :streaming-text)) (send-daemon (list :type :event :payload '(:action :cancel-stream))) (when (> (length (st :messages)) 0) (let ((idx (1- (length (st :messages))))) @@ -120,14 +51,14 @@ The wizard-dialog subclass validates each step and writes config to (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)) + ((and (eq ch :escape) (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))) + ((and (st :search-mode) (eq ch :up)) (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) (new-idx (max 0 (1- idx)))) @@ -136,7 +67,7 @@ The wizard-dialog subclass validates each step and writes config to (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))) + ((and (st :search-mode) (eq ch :down)) (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) (new-idx (min (1- (length matches)) (1+ idx)))) @@ -146,7 +77,7 @@ The wizard-dialog subclass validates each step and writes config to (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))) + ((and (st :search-mode) (eq ch :enter)) (let ((matches (st :search-matches)) (idx (st :search-match-idx))) (when (and matches (>= (length matches) (1+ idx))) @@ -157,7 +88,7 @@ The wizard-dialog subclass validates each step and writes config to (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)) + ((and (eq ch :tab) (null (st :input-buffer))) (if (st :url-buffer) ;; Already extracted — now open it @@ -174,7 +105,7 @@ The wizard-dialog subclass validates each step and writes config to when content do (let ((pos (or (search "https://" content) (search "http://" content)))) (when pos - (let ((end (or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab #\)))) + (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)) @@ -186,35 +117,27 @@ The wizard-dialog subclass validates each step and writes config to (setf (st :dirty) (list t t nil))) nil)))) ;; v0.7.0: Ctrl key bindings - ((eql ch 21) ; Ctrl+U — clear line + ((eq ch :ctrl-u) (setf (st :input-buffer) nil) (setf (st :dirty) (list nil nil t))) - ((eql ch 23) ; Ctrl+W — delete word backward + ((eq ch :ctrl-w) (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 + ((eq ch :ctrl-a) (setf (st :cursor-pos) 0)) - ((eql ch 5) ; Ctrl+E — end + ((eq ch :ctrl-e) (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 + ((eq ch :ctrl-l) + (setf (st :dirty) (list t t t))) + ((eq ch :ctrl-d) (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 to find messages")) - ((eql ch 28) ; v0.8.0 Ctrl+\ — open setup minibuffer - (open-minibuffer) - ;; If minibuffer opens, simulate typing /setup to filter to it - (when cl-tty.dialog:*dialog-stack* - (let ((sel (cl-tty.dialog:dialog-content (first cl-tty.dialog:*dialog-stack*)))) - (when (typep sel 'select) - (setf (cl-tty.select:select-filter sel) "setup")))) - (setf (st :dirty) (list t t nil))) - ((eql ch 7) ; v0.7.2 Ctrl+G — toggle gate collapse + ((eq ch :ctrl-f) + (add-msg :system "Use /search to find messages")) + ((eq ch :ctrl-g) (let ((gate-idx nil)) (loop for i from (1- (length (st :messages))) downto 0 for m = (aref (st :messages) i) @@ -230,50 +153,18 @@ The wizard-dialog subclass validates each step and writes config to gate-idx)) (setf (st :dirty) (list nil t nil))) (add-msg :system "No gate trace to toggle")))) - ((eql ch 24) ; Ctrl+X prefix + ((eq ch :ctrl-x) (setf (st :pending-ctrl-x) t)) - ((and (st :pending-ctrl-x) (eql ch 2)) ; Ctrl+X+B — toggle sidebar - (setf (st :pending-ctrl-x) nil) - (passepartout.channel-tui::sidebar-toggle) - (add-msg :system (if (st :sidebar-visible) "Sidebar shown (Ctrl+X+B to hide)" "Sidebar hidden"))) - ((eql ch 16) ; v0.8.0 Ctrl+P — open command palette (daemon commands) - (progn - (open-command-palette) - (setf (st :dirty) (list t t nil)))) - ((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 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 + ((and (st :pending-ctrl-x) (eq ch :ctrl-e)) ; 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 + ((and (st :pending-ctrl-x) (not (eq ch :ctrl-e))) ; 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)) + ((eq ch :enter) ;; 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)) @@ -350,49 +241,80 @@ The wizard-dialog subclass validates each step and writes config to (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 - ;; /tags command — tag stack + ;; /tags command — tag stack with trigger counts ((string-equal text "/tags") - (let ((cats *tag-categories*)) + (let ((cats passepartout::*tag-categories*) + (counts passepartout::*tag-trigger-count*)) (if cats (dolist (entry cats) - (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) + (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 — context visibility - ((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 '*cognitive-tool-registry*) - (floor (* (hash-table-count *cognitive-tool-registry*) 40) 4) + ;; /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))) - (overhead-tokens 200) - (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) - (total-limit 8192) - (pct-used (floor (* 100 total-est) total-limit))) - (add-msg :system (format nil "Context: ~d msgs, focus=~a, ~d/~d tokens (~d%)" - msg-count focus total-est total-limit pct-used)) - (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) - (add-msg :system (format nil "LOGS ~5d tokens" log-tokens)) - (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) - (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)))) - ;; /context why — debug node + (log-tokens (min 4000 (floor (* msg-count 60) 4))) + ;; rough estimate: TIME, CONTEXT overhead + (overhead-tokens 200) + (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) + (total-limit 8192) + (pct-used (floor (* 100 total-est) total-limit)) + (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) + :initial-element #\#))) + (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) + (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) + (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) + (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) + (add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count)) + (add-msg :system (format nil " [~a~a] ~d%" + bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used)) + (when (> pct-used 80) + (add-msg :system "⚠ Context near limit — older messages may be dropped")))) + ;; /context why — debug node with full attributes ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) (let ((node-id (string-trim '(#\Space) (subseq text 13)))) - (if (fboundp 'memory-object-get) - (let ((obj (funcall 'memory-object-get node-id))) + (if (fboundp 'passepartout::memory-object-get) + (let ((obj (funcall 'passepartout::memory-object-get node-id))) (if obj - (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" - node-id - (memory-object-type obj) - (memory-object-scope obj) - (memory-object-version obj))) - (add-msg :system (format nil "Node ~a not found" node-id)))) + (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 — pruned nodes + ;; /context dropped — estimate pruned nodes from budget ((string-equal text "/context dropped") - (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)")) + (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)))) @@ -419,18 +341,18 @@ The wizard-dialog subclass validates each step and writes config to (let* ((n-str (string-trim '(#\Space) (subseq text 8))) (n (handler-case (parse-integer n-str) (error () nil)))) (if n - (if (fboundp 'rollback-memory) + (if (fboundp 'passepartout::rollback-memory) (let* ((idx (1- n)) - (snaps *memory-snapshots*) + (snaps passepartout::*memory-snapshots*) (ts (when (< idx (length snaps)) (getf (nth idx snaps) :timestamp)))) - (funcall 'rollback-memory idx) + (funcall 'passepartout::rollback-memory idx) (add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts))) (add-msg :system "Memory rollback not available")) (add-msg :system "Usage: /rewind ")))) ;; /sessions command — list snapshots ((string-equal text "/sessions") - (let ((snaps *memory-snapshots*)) + (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):" @@ -445,45 +367,50 @@ The wizard-dialog subclass validates each step and writes config to (add-msg :system "No snapshots available")))) ;; /audit verify — memory integrity ((string-equal text "/audit verify") - (let ((count 0) (hashed 0)) - (maphash (lambda (k v) (declare (ignore k)) - (when v - (incf count) - (when (memory-object-hash v) - (incf hashed)))) - *memory-store*) - (add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots" - count hashed - (length *memory-snapshots*))))) + (if (fboundp 'passepartout::audit-verify-hash) + (let* ((result (funcall 'passepartout::audit-verify-hash)) + (total (car result)) + (missing (cdr result))) + (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" + total missing + (length passepartout::*memory-snapshots*) + (zerop missing) + (unless (zerop missing) missing)))) + (add-msg :system "Memory audit not available"))) ;; /resume — resume from snapshot ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) (let* ((n-str (string-trim '(#\Space) (subseq text 8))) (n (handler-case (parse-integer n-str) (error () nil)))) (if n - (if (fboundp 'rollback-memory) - (progn (funcall 'rollback-memory (1- n)) + (if (fboundp 'passepartout::rollback-memory) + (progn (funcall 'passepartout::rollback-memory (1- n)) (add-msg :system (format nil "Resumed from snapshot ~d" n))) (add-msg :system "Memory rollback not available")) (add-msg :system "Usage: /resume ")))) ;; /help — search user manual ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) - (let* ((topic (string-trim '(#\Space) (subseq text 6))) - (results (self-help-lookup topic))) - (dolist (entry results) - (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) - (unless results - (add-msg :system (format nil "Topic '~a' not found in USER_MANUAL.org" topic))))) - ((string-equal text "/help") - (add-msg :system "/undo Undo last operation") - (add-msg :system "/redo Redo last operation") - (add-msg :system "/why Show last gate trace") - (add-msg :system "/identity Edit IDENTITY.org") - (add-msg :system "/tags List tag severities") - (add-msg :system "/audit Inspect memory object") - (add-msg :system "/search Search messages") - (add-msg :system "/context Show context summary") - (add-msg :system "/eval Evaluate Lisp") - (add-msg :system "/rewind Rewind to snapshot N") + (let ((topic (string-trim '(#\Space) (subseq text 6))) + (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) + (if sections + (dolist (entry sections) + (let* ((title (car entry)) + (content (cdr entry)) + (preview (if (> (length content) 300) + (concatenate 'string (subseq content 0 297) "...") + content))) + (add-msg :system (format nil "~a: ~a" title preview)))) + (add-msg :system (format nil "No manual section found for '~a'" topic))))) + ((string-equal text "/help") + (add-msg :system "/eval Evaluate Lisp") + (add-msg :system "/undo Undo last operation") + (add-msg :system "/redo Redo last operation") + (add-msg :system "/why Show last gate trace") + (add-msg :system "/identity Edit IDENTITY.org") + (add-msg :system "/tags List tag severities") + (add-msg :system "/audit Inspect memory object") + (add-msg :system "/search Search messages") + (add-msg :system "/context Show context summary") + (add-msg :system "/rewind Rewind to snapshot N") (add-msg :system "/sessions Show snapshots") (add-msg :system "/resume Resume from snapshot") (add-msg :system "/focus Set project context") @@ -491,15 +418,7 @@ The wizard-dialog subclass validates each step and writes config to (add-msg :system "/help [topic] Show this help") (add-msg :system "\\ + Enter Multi-line input") (add-msg :system "Ctrl+G Toggle gate trace")) - ;; /setup command — open minibuffer filtered to setup - ((string-equal text "/setup") - (open-minibuffer) - (when cl-tty.dialog:*dialog-stack* - (let ((sel (cl-tty.dialog:dialog-content (first cl-tty.dialog:*dialog-stack*)))) - (when (typep sel 'select) - (setf (cl-tty.select:select-filter sel) "setup")))) - (setf (st :dirty) (list t t nil))) - ;; /theme command + ;; /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* @@ -579,7 +498,7 @@ The wizard-dialog subclass validates each step and writes config to (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)) + ((eq ch :tab) (let ((text (input-string))) (cond ;; @ prefix — file path completion @@ -635,22 +554,21 @@ The wizard-dialog subclass validates each step and writes config to (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)) + ((eq ch :backspace) (input-delete-char) (setf (st :dirty) (list nil nil t))) ;; Left arrow - ((or (eq ch :left) (eql ch 260)) + ((eq ch :left) (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)) + ((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 - ((or (eq ch :up) (eql ch 259)) + ((eq ch :up) (let* ((h (st :input-history)) (p (st :input-hpos))) (when (and h (< p (1- (length h)))) (incf (st :input-hpos)) @@ -658,7 +576,7 @@ The wizard-dialog subclass validates each step and writes config to (reverse (coerce (nth (st :input-hpos) h) 'list))) (setf (st :dirty) (list nil nil t))))) ;; Down arrow - ((or (eq ch :down) (eql ch 258)) + ((eq ch :down) (when (> (st :input-hpos) 0) (decf (st :input-hpos)) (let ((h (st :input-history))) @@ -667,358 +585,28 @@ The wizard-dialog subclass validates each step and writes config to (reverse (coerce (nth (st :input-hpos) h) 'list)) nil)) (setf (st :dirty) (list nil nil t))))) - ;; PageUp - ((or (eq ch :ppage) (eql ch 339)) - (let ((page-size (max 10 (floor (length (st :messages)) 3)))) - (setf (st :scroll-offset) (+ (st :scroll-offset) page-size))) + ;; PageUp — scroll back by page (10 lines) + ((eq ch :ppage) + (let ((max-offset (max 0 (- (length (st :messages)) 1)))) + (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) (setf (st :dirty) (list nil t nil))) - ;; PageDown - ((or (eq ch :npage) (eql ch 338)) - (let ((page-size (max 10 (floor (length (st :messages)) 3)))) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) page-size)))) + ;; PageDown — scroll forward by page + ((eq ch :npage) + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) (setf (st :dirty) (list nil t nil))) - ;; Printable - (t - (let ((chr (typecase ch - (character ch) - (integer (code-char ch)) - (t nil)))) - (when (and chr (graphic-char-p chr)) - (input-insert-char chr) - (setf (st :dirty) (list nil nil t)))))))) - - -;; v0.8.0 — Minibuffer: *slash-commands*, open-minibuffer, minibuffer-handle-key, make-wizard-dialog - -(defvar *slash-commands* - (list (list :name "/focus" :desc "Set project context" - :action (lambda () (add-msg :system "/focus"))) - (list :name "/scope" :desc "Change context scope" - :action (lambda () (add-msg :system "/scope memex|session|project"))) - (list :name "/unfocus" :desc "Pop context stack" - :action (lambda () (send-daemon (list :type :event :payload (list :sensor :unfocus))))) - (list :name "/search" :desc "Search messages" - :action (lambda () (add-msg :system "Use /search "))) - (list :name "/why" :desc "Show last gate trace" - :action (lambda () (add-msg :system "Gate trace: use /why"))) - (list :name "/audit" :desc "Inspect memory object" - :action (lambda () (add-msg :system "/audit "))) - (list :name "/context" :desc "Show context budget" - :action (lambda () (add-msg :system "/context"))) - (list :name "/theme" :desc "Switch color theme" - :action (lambda () (add-msg :system "Presets: dark light solarized gruvbox"))) - (list :name "/sidebar" :desc "Toggle sidebar" - :action #'sidebar-toggle) - (list :name "/help" :desc "Show all commands" - :action (lambda () (add-msg :system "Commands: /focus /scope /search /theme /eval /setup /quit ..."))) - (list :name "/setup" :desc "Run setup wizard" - :action (lambda () (make-wizard-dialog))) - (list :name "/eval" :desc "Evaluate Lisp expression" - :action (lambda () (add-msg :system "/eval "))) - (list :name "/reconnect" :desc "Reconnect to daemon" - :action (lambda () (disconnect-daemon) (connect-daemon))) - (list :name "/quit" :desc "Save history and exit" - :action (lambda () (add-msg :system "* Goodbye *") - (send-daemon (list :type :event :payload '(:action :quit))) - (setf (st :running) nil)))) - "~25 slash commands driving cl-tty's Select widget in the minibuffer.") - -(defun open-minibuffer () - "Push a cl-tty.dialog:select-dialog with *slash-commands* onto cl-tty's dialog stack." - (cl-tty.dialog:push-dialog - (cl-tty.dialog:select-dialog - "Commands" - (loop for cmd in *slash-commands* - collect (list :title (getf cmd :name) - :value cmd - :desc (getf cmd :desc))) - :on-select (lambda (opt) - (let ((cmd (getf opt :value)) - (action (when cmd (getf cmd :action)))) - (when action (funcall action))))))) - -(defvar *daemon-commands* - (list - ;; Category: Session - (list :title "── Session ──" :category t) - (list :title "Focus Project" :value :focus :desc "Set project context" - :action (lambda () (add-msg :system "Usage: /focus "))) - (list :title "Change Scope" :value :scope :desc "Switch scope: memex|session|project" - :action (lambda () (add-msg :system "Usage: /scope memex|session|project"))) - (list :title "Unfocus" :value :unfocus :desc "Pop context stack" - :action (lambda () (send-daemon (list :type :event :payload (list :sensor :unfocus))))) - (list :title "Show Context" :value :context :desc "Show context budget summary" - :action (lambda () (add-msg :system "Use /context for budget or /context why for node details"))) - ;; Category: Memory - (list :title "── Memory ──" :category t) - (list :title "List Sessions" :value :sessions :desc "List memory snapshots" - :action (lambda () (add-msg :system "Use /sessions to list snapshots"))) - (list :title "Rewind" :value :rewind :desc "Rewind to snapshot" - :action (lambda () (add-msg :system "Usage: /rewind "))) - (list :title "Audit Node" :value :audit :desc "Inspect memory object" - :action (lambda () (add-msg :system "Usage: /audit "))) - ;; Category: System - (list :title "── System ──" :category t) - (list :title "Reconnect" :value :reconnect :desc "Reconnect to daemon" - :action (lambda () (disconnect-daemon) (connect-daemon))) - (list :title "Quit" :value :quit :desc "Save history and exit" - :action (lambda () (add-msg :system "* Goodbye *") - (send-daemon (list :type :event :payload '(:action :quit))) - (setf (st :running) nil))) - ;; Category: Help - (list :title "── Help ──" :category t) - (list :title "Show Help" :value :help :desc "Show all commands" - :action (lambda () (add-msg :system "Commands: /focus /scope /search /theme /eval /setup /quit ..."))) - (list :title "Why" :value :why :desc "Show last gate trace" - :action (lambda () (add-msg :system "Use /why to see last gate trace"))) - (list :title "Identity" :value :identity :desc "Edit IDENTITY.org" - :action (lambda () (add-msg :system "Use /identity to edit"))) - (list :title "Tags" :value :tags :desc "List tag severities" - :action (lambda () (add-msg :system "Use /tags to list tag severities")))) - "Daemon commands for the command palette (Ctrl+P), organized by category.") - -(defun open-command-palette () - "Push a select-dialog with *daemon-commands* onto cl-tty's dialog stack. - Ctrl+P opens this palette. Categories: Session, Memory, System, Help." - (cl-tty.dialog:push-dialog - (cl-tty.dialog:select-dialog - "Command Palette" - (loop for cmd in *daemon-commands* - collect (list :title (getf cmd :title) - :value cmd - :desc (getf cmd :desc) - :category (getf cmd :category))) - :on-select (lambda (opt) - (let ((cmd (getf opt :value)) - (action (when cmd (getf cmd :action)))) - (when action (funcall action))))))) - -(defun croatoan-to-tty-event (ch) - "Convert a Croatoan key code to a cl-tty key-event struct." - (typecase ch - (keyword - (case ch - (:up (cl-tty.input:make-key-event :key :up)) - (:down (cl-tty.input:make-key-event :key :down)) - (:enter (cl-tty.input:make-key-event :key :enter)) - (:escape (cl-tty.input:make-key-event :key :escape)) - (:backspace (cl-tty.input:make-key-event :key :backspace)) - (:ppage (cl-tty.input:make-key-event :key :page-up)) - (:npage (cl-tty.input:make-key-event :key :page-down)) - (t (cl-tty.input:make-key-event :key ch)))) - (integer - (cond - ((= ch 27) (cl-tty.input:make-key-event :key :escape)) - ((or (= ch 13) (= ch 10)) (cl-tty.input:make-key-event :key :enter)) - ((or (= ch 263) (= ch 127) (= ch 8)) (cl-tty.input:make-key-event :key :backspace)) - ((= ch 259) (cl-tty.input:make-key-event :key :up)) - ((= ch 258) (cl-tty.input:make-key-event :key :down)) - ((= ch 260) (cl-tty.input:make-key-event :key :left)) - ((= ch 261) (cl-tty.input:make-key-event :key :right)) - ((= ch 339) (cl-tty.input:make-key-event :key :page-up)) - ((= ch 338) (cl-tty.input:make-key-event :key :page-down)) - ((<= 1 ch 26) (cl-tty.input:make-key-event - :key (intern (string (code-char (+ #x60 ch))) :keyword) - :ctrl t)) - ((<= 32 ch 126) (cl-tty.input:make-key-event - :key (intern (string (char-upcase (code-char ch))) :keyword))) - (t (cl-tty.input:make-key-event :key :unknown :code ch)))) - (t nil))) - -(defun minibuffer-handle-key (ch) - "Route Croatoan key through the active dialog's select widget. - Printable chars update the filter; special keys route through cl-tty.select:select-handle-key. - Returns T if the dialog consumed the key." - (let ((stack cl-tty.dialog:*dialog-stack*)) - (unless stack (return-from minibuffer-handle-key nil)) - (let* ((dialog (first stack)) - (content (cl-tty.dialog:dialog-content dialog))) - (unless (typep content 'cl-tty.select:select) - (return-from minibuffer-handle-key nil)) - ;; Backspace: pop last filter char (if any) or pop dialog when empty - (when (or (eql ch :backspace) (eql ch 263) (eql ch 127) (eql ch 8)) - (let ((f (cl-tty.select:select-filter content))) - (if (and f (> (length f) 0)) - (progn (setf (cl-tty.select:select-filter content) (subseq f 0 (1- (length f)))) - (cl-tty.select::select-clamp-index content) - t) - (progn (cl-tty.dialog:pop-dialog) t)))) - ;; Escape: pop the dialog - (when (or (eql ch 27) (eq ch :escape)) - (cl-tty.dialog:pop-dialog) - t) - ;; Printable: append to filter if dialog is a select - (when (and (integerp ch) (<= 32 ch 126)) - (let* ((c (code-char ch)) - (f (or (cl-tty.select:select-filter content) ""))) - (setf (cl-tty.select:select-filter content) - (concatenate 'string f (string c))) - (cl-tty.select::select-clamp-index content) - t)) - ;; Route through cl-tty.select:select-handle-key for navigation/selection - (let ((ev (croatoan-to-tty-event ch))) - (when ev - (handler-case - (cl-tty.select:select-handle-key content ev) - (error () nil))))))) - -(defun make-wizard-dialog () - "Create a setup wizard dialog daisy-chain: provider select → API key → save. - Validates at each step; final step writes ~/.passepartout/config.lisp." - (let* ((state (list :provider nil :api-key nil :memory "1000" :step 0)) - (step-labels '("Provider" "API Key" "Memory" "Review & Save")) - (step-fns - (list - ;; Step 0: provider selection - (lambda (input) - (let ((p (string-downcase (string-trim '(#\Space) input)))) - (if (member p '("openai" "anthropic" "ollama" "openrouter" "deepseek" "groq") :test #'string=) - (progn (setf (getf state :provider) p) nil) - (format nil "Unknown provider: ~a" input)))) - ;; Step 1: API key - (lambda (input) - (let ((k (string-trim '(#\Space) input))) - (if (> (length k) 4) - (progn (setf (getf state :api-key) k) nil) - "Key too short"))) - ;; Step 2: memory limit - (lambda (input) - (let ((v (string-trim '(#\Space) input))) - (if (or (string= v "") (string= v "1000")) - nil - (if (every #'digit-char-p v) - (progn (setf (getf state :memory) v) nil) - "Enter a number")))) - ;; Step 3: save - (lambda (input) - (let ((v (string-downcase (string-trim '(#\Space) input)))) - (cond ((string= v "yes") - (let ((env-path (merge-pathnames ".passepartout/config.lisp" - (user-homedir-pathname)))) - (handler-case - (progn - (uiop:ensure-all-directories-exist (list env-path)) - (with-open-file (out env-path :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (format out ";; Passepartout configuration~%") - (format out "(setf *provider* ~s)~%" (getf state :provider)) - (format out "(setf *api-key* ~s)~%" (getf state :api-key)) - (format out "(setf *memory-max-entries* ~s)~%" (getf state :memory)))) - (error (c) (format nil "Write failed: ~a" c)))) - nil) - ((string= v "no") nil) - (t "Type 'yes' or 'no'"))))))) - (labels ((advance () - (let* ((step (getf state :step)) - (fn (nth step step-fns)) - (err (funcall fn "ignored"))) - (declare (ignore fn)) - ;; Push next prompt dialog or finish - (if (< step (1- (length step-labels))) - (progn - (setf (getf state :step) (1+ step)) - (cl-tty.dialog:push-dialog - (cl-tty.dialog:prompt-dialog - (format nil "~a — ~a" (nth (getf state :step) step-labels) - (getf state :provider)) - :on-submit (lambda (val) - (let ((validation (funcall (nth (getf state :step) step-fns) val))) - (if validation - (progn - (cl-tty.dialog:push-dialog - (cl-tty.dialog:alert-dialog "Error" validation)) - (setf (getf state :step) (1- step))) - (advance))))))) - (add-msg :system (format nil "Configuration saved (~a). Run /reconnect." - (getf state :provider))))))) - ;; Push the first prompt dialog - (cl-tty.dialog:push-dialog - (cl-tty.dialog:prompt-dialog - "Setup — LLM Provider" - :on-submit (lambda (val) - (let ((err (funcall (first step-fns) val))) - (if err - (cl-tty.dialog:push-dialog - (cl-tty.dialog:alert-dialog "Invalid" err)) - (advance))))))))) - -(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))) - -(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)) + ;; Printable (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)))))) + (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)))))))) -#+end_src - -#+begin_src lisp ;; 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." @@ -1125,23 +713,18 @@ The wizard-dialog subclass validates each step and writes config to (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)) - ;; v0.8.0: sidebar enrichment fields - (when (getf payload :block-counts) (setf (st :block-counts) (getf payload :block-counts))) - (when (getf payload :context-usage) (setf (st :context-usage) (getf payload :context-usage))) - (when (getf payload :modified-files) (setf (st :modified-files) (getf payload :modified-files))) - (when (getf payload :session-cost) (setf (st :session-cost) (getf payload :session-cost))) + (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)))))) -#+end_src +#+END_SRC ** Daemon Communication -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-main.lisp (defun send-daemon (msg) (let ((s (st :stream))) (when (and s (open-stream-p s)) @@ -1192,10 +775,10 @@ The wizard-dialog subclass validates each step and writes config to while line do (push line (st :input-history)))) (setf (st :input-history) (nreverse (st :input-history)))))) -#+end_src +#+END_SRC ** Connection -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-main.lisp (defun connect-daemon (&optional (host "127.0.0.1") (port 9105)) (add-msg :system "* Connecting to daemon... *") (loop for attempt from 1 to 3 @@ -1225,178 +808,75 @@ The wizard-dialog subclass validates each step and writes config to (ignore-errors (close (st :stream))) (setf (st :stream) nil (st :connected) nil) (add-msg :system "* Disconnected *"))) -#+end_src +#+END_SRC ** Main Loop -#+begin_src lisp -(defun tui-run-screen (scr) - "The full TUI event loop. Called from tui-main inside with-screen." - (let* ((h (or (height scr) 24)) - (w (or (width scr) 80)) - (sidebar-w (when (>= w 120) - (make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44)))) - (content-w (if sidebar-w (- w 44) (- w 2))) - (ch (- h 5)) - (sw (make-instance 'window :height 3 :width content-w :y 0 :x 1)) - (cw (make-instance 'window :height ch :width content-w :y 3 :x 1)) - (iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1)) - (swank-port (or (ignore-errors - (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) - 4006))) - (setf (function-keys-enabled-p iw) t - (input-blocking iw) nil - (st :dirty) (list t t t) - (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw) - (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 *")))) - (flet ((recreate-windows (scr-width scr-height) - (let* ((new-w scr-width) - (new-h scr-height) - (has-sidebar (and (>= new-w 120) (st :sidebar-visible))) - (new-sidebar-w (when has-sidebar - (make-instance 'window :height (- new-h 5) - :width 42 :y 3 :x (- new-w 44)))) - (new-content-w (if new-sidebar-w (- new-w 44) (- new-w 2))) - (new-ch (- new-h 5))) - (setq sw (make-instance 'window :height 3 :width new-content-w :y 0 :x 1) - ch new-ch - cw (make-instance 'window :height new-ch :width new-content-w :y 3 :x 1) - iw (make-instance 'window :height 1 :width new-content-w :y (- new-h 1) :x 1) - sidebar-w new-sidebar-w - w new-w - h new-h) - (setf (function-keys-enabled-p iw) t - (input-blocking iw) nil - (st :dirty) (list t t t) - (st :sw) sw (st :cw) cw (st :iw) iw)))) - (let ((initial-sidebar (and (>= w 120) (st :sidebar-visible)))) - (when initial-sidebar - (view-sidebar (or sidebar-w - (make-instance 'window :height (- h 5) :width 42 - :y 3 :x (- w 44)))) - (refresh (or sidebar-w - (make-instance 'window :height (- h 5) :width 42 - :y 3 :x (- w 44)))))) - (redraw sw cw ch iw) - (when sidebar-w - (view-sidebar sidebar-w) - (refresh sidebar-w)) - ;; v0.8.0: render cl-tty dialog overlay when stack is non-empty - (when (and (boundp 'cl-tty.dialog:*dialog-stack*) - cl-tty.dialog:*dialog-stack*) - (render-dialog-overlay scr w h)) - (refresh scr) - (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 *")))) - (let ((ch (get-char iw))) - (cond - ((or (not ch) (equal ch -1)) nil) - ((eql ch 410) - (recreate-windows (or (width scr) 80) (or (height scr) 24)) - (redraw sw cw ch iw) - (refresh scr)) - (t (ignore-errors (on-key ch))))) - (redraw sw cw ch iw) - (when sidebar-w - (view-sidebar sidebar-w) - (refresh sidebar-w)) - ;; Recreate windows when sidebar visibility or terminal width changes - (let ((sidebar-wanted (and (st :sidebar-visible) (>= w 120)))) - (when (or (and sidebar-wanted (not sidebar-w)) - (and (not sidebar-wanted) sidebar-w)) - (recreate-windows w h) - (redraw sw cw ch iw))) - ;; v0.8.0: render cl-tty dialog overlay - (when (and (boundp 'cl-tty.dialog:*dialog-stack*) - cl-tty.dialog:*dialog-stack*) - (render-dialog-overlay scr w h)) - (refresh scr) - (sleep 0.03)) - (disconnect-daemon)))) - -(defun render-dialog-overlay (scr w h) - "Render the top cl-tty dialog as a Croatoan overlay. - Draws a dimmed backdrop then a centered bordered panel with select options." - (let* ((dialog (first cl-tty.dialog:*dialog-stack*)) - (title (cl-tty.dialog:dialog-title dialog)) - (content (cl-tty.dialog:dialog-content dialog)) - (ww (min 60 (- w 4))) - (wh (min 18 (- h 4))) - (wx (floor (- w ww) 2)) - (wy (floor (- h wh) 2))) - ;; Dimmed backdrop - (dotimes (row h) - (add-string scr (make-string w :initial-element #\Space) - :y row :x 0 :fgcolor (theme-color :dim) :bgcolor (theme-color :background))) - ;; Dialog panel window - (let ((win (make-instance 'window :height wh :width ww :y wy :x wx))) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (add-string win (format nil " ~a " title) :y 0 :x 2 :fgcolor (theme-color :accent)) - ;; Render select widget options - (when (typep content 'cl-tty.select:select) - (let* ((filtered (cl-tty.select:select-filtered-options content)) - (sel-idx (cl-tty.select:select-selected-index content)) - (filter-str (cl-tty.select:select-filter content)) - (y 1)) - ;; Show filter line - (add-string win (format nil " > ~a_" (or filter-str "")) - :y y :x 2 :n (- ww 4) :fgcolor (theme-color :input)) - (incf y) - ;; Show filtered options - (dolist (item filtered) - (when (< y (1- wh)) - (let* ((display-idx (first item)) - (option (third item)) - (title-str (getf option :title)) - (desc (getf option :desc)) - (is-selected (= display-idx sel-idx)) - (fg (if is-selected (theme-color :highlight) (theme-color :agent)))) - (when is-selected - (setf (color-pair win) (list (theme-color :highlight) (theme-color :dim))) - (add-string win (make-string (- ww 2) :initial-element #\Space) - :y y :x 1 :n (- ww 2)) - (setf (color-pair win) (list (theme-color :border) (theme-color :background)))) - (add-string win (format nil "~a ~a" (if is-selected ">" " ") title-str) - :y y :x 2 :n (min 25 (- ww 4)) :fgcolor fg) - (when (and desc (not is-selected)) - (add-string win (format nil " ~a" desc) :y y :x 28 :n (- ww 30) - :fgcolor (theme-color :dim))) - (incf y)))) - ;; Footer hint - (add-string win (format nil " ~a/~a | ↑↓ Navigate Enter Execute Esc Close" - (1+ sel-idx) (length filtered)) - :y (1- wh) :x 1 :n (- ww 2) :fgcolor (theme-color :dim)))) - (refresh win) - (close win)))) - +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-main.lisp (defun tui-main () (init-state) (load-history) (theme-load) - (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) - (tui-run-screen scr))) - -#+end_src + (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 + (let ((k (cl-tty.input:key-event-key data)) + (ctrl (cl-tty.input:key-event-ctrl data))) + (if ctrl + (intern (format nil "CTRL-~a" k) :keyword) + k))) + (t data)))) + (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)))) +#+END_SRC * Test Suite -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-main.lisp (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) @@ -1871,109 +1351,4 @@ The wizard-dialog subclass validates each step and writes config to (setf (st :scroll-offset) 3) (on-key :npage) (fiveam:is (= 0 (st :scroll-offset)))) -#+end_src - -* v0.8.0 Tests — Sidebar, Palette, Theme, Wizard -#+begin_src lisp -(in-package :passepartout-tui-tests) - -(fiveam:test test-theme-hex-to-rgb - "Contract 4: theme-hex-to-rgb parses #RRGGBB to integer triple." - (multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "#5E81AC") - (fiveam:is (= 94 r)) - (fiveam:is (= 129 g)) - (fiveam:is (= 172 b)))) - -(fiveam:test test-theme-hex-to-rgb-invalid - "Contract 4: theme-hex-to-rgb returns white for invalid input." - (multiple-value-bind (r g b) (passepartout.channel-tui::theme-hex-to-rgb "not-a-color") - (fiveam:is (= 255 r)) - (fiveam:is (= 255 g)) - (fiveam:is (= 255 b)))) - -(fiveam:test test-sidebar-toggle - "Contract 7: sidebar-toggle flips :sidebar-visible and sets dirty flags." - (init-state) - (setf (st :dirty) (list nil nil nil)) - (passepartout.channel-tui::sidebar-toggle) - (fiveam:is (eq t (st :sidebar-visible))) - (fiveam:is (eq t (first (st :dirty)))) - (fiveam:is (eq t (second (st :dirty))))) - -(fiveam:test test-ctrl-x-b-toggles-sidebar - "Contract 5: Ctrl+X then Ctrl+B toggles sidebar." - (init-state) - (on-key 24) ; Ctrl+X - (fiveam:is (eq t (st :pending-ctrl-x))) - (on-key 2) ; Ctrl+B - (fiveam:is (eq t (st :sidebar-visible)))) - -(fiveam:test test-ctrl-p-opens-command-palette - "Contract 6: Ctrl+P opens command palette (pushes dialog with daemon commands)." - (init-state) - (on-key 16) ; Ctrl+P - (fiveam:is-true (and cl-tty.dialog:*dialog-stack*))) - -(fiveam:test test-open-minibuffer-pushes-dialog - "Contract 7: open-minibuffer pushes a dialog with a select content." - (let ((cl-tty.dialog:*dialog-stack* nil)) - (passepartout.channel-tui::open-minibuffer) - (fiveam:is (= 1 (length cl-tty.dialog:*dialog-stack*))) - (let ((item (first cl-tty.dialog:*dialog-stack*))) - (fiveam:is (string= "DIALOG" (symbol-name (class-name (class-of item))))) - (let ((content (cl-tty.dialog:dialog-content item))) - (fiveam:is (not (null content))))))) - -(fiveam:test test-slash-commands-count - "Contract 6: *slash-commands* has at least 14 entries with :name, :desc, :action." - (let ((cmds passepartout.channel-tui::*slash-commands*)) - (fiveam:is (>= (length cmds) 14)) - (dolist (c cmds) - (fiveam:is (stringp (getf c :name))) - (fiveam:is (stringp (getf c :desc))) - (fiveam:is (functionp (getf c :action)))))) - -(fiveam:test test-daemon-commands-count - "Contract 8: *daemon-commands* has at least 14 entries with :title, :desc, :action, category headers." - (let ((cmds passepartout.channel-tui::*daemon-commands*)) - (fiveam:is (>= (length cmds) 14)) - (dolist (c cmds) - (if (getf c :category) - (fiveam:is (stringp (getf c :title))) - (progn - (fiveam:is (stringp (getf c :title))) - (fiveam:is (stringp (getf c :desc))) - (fiveam:is (functionp (getf c :action)))))))) - -(fiveam:test test-minibuffer-handle-key-escape - "Contract 8: minibuffer-handle-key with Esc pops dialog." - (let ((cl-tty.dialog:*dialog-stack* nil)) - (passepartout.channel-tui::open-minibuffer) - (fiveam:is (= 1 (length cl-tty.dialog:*dialog-stack*))) - (passepartout.channel-tui::minibuffer-handle-key 27) ; Esc - (fiveam:is (null cl-tty.dialog:*dialog-stack*)))) - -(fiveam:test test-minibuffer-handle-key-backspace - "Contract 8: Backspace pops filter char, then pops dialog on empty." - (let ((cl-tty.dialog:*dialog-stack* nil)) - (passepartout.channel-tui::open-minibuffer) - (let ((sel (cl-tty.dialog:dialog-content (first cl-tty.dialog:*dialog-stack*)))) - (setf (cl-tty.select:select-filter sel) "te") - (passepartout.channel-tui::minibuffer-handle-key 263) ; Backspace - (fiveam:is (string= "t" (cl-tty.select:select-filter sel))) - (passepartout.channel-tui::minibuffer-handle-key 263) ; Backspace - (fiveam:is (string= "" (or (cl-tty.select:select-filter sel) "")))))) - -(fiveam:test test-croatoan-to-tty-event-arrows - "Contract 8: croatoan-to-tty-event converts Croatoan key codes to cl-tty key-events." - (let ((up (passepartout.channel-tui::croatoan-to-tty-event 259))) - (fiveam:is (cl-tty.input:key-event-p up)) - (fiveam:is (eql :up (cl-tty.input:key-event-key up)))) - (let ((down (passepartout.channel-tui::croatoan-to-tty-event 258))) - (fiveam:is (eql :down (cl-tty.input:key-event-key down)))) - (let ((enter (passepartout.channel-tui::croatoan-to-tty-event 13))) - (fiveam:is (eql :enter (cl-tty.input:key-event-key enter)))) - (let ((esc (passepartout.channel-tui::croatoan-to-tty-event 27))) - (fiveam:is (eql :escape (cl-tty.input:key-event-key esc))))) - -#+end_src +#+END_SRC diff --git a/org/channel-tui-state.org b/org/channel-tui-state.org index 2bcac6c..7c107da 100644 --- a/org/channel-tui-state.org +++ b/org/channel-tui-state.org @@ -6,66 +6,6 @@ The TUI state is a single plist accessed via ~st~ / ~(setf st)~. All state mutation flows through event handlers in the controller. -** v0.8.0 — Information Radiator: Sidebar State - -The sidebar is Passepartout's permanent UX differentiator — a 42-column -information panel that renders architectural data no competitor can display -because none has deterministic gates, foveal-peripheral context, or -rule-synthesizing Dispatcher to feed it. The sidebar makes the invisible -visible: seven panels of zero-LLM-token data from the deterministic layer, -always on screen when terminal width permits. - -The sidebar reads its data from daemon response fields enriched by the -~:tui~ actuator in ~core-act.org~. All seven panels consume existing -infrastructure: gate trace from ~cognitive-verify~ (v0.4.0), focus from -~*loop-focus-id*~ (v0.3.0), rules from ~*hitl-pending*~ (v0.3.0), context -from ~token-economics~ (v0.5.0), files from tool execution tracking -(v0.8.0 new), cost from ~cost-tracker~ (v0.5.0), and block counts from -the Dispatcher (v0.8.0 new). Each field arrives as a daemon-response -plist key; the TUI stores them in state fields read by ~view-sidebar~. - -When the terminal is narrower than 120 columns, the sidebar collapses to -an overlay toggled via ~/sidebar~ or ~Ctrl+X+B~. This preserves the -information radiator on constrained displays without sacrificing chat -area real estate. - -State additions: ~:sidebar-visible~ (boolean), ~:block-counts~ (alist), -~:context-usage~ (integer 0-100), ~:modified-files~ (list of plists), -~:session-cost~ (plist). - -** v0.8.0 — TrueColor Theme System - -The existing theme system uses Croatoan's standard 8-color palette -(cyan, green, red, white, etc.). v0.8.0 upgrades to 24-bit TrueColor -via Croatoan's ~set-rgb~ / ~init-color~ primitives, enabling hex-specified -colors (#5E81AC, #BF616A, etc.) on supporting terminals (iTerm2, Kitty, -WezTerm, Windows Terminal, Ghostty). - -The upgrade is backward compatible: terminals without TrueColor fall -back to the nearest standard color. Hex values are parsed by -~theme-hex-to-rgb~ (one-line format string → integer triple) and -registered once at theme-switch time via ~theme-init-truecolor~. -Subsequent ~theme-color~ lookups return the Croatoan color ID, same -API as the 8-color system. - -Four new presets join the existing four (dark, light, solarized, gruvbox): -- ~:nord~ — blue-gray backgrounds, frost accent -- ~:tokyonight~ — purple-blue backgrounds, teal accent -- ~:catppuccin~ — warm pastels, mauve accent -- ~:monokai~ — dark brown backgrounds, orange accent - -Each preset defines 27 hex color values, one per semantic key in -~*tui-theme*~. The 27 keys are: -roles (user, agent, system), content (input, timestamp, help, error, -warning), status (connected, disconnected, busy, idle), gate trace -(passed, blocked, approval, hitl), tools (running, success, failure, -output), display (scroll-indicator, border, background), differentiator -(rule-count, focus-map), and UI (dim, highlight, accent). - -An audit ensures every key from ~*tui-theme*~ is consumed by at least one -rendering function in ~channel-tui-view.org~. Missing keys become invisible -theme presets — defined but unused. - ** Contract 1. (init-state): returns a fresh state plist with ~:msgs~ list, @@ -75,32 +15,17 @@ theme presets — defined but unused. and optional gate-trace from the daemon (v0.4.0). 3. (queue-event ev): thread-safely enqueues an event for the reader loop. (drain-queue) returns and clears the queue. -4. (theme-hex-to-rgb hex-string): parses ~"#RRGGBB"~ to - ~(values r g b)~ integers 0-255. Returns ~(values 255 255 255)~ - for unparseable input (v0.8.0). -5. (theme-init-truecolor): registers hex color values from - ~*tui-theme*~ with Croatoan's ~init-color~ / ~set-rgb~. No-op - on terminals without TrueColor support (v0.8.0). -6. (theme-color key): extended contract (v0.8.0): if the ~*tui-theme*~ - entry for ~key~ is a hex string, returns the Croatoan color ID - registered by ~theme-init-truecolor~. Falls back to keyword - lookup for non-hex entries and non-TrueColor terminals. -7. (sidebar-toggle): toggles ~:sidebar-visible~ state. Sets dirty - flags to force sidebar redraw (v0.8.0). ** Package + State -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-state.lisp (defpackage :passepartout.channel-tui - (:use :cl :croatoan :passepartout :usocket :bordeaux-threads) + (:use :cl :passepartout :usocket :bordeaux-threads) (:export :tui-main :st :add-msg :now :input-string :queue-event :drain-queue :init-state :view-status :view-chat :view-input :redraw :on-key :on-daemon-msg :send-daemon :connect-daemon :disconnect-daemon - :*tui-theme* :theme-color - :*slash-commands* :open-minibuffer :minibuffer-handle-key - :view-conversation :render-user-msg :render-agent-msg - :render-sys-msg :render-tool-call :render-gate-trace)) + :*tui-theme* :theme-color)) (in-package :passepartout.channel-tui) (defvar *state* nil) @@ -125,7 +50,7 @@ theme presets — defined but unused. :rule-count :cyan :focus-map :yellow ;; UI :dim :white :highlight :cyan :accent :green) - "Color theme plist. 27 semantic keys → Croatoan color values. + "Color theme plist. 27 semantic keys → hex color strings. See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") (defvar *tui-theme-presets* @@ -160,43 +85,7 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") :tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496" :scroll-indicator "#2aa198" :border "#657b83" :background "#002b36" :rule-count "#2aa198" :focus-map "#b58900" - :dim "#586e75" :highlight "#2aa198" :accent "#859900") - :nord (:user "#81a1c1" :agent "#d8dee9" :system "#ebcb8b" - :input "#d8dee9" :timestamp "#4c566a" :help "#88c0d0" :error "#bf616a" :warning "#ebcb8b" - :connected "#a3be8c" :disconnected "#bf616a" :busy "#b48ead" :idle "#616e88" - :gate-passed "#a3be8c" :gate-blocked "#bf616a" :gate-approval "#ebcb8b" - :hitl "#b48ead" - :tool-running "#b48ead" :tool-success "#a3be8c" :tool-failure "#bf616a" :tool-output "#d8dee9" - :scroll-indicator "#88c0d0" :border "#4c566a" :background "#2e3440" - :rule-count "#88c0d0" :focus-map "#ebcb8b" - :dim "#616e88" :highlight "#88c0d0" :accent "#5e81ac") - :tokyonight (:user "#7aa2f7" :agent "#c0caf5" :system "#e0af68" - :input "#c0caf5" :timestamp "#565f89" :help "#7dcfff" :error "#f7768e" :warning "#e0af68" - :connected "#9ece6a" :disconnected "#f7768e" :busy "#bb9af7" :idle "#565f89" - :gate-passed "#9ece6a" :gate-blocked "#f7768e" :gate-approval "#e0af68" - :hitl "#bb9af7" - :tool-running "#bb9af7" :tool-success "#9ece6a" :tool-failure "#f7768e" :tool-output "#c0caf5" - :scroll-indicator "#7dcfff" :border "#1f2335" :background "#1a1b26" - :rule-count "#7dcfff" :focus-map "#e0af68" - :dim "#565f89" :highlight "#7dcfff" :accent "#7aa2f7") - :catppuccin (:user "#89b4fa" :agent "#cdd6f4" :system "#f9e2af" - :input "#cdd6f4" :timestamp "#585b70" :help "#94e2d5" :error "#f38ba8" :warning "#f9e2af" - :connected "#a6e3a1" :disconnected "#f38ba8" :busy "#cba6f7" :idle "#6c7086" - :gate-passed "#a6e3a1" :gate-blocked "#f38ba8" :gate-approval "#f9e2af" - :hitl "#cba6f7" - :tool-running "#cba6f7" :tool-success "#a6e3a1" :tool-failure "#f38ba8" :tool-output "#cdd6f4" - :scroll-indicator "#94e2d5" :border "#45475a" :background "#1e1e2e" - :rule-count "#94e2d5" :focus-map "#f9e2af" - :dim "#6c7086" :highlight "#94e2d5" :accent "#89b4fa") - :monokai (:user "#a6e22e" :agent "#f8f8f2" :system "#e6db74" - :input "#f8f8f2" :timestamp "#75715e" :help "#66d9ef" :error "#f92672" :warning "#e6db74" - :connected "#a6e22e" :disconnected "#f92672" :busy "#ae81ff" :idle "#75715e" - :gate-passed "#a6e22e" :gate-blocked "#f92672" :gate-approval "#e6db74" - :hitl "#ae81ff" - :tool-running "#ae81ff" :tool-success "#a6e22e" :tool-failure "#f92672" :tool-output "#f8f8f2" - :scroll-indicator "#66d9ef" :border "#49483e" :background "#272822" - :rule-count "#66d9ef" :focus-map "#e6db74" - :dim "#75715e" :highlight "#66d9ef" :accent "#a6e22e")) + :dim "#586e75" :highlight "#2aa198" :accent "#859900")) "Named theme presets. /theme loads one into *tui-theme*.") (defvar *tui-theme-current-name* :dark @@ -232,40 +121,15 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") key))) (defun theme-color (role) - "Returns the Croatoan color for a semantic role. - Keyword or hex string values are returned as-is; hex strings are - converted to integers that Croatoan can process." + "Returns a hex color string for a semantic role, suitable for cl-tty." (let ((val (or (getf *tui-theme* role) :white))) - (if (and (stringp val) (> (length val) 0) (eql (char val 0) #\#)) - (handler-case (parse-integer (subseq val 1) :radix 16) - (error () val)) - val))) - -;; v0.8.0: TrueColor helpers -(defun theme-hex-to-rgb (hex-string) - "Parse #RRGGBB to (values r g b). Returns (255 255 255) for invalid input." - (if (and (stringp hex-string) (= 7 (length hex-string)) (eql (char hex-string 0) #\#)) - (handler-case - (let ((r (parse-integer (subseq hex-string 1 3) :radix 16)) - (g (parse-integer (subseq hex-string 3 5) :radix 16)) - (b (parse-integer (subseq hex-string 5 7) :radix 16))) - (values r g b)) - (error () (values 255 255 255))) - (values 255 255 255))) - -(defun theme-init-truecolor () - "Register hex colors from *tui-theme* with Croatoan's init-color." - (handler-case - (loop for (key val) on *tui-theme* by #'cddr - when (and (stringp val) (= 7 (length val)) (eql (char val 0) #\#)) - do (multiple-value-bind (r g b) (theme-hex-to-rgb val) - (init-color key (/ r 255.0) (/ g 255.0) (/ b 255.0)))) - (error () nil))) - -(defun sidebar-toggle () - "Toggle sidebar visibility. Sets dirty flags for full redraw." - (setf (st :sidebar-visible) (not (st :sidebar-visible))) - (setf (st :dirty) (list t t t))) + (cond + ((stringp val) val) + (t (case val + (:green "#00FF00") (:red "#FF0000") (:cyan "#00FFFF") + (:yellow "#FFFF00") (:magenta "#FF00FF") (:blue "#0000FF") + (:white "#FFFFFF") (:black "#000000") + (t "#FFFFFF")))))) (defun st (key) (getf *state* key)) (defun (setf st) (val key) (setf (getf *state* key) val)) @@ -282,13 +146,11 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") :collapsed-gates nil ; v0.7.2 :search-mode nil :search-query "" ; v0.7.2 :search-matches nil :search-match-idx 0 - :sidebar-visible nil ; v0.8.0 - :expand-tool-calls nil ; v0.8.0 :dirty (list nil nil nil)))) -#+end_src +#+END_SRC ** Helpers -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-state.lisp (defun now () (multiple-value-bind (s m h) (get-decoded-time) (declare (ignore s)) @@ -322,10 +184,10 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") (unless (st :scroll-at-bottom) (setf (st :scroll-notify) t)) (setf (st :dirty) (list t t nil))) -#+end_src +#+END_SRC ** Event Queue -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-state.lisp (defun queue-event (ev) (bt:with-lock-held (*event-lock*) (push ev *event-queue*))) @@ -333,4 +195,4 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") (bt:with-lock-held (*event-lock*) (let ((evs (nreverse *event-queue*))) (setf *event-queue* nil) evs))) -#+end_src +#+END_SRC diff --git a/org/channel-tui-view.org b/org/channel-tui-view.org index 43595e9..8d0709b 100644 --- a/org/channel-tui-view.org +++ b/org/channel-tui-view.org @@ -3,153 +3,26 @@ * View -Pure render functions. Each takes a Croatoan window and current state. -State is read via ~(st :key)~ — no mutation here. - -** v0.8.0 — Sidebar: The Information Radiator - -The sidebar is Passepartout's permanent UX differentiator. No competitor -can render gate traces, focus maps, or rule counters because none has -deterministic gates, foveal-peripheral context, or rule synthesis. The -sidebar makes this data permanently visible in a 42-column panel at the -right of the terminal. - -Seven panels stack vertically: - -1. *Gate Trace* — per-message trace from the most recent agent response, - colored by gate state: green for passed, red for blocked, yellow for - HITL-required. Mirrors the per-message gate trace from v0.7.2 but - always visible. - -2. *Focus* — the current foveal node ID from ~*loop-focus-id*~ plus a - related-node count from the last context assembly. Shows the user - what the agent is "looking at." - -3. *Rules* — the Dispatcher's ~*hitl-pending*~ count with a progress bar - toward certification threshold. Shows how many user decisions the - Dispatcher has learned from. - -4. *Context* — token gauge bar with percentage and color coding (green - < 50%, yellow 50-80%, orange 80-95%, red > 95%). Data from - ~token-economics~ ~context-usage-percentage~. - -5. *Files* — list of files modified in the most recent tool execution. - Each entry shows filepath and +/- line count where computable. - -6. *Cost* — session cost from ~cost-tracker~: total USD spent, call - count, per-provider breakdown. - -7. *Protection* — gate effectiveness counter from the Dispatcher's - ~*dispatcher-block-counts*~: how many actions each gate blocked this - session. This is the specific-value-proposition panel — no competitor - has deterministic gates to count. - -The sidebar is a fourth Croatoan window at the right of the terminal when -width ≥ 120 columns. At < 120 columns, it becomes an absolute-positioned -overlay toggled via ~/sidebar~ or ~Ctrl+X+B~. The overlay uses the same -rendering function (~view-sidebar~) and same data paths. - -** v0.8.0 — Command Palette - -The command palette provides a single discoverable entry point for all -TUI commands. Currently, commands are invisible — the user must know -~/help~ exists to discover ~/focus~, ~/rewind~, ~/context~, etc. The -palette solves this with a fuzzy-searchable overlay (Ctrl+P) organized -by category: - -- *Session* — ~/focus~, ~/scope~, ~/unfocus~, ~/rename~ -- *Agent* — ~/approve~, ~/deny~, ~/why~, ~/audit~, ~/context~ -- *View* — ~/theme~, ~/sidebar~, ~/search~, ~/clear~ -- *System* — ~/eval~, ~/status~, ~/reconnect~, ~/quit~ - -The palette renders as a centered Croatoan window overlay. Typing -filters items by fuzzy substring match on both command name and -description. Up/Down navigates; Enter executes; Esc dismisses. -Keyboard shortcuts (Ctrl+G, Ctrl+F, Ctrl+D, etc.) are displayed -as hints next to each item. - -This mirrors OpenCode's command palette pattern — a proven UX -convention that makes power commands discoverable without reading -documentation. - -** v0.8.0 — Conversation View: ScrollBox + Markdown - -The chat conversation is the primary TUI surface — it shows every -message exchanged with the daemon. The v0.8.0 refactoring replaces -the ad-hoc ~view-chat~ with a ScrollBox-driven conversation view -using cl-tty's markdown renderer and component model. - -Each message type has a dedicated render function: - -- *User messages*: ~render-user-msg~ — a colored line with role - prefix (green, "⬆ user"). Content is plain-text with word wrap. -- *Agent messages*: ~render-agent-msg~ — rendered through cl-tty's - ~parse-blocks~ + ~render-md~ for full markdown (bold, code, - links, blockquotes, code blocks with syntax highlighting, diffs). -- *System messages*: ~render-sys-msg~ — yellow, dimmed. -- *Tool executions*: ~render-tool-call~ — collapsible block showing - tool name, status (running ✓ ✗), duration, and truncated output. - Tab toggles expansion (~expand-tool-calls~ state). -- *Gate traces*: ~render-gate-trace~ — collapsible block (Ctrl+G - toggles per-message via ~collapsed-gates~ state). - -Sticky-scroll: when the user is at the bottom (scroll-offset 0), -new messages auto-scroll into view. Manual scroll-up sets -~sticky-scroll~ nil until the user scrolls back to bottom. - -~view-conversation~ replaces ~view-chat~. The ~redraw~ function -calls ~view-conversation~ instead. +|Pure render functions. Each takes the cl-tty backend and current state. +|State is read via ~(st :key)~ — no mutation here. ** Contract 1. (view-status win): renders the status bar with connection info, - msg count, scroll offset, rule counter, focus map, and timestamp. - Two lines: line 1 (status + rules), line 2 (focus + time). -2. (view-conversation win h): renders the scrolled conversation using - cl-tty ScrollBox model. Dispatches per-role to dedicated render - functions (~render-user-msg~, ~render-agent-msg~, ~render-sys-msg~, - ~render-tool-call~, ~render-gate-trace~). Sticky-scroll auto-follows - when at bottom. + msg count, scroll offset, rule counter, focus map (v0.4.0), and + timestamp. Two lines: line 1 (status + rules), line 2 (focus + time). +2. (view-chat win h): renders the scrolled chat message list. Takes + window and available height. Messages are color-coded: green (user), + white (agent), yellow (system). 3. (view-input win): renders the input line with cursor and typing indicator. 4. (redraw sw cw ch iw): dispatches redraws based on ~(st :dirty)~ flags (status, chat, input). Minimizes terminal writes. -5. (render-user-msg win content time w y): renders a user message - with green role-prefix, timestamp, and word-wrapped content. - Returns next y (v0.8.0). -6. (render-agent-msg win content time gate-trace w y collapsed): - renders an agent message through cl-tty's ~render-markdown~. - Gate trace rendered after content when not collapsed (v0.8.0). -7. (render-sys-msg win content w y): renders a system message in - yellow, dim style. Returns next y (v0.8.0). -8. (render-tool-call win tool-name status content w y): renders a - tool call with status indicator (running ✓ ✗), truncated output, - expandable via Tab. Returns next y (v0.8.0). -9. (render-gate-trace win trace w y): renders gate decisions as - colored lines (green passed, red blocked, yellow HITL). - Collapsible via Ctrl+G per message. Returns next y (v0.8.0). 5. (char-width ch): returns the terminal column width of character CH. ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8. Used by word-wrap for accurate line counting (v0.7.0). 6. (view-status win): v0.7.0 — timestamp right-aligned at (- w 12) on line 2, focus info at :x 1. No overlap. -7. (redraw sw cw sidebar-w ch iw): v0.8.0 — redraw dispatches to - five windows: status, chat, sidebar (when visible and ≥120 cols), - input. In overlay mode (<120 cols), sidebar is rendered as an - absolute-positioned overlay window on top of chat. -8. (view-sidebar window): renders 42-column sidebar with 7 panels - stacked vertically: Gate Trace, Focus, Rules, Context gauge, - Files, Cost, Protection. Each panel title uses ~:accent~ color. - Returns number of lines rendered (v0.8.0). -9. (view-palette window items filter-query selected-idx): renders - command palette as centered overlay (~60% width, ~50% height). - Shows category headers, filtered items with highlighted selection, - keyboard shortcut hints. Scrolls when items exceed available - height (v0.8.0). -10. (view-wizard window step input error): renders setup wizard UI: - step title (~:accent~), prompt text (~:agent~), input area, - error message in ~:error~ color, progress indicator "Step N/M" - at bottom (v0.8.0). ** Status Bar @@ -169,31 +42,29 @@ architecture: All three enrichments cost 0 LLM tokens — they are daemon-state queries that the TUI actuator attaches to the response plist before transmission. -#+begin_src lisp +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp (in-package :passepartout.channel-tui) -(defun view-status (win) - (clear win) - (box win 0 0) - (add-string win - (format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a" +(defun view-status (fb w) + (let ((line1 (format nil + " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a" (if (st :connected) "● Connected" "○ Disconnected") (string-upcase (string (st :mode))) (length (st :messages)) (if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0") (or (st :rule-count) 0) (if (st :streaming-text) " [streaming]" - (if (st :busy) " …thinking" ""))) - :y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected))) - ;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0) - (let ((focus-info (or (st :foveal-id) ""))) - (when (and focus-info (> (length focus-info) 0)) - (add-string win (format nil " [Focus: ~a]" focus-info) - :y 2 :x 1 :fgcolor (theme-color :timestamp)))) - (add-string win (format nil " ~a" (now)) - :y 2 :x (max 1 (- (width win) 12)) - :fgcolor (theme-color :timestamp)) - (refresh win)) + (if (st :busy) " …thinking" ""))))) + (cl-tty.backend:draw-text fb 1 1 line1 + (theme-color (if (st :connected) :connected :disconnected)) + nil) + ;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0) + (let ((focus-info (or (st :foveal-id) ""))) + (when (and focus-info (> (length focus-info) 0)) + (cl-tty.backend:draw-text fb 1 2 (format nil " [Focus: ~a]" focus-info) + (theme-color :timestamp) nil))) + (cl-tty.backend:draw-text fb (max 1 (- w 12)) 2 (format nil " ~a" (now)) + (theme-color :timestamp) nil))) ;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown (defun search-highlight (content query) @@ -212,98 +83,23 @@ that the TUI actuator attaches to the response plist before transmission. (setf result (concatenate 'string result (subseq content pos))) (if (string= result "") content result)))) -(defun render-user-msg (win content time w y) - "Render a user message with green role-prefix and timestamp. Returns next y." - (let* ((prefix (format nil "⬆ [~a] " time)) - (line-text (concatenate 'string prefix content)) - (wrapped (word-wrap line-text (- w 2)))) - (dolist (line wrapped) - (when (< y 9999) - (add-string win line :y y :x 1 :n (1- w) :fgcolor (theme-color :user)) - (incf y))) - y)) - -(defun render-agent-msg (win content time w y) - "Render an agent message using cl-tty's markdown renderer. Returns next y." - (let* ((prefix (format nil "⬇ [~a] " time)) - (header-len (length prefix))) - ;; Role prefix line - (add-string win prefix :y y :x 1 :n header-len :fgcolor (theme-color :agent)) - (incf y) - ;; Markdown content — cl-tty's render-markdown produces ANSI-styled lines - (let ((md-lines (cl-tty.markdown:render-md - (cl-tty.markdown:parse-blocks content)))) - (dolist (line md-lines) - (when (< y 9999) - ;; Each line may contain ANSI escape codes; render through add-string - (add-string win line :y y :x 1 :n (- w 2) :fgcolor (theme-color :agent)) - (incf y)))) - y)) - -(defun render-sys-msg (win content w y) - "Render a system message in yellow, dim style. Returns next y." - (let* ((line-text (format nil " ~a" content)) - (wrapped (word-wrap line-text (- w 2)))) - (dolist (line wrapped) - (when (< y 9999) - (add-string win line :y y :x 1 :n (1- w) :fgcolor (theme-color :system)) - (incf y))) - y)) - -(defun render-tool-call (win tool-name status duration content w y tab-expanded) - "Render a tool call with status indicator. Tab toggles full output. Returns next y." - (let* ((status-char (case status (:running "…") (:success "✓") (:failure "✗") (t "?"))) - (status-color (case status (:running (theme-color :tool-running)) - (:success (theme-color :tool-success)) - (:failure (theme-color :tool-failure)) - (t (theme-color :dim)))) - (summary (format nil " ~a ~a~@[ (~,1fs)~]" status-char tool-name duration))) - ;; Summary line - (add-string win summary :y y :x 1 :n (- w 2) :fgcolor status-color) - (incf y) - ;; Expanded output (when Tab pressed) - (when tab-expanded - (dolist (line (word-wrap content (- w 6))) - (when (< y 9999) - (add-string win (format nil " ~a" line) :y y :x 1 :n (- w 4) :fgcolor (theme-color :tool-output)) - (incf y)))) - y)) - -(defun render-gate-trace (win trace w y collapsed) - "Render gate decisions as colored lines. Ctrl+G toggles. Returns next y." - (unless collapsed - (dolist (entry (gate-trace-lines trace)) - (when (< y 9999) - (add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim)) - (incf y)))) - y) - -(defun view-conversation (win h) - "Render scrolled message list using cl-tty ScrollBox model. - Sticky-scroll: auto-follows new content when at bottom. - Each message role dispatched to its dedicated render function." - (clear win) - (box win 0 0) - (let* ((w (or (width win) 78)) - (msgs (st :messages)) +(defun view-chat (fb w h) + (let* ((msgs (st :messages)) (total (length msgs)) (max-lines (- h 2)) (is-search (st :search-mode)) (y 1)) - ;; Search mode header + ;; v0.7.2: search mode header (when is-search (let* ((matches (st :search-matches)) (idx (st :search-match-idx)) (query (st :search-query)) (header (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit" (length matches) query (1+ idx) (length matches)))) - (add-string win header :y y :x 1 :n (1- w) :fgcolor (theme-color :highlight)) + (cl-tty.backend:draw-text fb 1 y header (theme-color :highlight) nil) (incf y) (decf max-lines))) - ;; Sticky-scroll: if at bottom, auto-follow - (when (and (zerop (st :scroll-offset)) (> total 0)) - (setf (st :scroll-at-bottom) t)) - ;; Count visible messages from end + ;; Count visible messages from end, accounting for word wrap (let* ((msg-count 0) (lines-remaining max-lines)) (loop for i from (1- total) downto 0 @@ -312,16 +108,17 @@ that the TUI actuator attaches to the response plist before transmission. (role (getf msg :role)) (content (getf msg :content)) (time (or (getf msg :time) "")) - (nlines (case role - (:user (length (word-wrap (format nil "⬆ [~a] ~a" time content) (- w 2)))) - (:agent (let ((header (format nil "⬇ [~a]" time))) - (+ 1 (length (cl-tty.markdown:render-md - (cl-tty.markdown:parse-blocks content)))))) - (t (length (word-wrap (format nil " ~a" content) (- w 2))))))) + (prefix (case role (:user "⬆") (:agent "⬇") (t " "))) + (content-show (if is-search + (search-highlight content (st :search-query)) + content)) + (line-text (format nil "~a [~a] ~a" prefix time content-show)) + (wrapped (word-wrap line-text (- w 2))) + (nlines (length wrapped))) (if (<= nlines lines-remaining) (progn (decf lines-remaining nlines) (incf msg-count)) (setf lines-remaining 0)))) - ;; Render from start message + ;; Render from the correct starting message (let* ((scroll-skip (st :scroll-offset)) (start (max 0 (- total msg-count scroll-skip)))) (loop for i from start below total @@ -330,168 +127,57 @@ that the TUI actuator attaches to the response plist before transmission. (role (getf msg :role)) (content (getf msg :content)) (time (or (getf msg :time) "")) - (gate-trace (getf msg :gate-trace)) - (collapsed (member i (st :collapsed-gates))) - (tool-name (getf msg :tool)) - (tool-status (getf msg :tool-status)) - (tool-duration (getf msg :tool-duration)) - (tool-expanded (member i (st :expand-tool-calls)))) - (setf y (case role - (:user (render-user-msg win content time w y)) - (:agent (progn - (setf y (render-agent-msg win content time w y)) - (when gate-trace - (setf y (render-gate-trace win gate-trace w y collapsed))) - y)) - (t (render-sys-msg win content w y)))) - ;; Tool call block (attached to any role message) - (when tool-name - (setf y (render-tool-call win tool-name tool-status tool-duration - content w y tool-expanded))))))) - ;; Sticky-scroll update - (when (and (st :scroll-at-bottom) (plusp (length msgs))) - (setf (st :scroll-offset) 0)) - (refresh win))) -#+end_src + (color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent)))) + (prefix (case role (:user "⬆") (:agent "⬇") (t " "))) + (is-panel (getf msg :panel)) + (is-resolved (getf msg :panel-resolved)) + (content-show (if is-search + (search-highlight content (st :search-query)) + content)) + (line-text (format nil "~a [~a] ~a" prefix time content-show)) + (wrapped (word-wrap line-text (- w 2)))) + ;; HITL panel: render with colored border + (when is-panel + (setf color (if is-resolved + (theme-color :dim) + (theme-color :hitl)))) + (dolist (line wrapped) + (when (< y (1- h)) + (cl-tty.backend:draw-text fb 1 y line color nil) + (incf y))) + ;; v0.7.2: gate trace below agent messages + (let ((gate-trace (getf msg :gate-trace))) + (when (and gate-trace (not (member i (st :collapsed-gates)))) + (dolist (entry (passepartout::gate-trace-lines gate-trace)) + (when (< y (1- h)) + (cl-tty.backend:draw-text fb 3 y (car entry) + (or (getf (cdr entry) :fgcolor) :dim) nil) + (incf y))))))))))) +#+END_SRC ** Input Line -#+begin_src lisp -(defun view-input (win) +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp +(defun view-input (fb w) (let* ((text (input-string)) - (w (or (width win) 78)) (pos (or (st :cursor-pos) 0)) (display-start (max 0 (- pos (1- w)))) (visible (subseq text display-start (min (length text) (+ display-start w))))) - (clear win) - (add-string win (format nil "~a " visible) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input)) - (setf (cursor-position win) (list 0 (min (- pos display-start) (1- w))))) - (refresh win)) + (cl-tty.backend:draw-text fb 0 0 (format nil "~a " visible) (theme-color :input) nil))) #+end_src ** Redraw (dirty-flag dispatch) #+begin_src lisp -(defun redraw (sw cw ch iw) +(defun redraw (fb w h) (destructuring-bind (sd cd id) (st :dirty) - (when sd (view-status sw)) - (when cd (view-conversation cw ch)) - (when id (view-input iw)) - (setf (st :dirty) (list nil nil nil)))) -#+end_src - -* Test Suite -#+begin_src lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload :fiveam :silent t)) - -(defpackage :passepartout-tui-view-tests - (:use :cl :fiveam :passepartout) - (:export #:tui-view-suite)) - -(in-package :passepartout-tui-view-tests) - -(def-suite tui-view-suite :description "TUI view rendering helpers") -(in-suite tui-view-suite) - -(test test-char-width-ascii - "Contract 5: ASCII characters (< 128) have width 1." - (is (= 1 (char-width #\a))) - (is (= 1 (char-width #\Space))) - (is (= 1 (char-width #\@)))) - -(test test-char-width-tab - "Contract 5: tab character has width 8." - (is (= 8 (char-width #\Tab)))) - -(test test-char-width-cjk - "Contract 5: CJK characters have width 2." - (is (= 2 (char-width #\日)))) - -(test test-char-width-null - "Contract 5: null has width 0." - (is (= 0 (char-width #\Nul)))) - -(test test-markdown-bold - "Contract 7: parse-markdown-spans detects **bold**." - (let ((segments (parse-markdown-spans "hello **world**!"))) - (is (= 3 (length segments))))) - -(test test-markdown-plain - "Contract 7: plain text returns single segment." - (let ((segments (parse-markdown-spans "plain"))) - (is (= 1 (length segments))) - (is (string= "plain" (caar segments))))) - -(test test-markdown-url - "Contract 7: parse-markdown-spans detects URLs." - (let ((segments (parse-markdown-spans "see https://example.com for more"))) - (is (>= (length segments) 2)) - (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) - -(test test-markdown-blocks - "Contract 8: parse-markdown-blocks detects code blocks." - (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) - (segs (parse-markdown-blocks text))) - (is (= 3 (length segs))) - (let ((code (second segs))) - (is (eq t (getf code :code-block))) - (is (string= "lisp" (getf code :lang))) - (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) - -(test test-markdown-blocks-no-close - "Contract 8: unclosed code block returns content." - (let* ((text (format nil "```~%unclosed code")) - (segs (parse-markdown-blocks text))) - (is (= 1 (length segs))) - (is (eq t (getf (first segs) :code-block))))) - -(test test-syntax-highlight - "Contract 9: syntax-highlight colors Lisp code." - (let ((segs (syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) - (is (>= (length segs) 3)))) - -(test test-syntax-highlight-keyword - "Contract 9: syntax-highlight colors keywords." - (let ((segs (syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) - (is (>= (length segs) 2)) - (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-syntax-highlight-function - "Contract 9: syntax-highlight colors function calls." - (let ((segs (syntax-highlight "(+ 1 2)" "lisp"))) - (is (>= (length segs) 2)) - (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) - -(test test-gate-trace-lines-passed - "Contract 9: gate-trace-lines for passed gate." - (let ((lines (gate-trace-lines - '((:gate "path" :result :passed))))) - (is (= 1 (length lines))) - (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) - -(test test-gate-trace-lines-blocked - "Contract 9: gate-trace-lines for blocked gate." - (let ((lines (gate-trace-lines - '((:gate "shell" :result :blocked :reason "rm"))))) - (is (= 1 (length lines))) - (is (search "rm" (caar lines))))) - -(test test-gate-trace-lines-approval - "Contract 9: gate-trace-lines for approval gate." - (let ((lines (gate-trace-lines - '((:gate "network" :result :approval))))) - (is (= 1 (length lines))) - (is (search "HITL" (caar lines))))) - -(test test-init-state-has-collapsed-gates - "Contract v0.7.2: init-state includes :collapsed-gates field." - (passepartout.channel-tui::init-state) - (let ((cg (passepartout.channel-tui::st :collapsed-gates))) - (is (null cg)))) -#+end_src + (when sd (view-status fb w)) + (when cd (view-chat fb w (- h 5))) + (when id (view-input fb w)) + (setf (st :dirty) (list nil nil nil)))) +#+END_SRC * Implementation — v0.7.0 additions -#+begin_src lisp -(in-package :passepartout.channel-tui) +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp +(in-package :passepartout) (defun char-width (ch) "Returns the terminal column width of character CH. @@ -514,39 +200,11 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." ((<= #x20D0 code #x20FF) 0) ((<= #xFE00 code #xFE0F) 0) (t 1)))) - -(defun word-wrap (text max-width) - "Split TEXT into lines that fit within MAX-WIDTH columns. -Word-breaks at spaces when possible; breaks mid-word if necessary. -Respects CJK/emoji char widths via char-width." - (let ((lines nil) - (start 0) - (end (length text))) - (loop while (< start end) do - (let* ((col 0) - (pos start) - (last-break start)) - (loop while (< pos end) - for width = (char-width (char text pos)) do - (when (char= (char text pos) #\Space) - (setf last-break pos)) - (when (> (+ col width) max-width) - (return)) - (incf col width) - (incf pos) - (when (>= pos end) (return))) - (let ((line-end (if (> pos start) pos (1+ start)))) - (when (>= line-end end) (setf line-end end)) - (push (subseq text start line-end) lines) - (setf start (if (and (< line-end end) (char= (char text line-end) #\Space)) - (1+ line-end) - line-end))))) - (nreverse lines))) -#+end_src +#+END_SRC * v0.7.1 — Markdown Rendering -#+begin_src lisp -(in-package :passepartout.channel-tui) +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp +(in-package :passepartout) (defun parse-markdown-spans (text) "Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))." @@ -586,28 +244,22 @@ Respects CJK/emoji char widths via char-width." (t (push (cons (subseq text pos) nil) results) (return)))))))) (nreverse results))) -(defun render-styled (win segments y x w) - "Render markdown segments to Croatoan window. Returns next y." +(defun render-styled (fb segments y x w) + "Render markdown segments to cl-tty backend. Returns next y." (dolist (seg segments) - (when (>= y (height win)) (return y)) (let* ((text (or (car seg) "")) (attrs (cdr seg)) (bold (getf attrs :bold)) (code (getf attrs :code)) - (underline (getf attrs :underline)) - (url (getf attrs :url)) - (style-bits (append (when bold '(:bold)) - (when underline '(:underline))))) - (when style-bits - (add-attributes win (get-bitmask style-bits))) - (add-string win text :y y :x x :n (max 1 (- w x)) - :bgcolor (when code (theme-color :dim)) - :fgcolor (cond (url (theme-color :highlight)) - (t (theme-color (or (getf attrs :role) :agent))))) - (when style-bits - (remove-attributes win (get-bitmask style-bits))) + (url (getf attrs :url))) + (declare (ignore code)) + (cl-tty.backend:draw-text fb x y text + (cond (url (theme-color :highlight)) + (t (theme-color (or (getf attrs :role) :agent)))) + nil + :bold bold) (incf x (length text)))) - (1+ y)) + y) (defun parse-markdown-blocks (text) "Split text at ``` code block boundaries." @@ -670,11 +322,11 @@ Respects CJK/emoji char widths via char-width." :keyword :function))) r) (setf p fe))))))))) (nreverse r))) -#+end_src +#+END_SRC * v0.7.2 — Gate Trace -#+begin_src lisp -(in-package :passepartout.channel-tui) +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp +(in-package :passepartout) (defun gate-trace-lines (trace) "Convert gate-trace plist to display lines." @@ -685,14 +337,14 @@ Respects CJK/emoji char widths via char-width." (reason (getf entry :reason)) (name (or gate "unknown")) (color (case result - (:passed (theme-color :gate-passed)) - (:blocked (theme-color :gate-blocked)) - (:approval (theme-color :gate-approval)) - (t (theme-color :dim)))) + (:passed :gate-passed) + (:blocked :gate-blocked) + (:approval :gate-approval) + (t :dim))) (prefix (case result - (:passed " ✓ ") - (:blocked " ✗ ") - (:approval " → ") + (:passed " \u2713 ") + (:blocked " \u2717 ") + (:approval " \u2192 ") (t " ? "))) (text (format nil "~a~a~@[~a~]~@[~a~]" prefix name @@ -700,348 +352,115 @@ Respects CJK/emoji char widths via char-width." (if (eq result :approval) " (HITL required)" "")))) (push (cons text (list :fgcolor color)) lines))) (nreverse lines))) -#+end_src +#+END_SRC -* v0.8.0 — Sidebar + Minibuffer View -#+begin_src lisp -(in-package :passepartout.channel-tui) +* Test Suite +#+BEGIN_SRC lisp :tangle ../lisp/channel-tui-view.lisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload :fiveam :silent t)) -;; ── Sidebar Panel Slots ── -;; Each sidebar panel is a cl-tty slot registration with :mode :replace. -;; The sidebar orchestrates them in order, passing (win w h y) and -;; receiving the next y position. +(defpackage :passepartout-tui-view-tests + (:use :cl :fiveam :passepartout) + (:export #:tui-view-suite)) -(defun render-sidebar-panel-header (win w y title) - (add-string win (format nil "── ~a ──" title) :y y :x 1 :n (- w 2) - :fgcolor (theme-color :accent)) - (1+ y)) - -(cl-tty.slot:defslot :sidebar-gate-trace :mode :replace - :render-fn - (lambda (win w h y) - (let ((trace (st :gate-trace))) - (setf y (render-sidebar-panel-header win w y "Gate Trace")) - (if trace - (dolist (entry (gate-trace-lines trace)) - (when (< y (1- h)) - (add-string win (car entry) :y y :x 2 :n (- w 4) - :fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim))) - (incf y))) - (add-string win " (no trace)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - y))) - -(cl-tty.slot:defslot :sidebar-focus :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (render-sidebar-panel-header win w y "Focus")) - (add-string win (format nil " ~a" (or (st :foveal-id) "(none)")) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map)) - (+ y 2))) - -(cl-tty.slot:defslot :sidebar-rules :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Rules")) - (add-string win (format nil " Rules: ~d" (or (st :rule-count) 0)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count)) - (1+ y))) - -(cl-tty.slot:defslot :sidebar-context :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Context")) - (let* ((pct (or (st :context-usage) 0)) - (bar-width 30) - (filled (min bar-width (floor (* pct bar-width) 100))) - (gauge-color (cond ((< pct 50) (theme-color :connected)) - ((< pct 80) (theme-color :warning)) - ((< pct 95) (theme-color :tool-running)) - (t (theme-color :error))))) - (add-string win (format nil " [~a~a] ~d%" - (make-string filled :initial-element #\█) - (make-string (- bar-width filled) :initial-element #\░) - pct) - :y y :x 2 :n (- w 4) :fgcolor gauge-color)) - (1+ y))) - -(cl-tty.slot:defslot :sidebar-files :mode :replace - :render-fn - (lambda (win w h y) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Files")) - (let ((files (st :modified-files))) - (if files - (dolist (f files) - (when (< y (1- h)) - (let ((fp (getf f :filepath)) - (added (getf f :lines-added)) - (removed (getf f :lines-removed))) - (add-string win (format nil " ~a~@[ +~d~]~@[ -~d~]" - (subseq fp (max 0 (- (length fp) 30))) - (when (> added 0) added) - (when (> removed 0) removed)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) - (incf y)))) - (add-string win " (no changes)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - y))) - -(cl-tty.slot:defslot :sidebar-cost :mode :replace - :render-fn - (lambda (win w h y) - (declare (ignore h)) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Cost")) - (let ((cost (st :session-cost))) - (if cost - (progn - (add-string win (format nil " Total: $~,4f" (getf cost :total)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) - (incf y) - (add-string win (format nil " Calls: ~d" (getf cost :calls)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))) - (add-string win " (no data)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - (1+ y)))) - -(cl-tty.slot:defslot :sidebar-protection :mode :replace - :render-fn - (lambda (win w h y) - (setf y (+ y 2)) - (setf y (render-sidebar-panel-header win w y "Protection")) - (let ((bc (st :block-counts))) - (if (and bc (> (getf bc :total) 0)) - (let ((by-gate (getf bc :by-gate))) - (dolist (entry (subseq by-gate 0 (min (length by-gate) 6))) - (when (< y (1- h)) - (add-string win (format nil " ~a: ~d" (car entry) (cdr entry)) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :gate-blocked)) - (incf y)))) - (add-string win " (no blocks)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))) - y))) - -(defun view-sidebar (win) - "Render 42-column sidebar with panel slots: Gate Trace, Focus, Rules, Context, Files, Cost, Protection." - (clear win) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (let ((w (or (width win) 42)) - (h (or (height win) 24)) - (y 1)) - (dolist (panel '(:sidebar-gate-trace :sidebar-focus :sidebar-rules - :sidebar-context :sidebar-files :sidebar-cost - :sidebar-protection)) - (let ((result (cl-tty.slot:slot-render panel win w h y))) - (when result (setf y (min (1- h) result))))) - (refresh win) - (1- y))) - -(defun view-minibuffer (win) - "Render the bottom-anchored minibuffer panel. Dispatches on :minibuffer-mode." - (case (st :minibuffer-mode) - (:slash-menu (view-slash-menu win)) - (:wizard (view-wizard-in-panel win)) - (t nil))) - -(declaim (special *slash-commands*)) ; forward declaration — defined in channel-tui-main - -(defun view-slash-menu (win) - "Render the slash-command menu: filter bar, filtered command list, selection highlight." - (clear win) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (let* ((w (or (width win) 60)) - (h (or (height win) 10)) - (y 1) - (filter (or (st :minibuffer-filter) "")) - (commands passepartout.channel-tui::*slash-commands*) - (filtered (if (or (null filter) (string= filter "")) - (mapcar (lambda (c) (list :index (position c commands) :cmd c)) commands) - (let ((q (string-downcase filter)) (i 0) (r nil)) - (dolist (c commands (nreverse r)) - (when (or (search q (string-downcase (getf c :name))) - (search q (string-downcase (or (getf c :desc) "")))) - (push (list :index i :cmd c) r)) - (incf i))))) - (sel (or (st :minibuffer-selected-idx) 0)) - (max-visible (- h 3))) - ;; Header: filter bar - (add-string win (format nil " Commands") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) - (incf y) - (add-string win (format nil " > ~a_" (if (> (length filter) 0) filter "/")) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :input)) - (incf y) - ;; Command list - (if filtered - (let* ((start (max 0 (- sel (floor max-visible 2)))) - (end (min (length filtered) (+ start max-visible))) - (flat-i 0)) - (loop for entry across (subseq (coerce filtered 'vector) start end) - for fi from start - for cmd = (getf entry :cmd) - do (let* ((name (getf cmd :name)) - (desc (getf cmd :desc)) - (selected (= fi sel)) - (fg (if selected (theme-color :highlight) (theme-color :agent)))) - (when selected - (add-string win (make-string (- w 4) :initial-element #\Space) :y y :x 2 :n (- w 4) - :fgcolor (theme-color :dim) :bgcolor (theme-color :highlight))) - (let ((prefix (if selected " > " " "))) - (add-string win (format nil "~a~a" prefix name) :y y :x 3 :n (min (- w 6) 25) :fgcolor fg) - (when desc - (add-string win (format nil " — ~a" desc) :y y :x 28 :n (min (- w 30) (length desc)) :fgcolor (theme-color :dim)))) - (incf y)))) - (progn - (add-string win " (no matching commands)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (incf y))) - ;; Footer - (add-string win " ↑↓ Navigate Enter Execute Esc Close" - :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (refresh win) - (- h 0))) - -(defun view-wizard-in-panel (win) - "Render the setup wizard in the bottom-anchored minibuffer panel. Three modes: provider-list, key-entry, cascade-config." - (clear win) - (setf (color-pair win) (list (theme-color :border) (theme-color :background))) - (box win 0 0) - (let* ((w (or (width win) 70)) - (h (or (height win) 14)) - (y 1) - (mode (st :wizard-mode)) - (error-msg (st :wizard-error)) - (selected-idx (st :wizard-selected-idx)) - (providers (passepartout.channel-tui::wizard-provider-list)) - (configured (st :wizard-providers))) - (add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) - (incf y 2) - (case mode - (:provider-list - (let ((count (/ (length configured) 2))) - (add-string win (format nil "Configure Providers~a" - (if (> count 0) (format nil " — ~d configured" count) "")) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (incf y) - (loop for p in providers - for i from 0 - do (let* ((meta (passepartout.channel-tui::wizard-provider-meta p)) - (name (car meta)) - (key (getf configured p)) - (prefix (if (= i selected-idx) "> " " ")) - (suffix (if key " ✓" "")) - (color (if (= i selected-idx) - (theme-color :highlight) - (theme-color :dim)))) - (add-string win (format nil "~a~a~a" prefix name suffix) - :y y :x 3 :n (- w 6) :fgcolor color) - (incf y))) - (incf y) - (add-string win " Done — configure cascade" - :y y :x 3 :n (- w 6) - :fgcolor (if (>= selected-idx (length providers)) - (theme-color :highlight) - (theme-color :dim))) - (when (>= selected-idx (length providers)) - (add-string win ">" :y y :x 1 :n 2 :fgcolor (theme-color :highlight)))) - (:key-entry - (let* ((provider (st :wizard-current-provider)) - (meta (passepartout.channel-tui::wizard-provider-meta provider)) - (name (car meta)) - (url (cadr meta)) - (input (or (st :wizard-input) ""))) - (add-string win (format nil "API Key: ~a" name) :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) - (incf y) - (when url - (add-string win (format nil "Get key at: ~a" url) :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)) - (incf y)) - (add-string win "Enter your API key." :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)) - (incf y 2) - (add-string win (format nil "Key: > ~a" input) :y y :x 3 :n (- w 6) :fgcolor (theme-color :input)) - (incf y) - (when error-msg - (add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error)) - (incf y)) - (incf y) - (add-string win "Enter=Save Esc=Back Bksp=Edit Ctrl+U=Clear" - :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (return-from view-wizard-in-panel))) - (:cascade-config - (let* ((slot (st :wizard-cascade-slot)) - (slot-providers (getf (st :wizard-cascade) slot)) - (slot-label (cadr (assoc slot passepartout.channel-tui::*wizard-cascade-labels*))) - (count (/ (length configured) 2))) - (add-string win (format nil "Configure Cascade — ~d provider~:p" count) - :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) - (incf y) - (add-string win (or slot-label "Unknown") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) - (incf y) - (let ((shown nil)) - (loop for p in providers - for i from 0 - do (when (getf configured p) - (let* ((meta (passepartout.channel-tui::wizard-provider-meta p)) - (name (car meta)) - (in-slot (member p slot-providers)) - (prefix (if (= i selected-idx) "> " " ")) - (mark (if in-slot " [✓]" " [ ]")) - (color (if (= i selected-idx) - (theme-color :highlight) - (if in-slot (theme-color :gate-passed) (theme-color :dim))))) - (add-string win (format nil "~a~a~a" prefix name mark) - :y y :x 3 :n (- w 6) :fgcolor color) - (incf y) - (push t shown)))) - (unless shown - (add-string win " (no providers configured)" - :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)) - (incf y))) - (incf y) - (add-string win (format nil "Cascade: ~{~a~^, ~}" - (or slot-providers '("(none)"))) - :y y :x 3 :n (- w 6) :fgcolor (theme-color :dim)))) - (when error-msg - (incf y) - (add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error))) - (let ((footer (case mode - (:provider-list "↑↓ Navigate Enter=Select Esc=Back Ctrl+D=Remove") - (:cascade-config "↑↓ Select Enter=Toggle Tab=Next Quadrant Ctrl+S=Save Esc=Back") - (t "")))) - (when footer - (add-string win footer :y (- h 0) :x 2 :n (- w 4) :fgcolor (theme-color :dim)))) - (- h 0))))) - -#+end_src - -* v0.8.0 Tests — Sidebar View + Minibuffer View -#+begin_src lisp (in-package :passepartout-tui-view-tests) -(test test-theme-hex-string-keys-exist - "v0.8.0: all 27 theme keys are present in *tui-theme*." - (let* ((theme passepartout.channel-tui::*tui-theme*) - (required '(:user :agent :system :input :timestamp :help :error :warning - :connected :disconnected :busy :idle - :gate-passed :gate-blocked :gate-approval :hitl - :tool-running :tool-success :tool-failure :tool-output - :scroll-indicator :border :background - :rule-count :focus-map - :dim :highlight :accent))) - (dolist (key required) - (is (getf theme key) (format nil "~a should be defined" key))))) +(def-suite tui-view-suite :description "TUI view rendering helpers") +(in-suite tui-view-suite) -(test test-theme-presets-count - "v0.8.0: 8 presets defined: dark, light, solarized, gruvbox, nord, tokyonight, catppuccin, monokai." - (let* ((presets passepartout.channel-tui::*tui-theme-presets*) - (names '(:dark :light :solarized :gruvbox :nord :tokyonight :catppuccin :monokai))) - (dolist (name names) - (is (getf presets name) (format nil "~a preset should exist" name))))) +(test test-char-width-ascii + "Contract 5: ASCII characters (< 128) have width 1." + (is (= 1 (passepartout::char-width #\a))) + (is (= 1 (passepartout::char-width #\Space))) + (is (= 1 (passepartout::char-width #\@)))) -(test test-minibuffer-init-state-fields - "Contract v0.8.0: init-state no longer has legacy palette/wizard fields." +(test test-char-width-tab + "Contract 5: tab character has width 8." + (is (= 8 (passepartout::char-width #\Tab)))) + +(test test-char-width-cjk + "Contract 5: CJK characters have width 2." + (is (= 2 (passepartout::char-width #\日)))) + +(test test-char-width-null + "Contract 5: null has width 0." + (is (= 0 (passepartout::char-width #\Nul)))) + +(test test-markdown-bold + "Contract 7: parse-markdown-spans detects **bold**." + (let ((segments (passepartout::parse-markdown-spans "hello **world**!"))) + (is (= 3 (length segments))))) + +(test test-markdown-plain + "Contract 7: plain text returns single segment." + (let ((segments (passepartout::parse-markdown-spans "plain"))) + (is (= 1 (length segments))) + (is (string= "plain" (caar segments))))) + +(test test-markdown-url + "Contract 7: parse-markdown-spans detects URLs." + (let ((segments (passepartout::parse-markdown-spans "see https://example.com for more"))) + (is (>= (length segments) 2)) + (is (find t segments :key (lambda (s) (getf (cdr s) :url)))))) + +(test test-markdown-blocks + "Contract 8: parse-markdown-blocks detects code blocks." + (let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 3 (length segs))) + (let ((code (second segs))) + (is (eq t (getf code :code-block))) + (is (string= "lisp" (getf code :lang))) + (is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content))))))) + +(test test-markdown-blocks-no-close + "Contract 8: unclosed code block returns content." + (let* ((text (format nil "```~%unclosed code")) + (segs (passepartout::parse-markdown-blocks text))) + (is (= 1 (length segs))) + (is (eq t (getf (first segs) :code-block))))) + +(test test-syntax-highlight + "Contract 9: syntax-highlight colors Lisp code." + (let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp"))) + (is (>= (length segs) 3)))) + +(test test-syntax-highlight-keyword + "Contract 9: syntax-highlight colors keywords." + (let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp"))) + (is (>= (length segs) 2)) + (is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-syntax-highlight-function + "Contract 9: syntax-highlight colors function calls." + (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp"))) + (is (>= (length segs) 2)) + (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor)))))) + +(test test-gate-trace-lines-passed + "Contract 9: gate-trace-lines for passed gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "path" :result :passed))))) + (is (= 1 (length lines))) + (is (eq :gate-passed (getf (cdar lines) :fgcolor))))) + +(test test-gate-trace-lines-blocked + "Contract 9: gate-trace-lines for blocked gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "shell" :result :blocked :reason "rm"))))) + (is (= 1 (length lines))) + (is (search "rm" (caar lines))))) + +(test test-gate-trace-lines-approval + "Contract 9: gate-trace-lines for approval gate." + (let ((lines (passepartout::gate-trace-lines + '((:gate "network" :result :approval))))) + (is (= 1 (length lines))) + (is (search "HITL" (caar lines))))) + +(test test-init-state-has-collapsed-gates + "Contract v0.7.2: init-state includes :collapsed-gates field." (passepartout.channel-tui::init-state) - (is (null (getf passepartout.channel-tui::*state* :mode))) - (is (null (getf passepartout.channel-tui::*state* :palette-visible)))) -#+end_src + (let ((cg (passepartout.channel-tui::st :collapsed-gates))) + (is (null cg)))) +#+END_SRC diff --git a/passepartout.asd b/passepartout.asd index 4b9c7eb..22f0d3f 100644 --- a/passepartout.asd +++ b/passepartout.asd @@ -6,7 +6,7 @@ :description "The Probabilistic-Deterministic Lisp Machine" :depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid) :serial t - :components ((:file "lisp/core-package") + :components ((:file "lisp/core-package") (:file "lisp/core-skills") (:file "lisp/core-transport") (:file "lisp/core-memory") @@ -16,7 +16,7 @@ (:file "lisp/core-pipeline"))) (defsystem :passepartout/tui - :depends-on (:passepartout :croatoan :cl-tty :usocket :bordeaux-threads) + :depends-on (:passepartout :cl-tty :usocket :bordeaux-threads) :serial t :components ((:file "lisp/channel-tui-state") (:file "lisp/channel-tui-view")