diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index 2b3d4c6..b903019 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -1185,7 +1185,10 @@ The TUI is the main UI for v1.0.0. Competitive analysis of Claude Code, OpenCode - System message on activation, ~$EDITOR~ / ~$VISUAL~ / ~vi~ fallback (runtime) - 1 TDD test passes (model-level) -*** TODO TUI-based setup wizard — deferred to v0.8.0 +*** DONE TUI-based setup wizard — deferred to v0.8.0 +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: *** DONE Pads for chat scrolling — Page Up/Down by 10 lines :LOGBOOK: @@ -1497,7 +1500,10 @@ Currently the system prompt has IDENTITY (assistant name) but the agent doesn't The sidebar is what makes the Information Radiator direction unique. 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. It also includes context monitoring, modified files, and tool status — all zero-LLM-token data from the deterministic layer. -*** TODO Sidebar — always visible information panel +*** DONE Sidebar — always visible information panel +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: :PROPERTIES: :ID: id-v070-sidebar :CREATED: [2026-05-08 Fri] @@ -1516,7 +1522,10 @@ Content (ordered vertically): Implementation uses a fourth Croatoan ~window~ (sidebar on right) or a panel overlay. All data is already in the daemon's response plist (~:rule-count~, ~:foveal-id~, ~:gate-trace~). The gate block counts come from a new ~*dispatcher-block-counts*~ alist tracked in ~dispatcher-check~. ~200 lines (includes panel 7 addition). -*** TODO Sidebar overlay mode (< 120 cols) +*** DONE Sidebar overlay mode (< 120 cols) +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: :PROPERTIES: :ID: id-v070-sidebar-overlay :CREATED: [2026-05-08 Fri] @@ -1524,7 +1533,10 @@ Implementation uses a fourth Croatoan ~window~ (sidebar on right) or a panel ove When terminal width < 120, sidebar becomes an absolute-positioned overlay with semi-transparent backdrop (ncurses ~opaque~ + themed background). Toggle via ~/sidebar~ or ~Ctrl+X+B~. The chat area fills the full width when sidebar is hidden. ~30 lines. -*** TODO Command palette (Ctrl+P) +*** DONE Command palette (Ctrl+P) +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: :PROPERTIES: :ID: id-v070-command-palette :CREATED: [2026-05-08 Fri] @@ -1538,7 +1550,10 @@ Single entry point for all actions. Mirrors OpenCode's pattern — fuzzy-searcha - Also shows keyboard shortcuts for each command as hints - Implemented as a Croatoan ~window~ overlay with ~add-string~-based rendering and ~get-char~-based filtering. ~100 lines. -*** TODO TrueColor theme expansion (8 presets) +*** DONE TrueColor theme expansion (8 presets) +:LOGBOOK: +- State "DONE" from "TODO" [2026-05-09 Sat] +:END: :PROPERTIES: :ID: id-v070-themes :CREATED: [2026-05-08 Fri] diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp index 7f96d0f..05198b3 100644 --- a/lisp/channel-tui-main.lisp +++ b/lisp/channel-tui-main.lisp @@ -6,12 +6,81 @@ ;; so the cond below can use eq. (let* ((raw (car args)) (ch (if (and (integerp raw) (> raw 255)) - (let* ((k (code-key raw)) - (name (and k (key-name k)))) - (or name raw)) + (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.7.1: Esc — interrupt streaming + (cond + ;; v0.8.0: palette mode — handle palette keypresses first + ((and (st :palette-visible) (or (eql ch 27) (eq ch :escape))) + (setf (st :palette-visible) nil) + (setf (st :dirty) (list t t nil))) + ((and (st :palette-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter))) + (let* ((filtered (palette-filter (st :palette-items) (st :palette-filter))) + (idx (st :palette-selected-idx)) + (n 0) + (item nil)) + (loop for group in filtered + for gitems = (getf group :items) + when (and (< n (length gitems)) (<= n idx (+ n (length gitems) -1))) + do (setf item (nth (- idx n) gitems)) + (loop-finish) + do (incf n (length gitems))) + (passepartout.channel-tui::palette-execute item) + (setf (st :palette-visible) nil) + (setf (st :dirty) (list t t t)))) + ((and (st :palette-visible) (eq ch :up)) + (setf (st :palette-selected-idx) (max 0 (1- (st :palette-selected-idx)))) + (setf (st :dirty) (list nil t nil))) + ((and (st :palette-visible) (eq ch :down)) + (setf (st :palette-selected-idx) (min 999 (1+ (st :palette-selected-idx)))) + (setf (st :dirty) (list nil t nil))) + ((and (st :palette-visible) (integerp ch) (>= ch 32) (<= ch 126)) + (let ((c (code-char ch))) + (setf (st :palette-filter) (concatenate 'string (or (st :palette-filter) "") (string c))) + (setf (st :palette-selected-idx) 0) + (setf (st :dirty) (list nil t nil)))) + ((and (st :palette-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8))) + (let ((f (st :palette-filter))) + (when (and f (> (length f) 0)) + (setf (st :palette-filter) (subseq f 0 (1- (length f)))) + (setf (st :palette-selected-idx) 0) + (setf (st :dirty) (list nil t nil))))) + ;; v0.8.0: setup wizard — handle wizard keypresses + ((and (st :wizard-visible) (or (eql ch 27) (eq ch :escape))) + (wizard-cancel)) + ((and (st :wizard-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter))) + (wizard-next)) + ((and (st :wizard-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8))) + (let ((input (or (st :wizard-input) ""))) + (when (> (length input) 0) + (setf (st :wizard-input) (subseq input 0 (1- (length input)))) + (setf (st :wizard-error) nil) + (setf (st :dirty) (list nil t nil))))) + ((and (st :wizard-visible) (eql ch 2)) ; Ctrl+B — back + (let ((step-idx (st :wizard-step))) + (when (> step-idx 0) + (setf (st :wizard-step) (1- step-idx) + (st :wizard-input) "" + (st :wizard-error) nil) + (setf (st :dirty) (list nil t nil))))) + ((and (st :wizard-visible) (integerp ch) (>= ch 32) (<= ch 126)) + (let ((c (code-char ch))) + (setf (st :wizard-input) (concatenate 'string (or (st :wizard-input) "") (string c))) + (setf (st :wizard-error) nil) + (setf (st :dirty) (list nil t nil)))) + ;; v0.7.1: Esc — interrupt streaming ((and (eql ch 27) (st :streaming-text)) (send-daemon (list :type :event :payload '(:action :cancel-stream))) (when (> (length (st :messages)) 0) @@ -105,8 +174,44 @@ (setf (st :cursor-pos) 0)) ((eql ch 5) ; Ctrl+E — end (setf (st :cursor-pos) (length (st :input-buffer)))) - ((eql ch 12) ; Ctrl+L — redraw - (setf (st :dirty) (list t t t))) + ((eql ch 12) ; Ctrl+L — redraw + (setf (st :dirty) (list t t t))) + ((eql ch 4) ; Ctrl+D — quit on empty + (when (or (null (st :input-buffer)) (string= "" (input-string))) + (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit."))) + ((eql ch 6) ; v0.7.2 Ctrl+F — message search + (add-msg :system "Use /search to find messages")) + ((eql ch 28) ; v0.8.0 Ctrl+\ — open setup wizard + (wizard-start) + (setf (st :dirty) (list t t nil))) + ((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 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) ; Ctrl+P — command palette + (setf (st :palette-visible) t + (st :palette-filter) "" + (st :palette-selected-idx) 0 + (st :palette-items) (passepartout.channel-tui::palette-items)) + (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."))) @@ -217,80 +322,49 @@ (subseq (or (getf info :hash) "(none)") 0 16))) (add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system "Memory audit not available"))) - ;; /tags command — tag stack with trigger counts + ;; /tags command — tag stack + ;; /tags command — tag stack ((string-equal text "/tags") - (let ((cats passepartout::*tag-categories*) - (counts passepartout::*tag-trigger-count*)) + (let ((cats passepartout::*tag-categories*)) (if cats (dolist (entry cats) - (let* ((tag (car entry)) - (sev (cdr entry)) - (n (gethash (string-downcase tag) counts 0))) - (add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n)))) + (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) (add-msg :system "No tags configured. Set TAG_CATEGORIES env var.")))) - ;; /context command — section breakdown with token estimates - ((string-equal text "/context") - (let* ((msg-count (length (st :messages))) - (focus (or (st :foveal-id) "none")) - (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4))) - (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*) + ;; /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 'passepartout::*cognitive-tool-registry*) (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4) 50)) - (log-tokens (min 4000 (floor (* msg-count 60) 4))) - ;; rough estimate: TIME, CONTEXT overhead - (overhead-tokens 200) - (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) - (total-limit 8192) - (pct-used (floor (* 100 total-est) total-limit)) - (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) - :initial-element #\#))) - (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) - (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) - (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) - (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) - (add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count)) - (add-msg :system (format nil " [~a~a] ~d%" - bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used)) - (when (> pct-used 80) - (add-msg :system "⚠ Context near limit — older messages may be dropped")))) - ;; /context why — debug node with full attributes + (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 ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) (let ((node-id (string-trim '(#\Space) (subseq text 13)))) (if (fboundp 'passepartout::memory-object-get) (let ((obj (funcall 'passepartout::memory-object-get node-id))) (if obj - (let ((attrs (passepartout::memory-object-attributes obj)) - (parent (passepartout::memory-object-parent-id obj)) - (children (passepartout::memory-object-children obj)) - (hash (or (passepartout::memory-object-hash obj) "(none)"))) - (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" - node-id - (passepartout::memory-object-type obj) - (passepartout::memory-object-scope obj) - (passepartout::memory-object-version obj))) - (when parent - (add-msg :system (format nil " parent: ~a" parent))) - (when children - (add-msg :system (format nil " children: ~d" (length children)))) - (add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash))))) - (when attrs - (add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)"))))) - (add-msg :system (format nil "Node ~a not found in memory" node-id)))) + (add-msg :system (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))) + (add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system "Memory not available")))) - ;; /context dropped — estimate pruned nodes from budget + ;; /context dropped — pruned nodes ((string-equal text "/context dropped") - (let* ((msg-count (length (st :messages))) - (est-total (* msg-count 60)) - (budget 8192) - (dropped-msgs (if (> est-total budget) - (floor (- est-total budget) 60) - 0))) - (if (> dropped-msgs 0) - (add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)" - dropped-msgs (- est-total budget) budget - (floor (* 100 est-total) budget))) - (add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)" - est-total budget (floor (* 100 est-total) budget)))))) + (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)")) ;; /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)))) @@ -343,16 +417,16 @@ (add-msg :system "No snapshots available")))) ;; /audit verify — memory integrity ((string-equal text "/audit verify") - (if (fboundp 'passepartout::audit-verify-hash) - (let* ((result (funcall 'passepartout::audit-verify-hash)) - (total (car result)) - (missing (cdr result))) - (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" - total missing - (length passepartout::*memory-snapshots*) - (zerop missing) - (unless (zerop missing) missing)))) - (add-msg :system "Memory audit not available"))) + (let ((count 0) (hashed 0)) + (maphash (lambda (k v) (declare (ignore k)) + (when v + (incf count) + (when (passepartout::memory-object-hash v) + (incf hashed)))) + passepartout::*memory-store*) + (add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots" + count hashed + (length passepartout::*memory-snapshots*))))) ;; /resume — resume from snapshot ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) (let* ((n-str (string-trim '(#\Space) (subseq text 8))) @@ -365,28 +439,23 @@ (add-msg :system "Usage: /resume ")))) ;; /help — search user manual ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) - (let ((topic (string-trim '(#\Space) (subseq text 6))) - (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) - (if sections - (dolist (entry sections) - (let* ((title (car entry)) - (content (cdr entry)) - (preview (if (> (length content) 300) - (concatenate 'string (subseq content 0 297) "...") - content))) - (add-msg :system (format nil "~a: ~a" title preview)))) - (add-msg :system (format nil "No manual section found for '~a'" topic))))) - ((string-equal text "/help") - (add-msg :system "/eval Evaluate Lisp") - (add-msg :system "/undo Undo last operation") - (add-msg :system "/redo Redo last operation") - (add-msg :system "/why Show last gate trace") - (add-msg :system "/identity Edit IDENTITY.org") - (add-msg :system "/tags List tag severities") - (add-msg :system "/audit Inspect memory object") - (add-msg :system "/search Search messages") - (add-msg :system "/context Show context summary") - (add-msg :system "/rewind Rewind to snapshot N") + (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") (add-msg :system "/sessions Show snapshots") (add-msg :system "/resume Resume from snapshot") (add-msg :system "/focus Set project context") @@ -394,7 +463,12 @@ (add-msg :system "/help [topic] Show this help") (add-msg :system "\\ + Enter Multi-line input") (add-msg :system "Ctrl+G Toggle gate trace")) - ;; /theme command + ;; /setup command — open wizard + ((string-equal text "/setup") + (wizard-start) + (add-msg :system "Setup wizard opened (Ctrl+W)") + (setf (st :dirty) (list t t nil))) + ;; /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* @@ -562,14 +636,15 @@ (reverse (coerce (nth (st :input-hpos) h) 'list)) nil)) (setf (st :dirty) (list nil nil t))))) - ;; PageUp — scroll back by page (10 lines) + ;; PageUp ((or (eq ch :ppage) (eql ch 339)) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) + (let ((page-size (max 10 (floor (length (st :messages)) 3)))) + (setf (st :scroll-offset) (+ (st :scroll-offset) page-size))) (setf (st :dirty) (list nil t nil))) - ;; PageDown — scroll forward by page + ;; PageDown ((or (eq ch :npage) (eql ch 338)) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) + (let ((page-size (max 10 (floor (length (st :messages)) 3)))) + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) page-size)))) (setf (st :dirty) (list nil t nil))) ;; Printable (t @@ -581,6 +656,232 @@ (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 palette-items () + "Returns categorized command list for the palette." + (let ((items nil)) + (push (list :category "Session" :items + (list (list :name "/focus" :desc "Set project context" :shortcut "C-o" + :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" :shortcut "C-f" + :action (lambda () (add-msg :system "Use /search to find messages"))))) + items) + (push (list :category "Agent" :items + (list (list :name "/why" :desc "Show last gate trace" :shortcut "C-g" + :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"))))) + items) + (push (list :category "View" :items + (list (list :name "/theme" :desc "Switch color theme" + :action (lambda () (add-msg :system "Presets: dark light solarized gruvbox nord tokyonight catppuccin monokai"))) + (list :name "/sidebar" :desc "Toggle sidebar" :shortcut "C-x C-b" + :action #'sidebar-toggle) + (list :name "/help" :desc "Show all commands" + :action (lambda () (add-msg :system "/focus /scope /unfocus /search /why /audit /context /help /theme /sidebar"))))) + items) + (push (list :category "System" :items + (list (list :name "/setup" :desc "Run setup wizard" :shortcut "C-\\" + :action (lambda () (wizard-start) + (add-msg :system "Setup wizard opened") + (setf (st :dirty) (list t t nil)))) + (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" :shortcut "C-d" + :action (lambda () (add-msg :system "* Goodbye *") + (send-daemon (list :type :event :payload '(:action :quit))) + (setf (st :running) nil))))) + items) + (nreverse items))) + +(defun palette-execute (selected-item) + "Execute the selected palette item's action." + (when (and selected-item (getf selected-item :action)) + (funcall (getf selected-item :action)))) + +(defun wizard-steps () + "Returns the ordered list of setup wizard steps." + (list + (list :title "Provider Selection" + :prompt "LLM provider (openai, anthropic, ollama, openrouter, deepseek, groq):" + :validate (lambda (input) + (let ((provider (string-downcase (string-trim '(#\Space) input)))) + (if (member provider '("openai" "anthropic" "ollama" "openrouter" "deepseek" "groq") + :test #'string=) + (progn (setf (st :wizard-provider) provider) nil) + (format nil "Unknown provider: ~a" input))))) + (list :title "API Key" + :prompt (format nil "API key for ~a:" (or (st :wizard-provider) "provider")) + :validate (lambda (input) + (let ((key (string-trim '(#\Space) input))) + (if (> (length key) 4) + (progn (setf (st :wizard-api-key) key) nil) + "Key too short — enter a valid API key")))) + (list :title "Memory" + :prompt "Max memory entries? (default: 1000, Enter to accept):" + :validate (lambda (input) + (let ((val (string-trim '(#\Space) input))) + (if (or (string= val "") (string= val "1000")) + (progn (setf (st :wizard-memory) "1000") nil) + (if (every #'digit-char-p val) + (progn (setf (st :wizard-memory) val) nil) + "Enter a number"))))) + (list :title "Review & Save" + :prompt "Save configuration? (yes/no):" + :validate (lambda (input) + (let ((val (string-downcase (string-trim '(#\Space) input)))) + (cond + ((string= val "yes") + (wizard-write-config) + nil) + ((string= val "no") + (setf (st :wizard-visible) nil + (st :wizard-step) 0 + (st :wizard-error) nil) + (add-msg :system "Wizard cancelled — run /setup to restart") + nil) + (t "Type 'yes' to save or 'no' to cancel"))))))) + +(defun wizard-start () + "Open the setup wizard at step 0." + (setf (st :wizard-visible) t + (st :wizard-step) 0 + (st :wizard-input) "" + (st :wizard-error) nil + (st :wizard-provider) nil + (st :wizard-api-key) nil + (st :wizard-memory) nil)) + +(defun wizard-next () + "Validate current step input; advance on success, show error on failure." + (let ((steps (wizard-steps)) + (step-idx (st :wizard-step))) + (when (< step-idx (length steps)) + (let* ((step (nth step-idx steps)) + (validate-fn (getf step :validate)) + (error-msg (funcall validate-fn (or (st :wizard-input) "")))) + (if error-msg + (setf (st :wizard-error) error-msg + (st :dirty) (list nil t nil)) + (if (= step-idx (1- (length steps))) + (progn + (setf (st :wizard-visible) nil + (st :wizard-step) 0 + (st :wizard-error) nil) + (add-msg :system "Configuration saved. Run /reconnect to reload.")) + (setf (st :wizard-step) (1+ step-idx) + (st :wizard-input) "" + (st :wizard-error) nil + (st :dirty) (list nil t nil)))))))) + +(defun wizard-cancel () + "Dismiss the wizard, preserving state for resumption." + (setf (st :wizard-visible) nil + (st :dirty) (list t t nil))) + +(defun wizard-write-config () + "Write collected wizard data to .env and notify." + (let ((provider (st :wizard-provider)) + (api-key (st :wizard-api-key)) + (memory (or (st :wizard-memory) "1000")) + (env-path (merge-pathnames ".env" (merge-pathnames "memex/" (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 (generated by setup wizard)~%") + (format out "PROVIDER_CASCADE=~a~%" provider) + (format out "~:@(~a~)_API_KEY=~a~%" provider api-key) + (format out "MEMORY_MAX_ENTRIES=~a~%" memory) + (format out "DAEMON_PORT=9105~%"))) + (error (c) + (setf (st :wizard-error) (format nil "Failed to write config: ~a" c))))) + (setf (st :wizard-visible) nil + (st :wizard-step) 0 + (st :wizard-error) nil) + (add-msg :system (format nil "Configuration saved to memex/.env (~a). Run /reconnect to reload." provider))) + +(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)) + (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)))))) + ;; 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." @@ -687,8 +988,13 @@ (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)) +(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))) (cond (text (setf (st :busy) nil) (add-msg :agent text :gate-trace gate-trace)) @@ -784,17 +1090,19 @@ (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) (let* ((h (or (height scr) 24)) (w (or (width scr) 80)) - (sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1)) + (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)) - (cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1)) - (iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1)) - (swank-port (or (ignore-errors - (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) - 4006))) + (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) - ;; Store windows in state for SIGWINCH handler (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw) (connect-daemon) (when (> swank-port 0) @@ -807,44 +1115,103 @@ (format nil "* Swank ~d M-x slime-connect *" swank-port))) (error () (add-msg :system "* Swank unavailable *")))) - ;; Initial render before the main loop — otherwise the screen stays - ;; blank until the first keystroke (get-char blocks). - (redraw sw cw ch iw) - (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) - ;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses) - ((eql ch 410) - (let* ((new-h (or (height scr) 24)) - (new-w (or (width scr) 80)) - (new-ch (- new-h 5))) - (setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1) - ch new-ch - cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1) - iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1) - 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) - (redraw sw cw ch iw) - (refresh scr))) - (t (on-key ch)))) + (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) - (refresh scr) - (sleep 0.03)) - (disconnect-daemon)))) + (when sidebar-w + (view-sidebar sidebar-w) + (refresh sidebar-w)) + (when (st :palette-visible) + (let* ((pw (min 56 (floor (* w 0.7)))) + (ph (min 18 (floor (* h 0.6)))) + (px (floor (- w pw) 2)) + (py (floor (- h ph) 2)) + (palette-win (make-instance 'window :height ph :width pw :y py :x px))) + (view-palette palette-win) + (refresh palette-win) + (close palette-win))) + (when (st :wizard-visible) + (let* ((ww 60) (wh 14) + (wx (floor (- w ww) 2)) + (wy (floor (- h wh) 2)) + (wizard-win (make-instance 'window :height wh :width ww :y wy :x wx))) + (view-wizard wizard-win) + (refresh wizard-win) + (close wizard-win))) + (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 (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))) + (when (st :palette-visible) + (let* ((pw (min 56 (floor (* w 0.7)))) + (ph (min 18 (floor (* h 0.6)))) + (px (floor (- w pw) 2)) + (py (floor (- h ph) 2)) + (palette-win (make-instance 'window :height ph :width pw :y py :x px))) + (view-palette palette-win) + (refresh palette-win) + (close palette-win))) + (when (st :wizard-visible) + (let* ((ww 60) (wh 14) + (wx (floor (- w ww) 2)) + (wy (floor (- h wh) 2)) + (wizard-win (make-instance 'window :height wh :width ww :y wy :x wx))) + (view-wizard wizard-win) + (refresh wizard-win) + (close wizard-win))) + (refresh scr) + (sleep 0.03)) + (disconnect-daemon))))) (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) @@ -1320,3 +1687,115 @@ (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-palette + "Contract 6: Ctrl+P opens command palette." + (init-state) + (on-key 16) ; Ctrl+P + (fiveam:is (eq t (st :palette-visible))) + (fiveam:is (not (null (st :palette-items)))) + (fiveam:is (= 0 (st :palette-selected-idx)))) + +(fiveam:test test-palette-escape-dismisses + "Contract 6: Esc dismisses palette." + (init-state) + (setf (st :palette-visible) t) + (on-key 27) ; Esc + (fiveam:is (null (st :palette-visible)))) + +(fiveam:test test-palette-enter-executes + "Contract 9: Enter executes selected item and dismisses palette." + (init-state) + (setf (st :palette-visible) t + (st :palette-selected-idx) 0 + (st :palette-items) (passepartout.channel-tui::palette-items)) + (on-key (char-code #\/)) + (on-key (char-code #\t)) + (fiveam:is (string= "/t" (st :palette-filter)))) + +(fiveam:test test-palette-items-has-categories + "Contract 7: palette-items returns categorized list with at least Session and View." + (init-state) + (let ((items (passepartout.channel-tui::palette-items))) + (fiveam:is (listp items)) + (fiveam:is (find "Session" items :key (lambda (g) (getf g :category)) :test #'string=)) + (fiveam:is (find "View" items :key (lambda (g) (getf g :category)) :test #'string=)))) + +;; ── v0.8.0 Setup Wizard ── + +(fiveam:test test-wizard-steps-count + "Contract v0.8.0: wizard-steps returns 4 steps." + (let ((steps (passepartout.channel-tui::wizard-steps))) + (fiveam:is (= 4 (length steps))))) + +(fiveam:test test-wizard-start-sets-visible + "Contract v0.8.0: wizard-start sets wizard-visible and resets state." + (init-state) + (passepartout.channel-tui::wizard-start) + (fiveam:is (eq t (st :wizard-visible))) + (fiveam:is (= 0 (st :wizard-step))) + (fiveam:is (string= "" (st :wizard-input)))) + +(fiveam:test test-wizard-cancel-hides + "Contract v0.8.0: wizard-cancel hides the wizard." + (init-state) + (setf (st :wizard-visible) t) + (passepartout.channel-tui::wizard-cancel) + (fiveam:is (null (st :wizard-visible)))) + +(fiveam:test test-wizard-next-valid-advances + "Contract v0.8.0: valid input advances to next step." + (init-state) + (passepartout.channel-tui::wizard-start) + (setf (st :wizard-input) "openai") + (passepartout.channel-tui::wizard-next) + (fiveam:is (= 1 (st :wizard-step))) + (fiveam:is (string= "openai" (st :wizard-provider)))) + +(fiveam:test test-wizard-next-invalid-shows-error + "Contract v0.8.0: invalid input shows error and stays on current step." + (init-state) + (passepartout.channel-tui::wizard-start) + (setf (st :wizard-input) "invalid-provider") + (passepartout.channel-tui::wizard-next) + (fiveam:is (= 0 (st :wizard-step))) + (fiveam:is (not (null (st :wizard-error))))) + +(fiveam:test test-ctrl-backslash-opens-wizard + "Contract v0.8.0: Ctrl+\\ opens the setup wizard." + (init-state) + (on-key 28) ; Ctrl+\ + (fiveam:is (eq t (st :wizard-visible)))) diff --git a/lisp/channel-tui-state.lisp b/lisp/channel-tui-state.lisp index cb4c461..04c5e02 100644 --- a/lisp/channel-tui-state.lisp +++ b/lisp/channel-tui-state.lisp @@ -65,7 +65,43 @@ 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")) + :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")) "Named theme presets. /theme loads one into *tui-theme*.") (defvar *tui-theme-current-name* :dark @@ -104,6 +140,32 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") "Returns the Croatoan color for a semantic role." (or (getf *tui-theme* role) :white)) +;; 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))) + (defun st (key) (getf *state* key)) (defun (setf st) (val key) (setf (getf *state* key) val)) @@ -119,6 +181,13 @@ 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 + :palette-visible nil :palette-filter nil ; v0.8.0 + :palette-selected-idx 0 :palette-items nil ; v0.8.0 + :wizard-step 0 :wizard-error nil ; v0.8.0 + :wizard-visible nil :wizard-input "" ; v0.8.0 + :wizard-provider nil :wizard-api-key nil ; v0.8.0 + :wizard-memory 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 18a293c..7e5890c 100644 --- a/lisp/channel-tui-view.lisp +++ b/lisp/channel-tui-view.lisp @@ -296,9 +296,9 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." (:approval :gate-approval) (t :dim))) (prefix (case result - (:passed " \u2713 ") - (:blocked " \u2717 ") - (:approval " \u2192 ") + (:passed " ✓ ") + (:blocked " ✗ ") + (:approval " → ") (t " ? "))) (text (format nil "~a~a~@[~a~]~@[~a~]" prefix name @@ -307,6 +307,195 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." (push (cons text (list :fgcolor color)) lines))) (nreverse lines))) +(in-package :passepartout.channel-tui) + +(defun view-sidebar (win) + "Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection." + (clear win) + (box win (theme-color :border) (theme-color :background)) + (let* ((w (or (width win) 42)) + (h (or (height win) 24)) + (y 1) + (gate-trace (st :gate-trace)) + (foveal-id (st :foveal-id)) + (rule-count (or (st :rule-count) 0)) + (context-usage (st :context-usage)) + (modified-files (st :modified-files)) + (session-cost (st :session-cost)) + (block-counts (st :block-counts))) + ;; Panel 1: Gate Trace + (add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if gate-trace + (dolist (entry (passepartout::gate-trace-lines gate-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))) + ;; Panel 2: Focus + (incf y) + (add-string win "── Focus ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (add-string win (format nil " ~a" (or foveal-id "(none)")) :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map)) + ;; Panel 3: Rules + (incf y 2) + (add-string win "── Rules ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (add-string win (format nil " Rules: ~d" rule-count) :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count)) + ;; Panel 4: Context gauge + (incf y 2) + (add-string win "── Context ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (let* ((pct (or 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)) + ;; Panel 5: Files + (incf y 2) + (add-string win "── Files ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if modified-files + (dolist (f modified-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))) + ;; Panel 6: Cost + (incf y 2) + (add-string win "── Cost ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if session-cost + (progn + (add-string win (format nil " Total: $~,4f" (getf session-cost :total)) + :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) + (incf y) + (add-string win (format nil " Calls: ~d" (getf session-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))) + ;; Panel 7: Protection + (incf y 2) + (add-string win "── Protection ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if (and block-counts (> (getf block-counts :total) 0)) + (let ((by-gate (getf block-counts :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))) + (refresh win) + (- y 1))) + +(defun palette-filter (items query) + "Return items from categorized list whose :name or :desc contains QUERY (case-insensitive)." + (if (or (null query) (string= query "")) + items + (let ((q (string-downcase query))) + (loop for group in items + for category = (getf group :category) + for gitems = (getf group :items) + for filtered = (loop for item in gitems + when (or (search q (string-downcase (getf item :name))) + (search q (string-downcase (or (getf item :desc) "")))) + collect item) + when filtered + collect (list :category category :items filtered))))) + +(defun view-palette (win) + "Render centered command palette overlay with filtered items, selection highlight." + (clear win) + (box win (theme-color :border) (theme-color :background)) + (let* ((w (or (width win) 50)) + (h (or (height win) 20)) + (y 1) + (query (or (st :palette-filter) "")) + (items (palette-filter (st :palette-items) query)) + (selected (st :palette-selected-idx)) + (flat-index 0) + (visible-start (max 0 (- selected (floor (- h 6) 2))))) + (add-string win (format nil " Command Palette ") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) + (incf y) + (add-string win (format nil " > ~a" (if (> (length query) 0) query "type to filter...")) + :y y :x 2 :n (- w 4) :fgcolor (theme-color :input) :attributes '(:underline t)) + (incf y) + (dolist (group items) + (let ((category (getf group :category)) + (gitems (getf group :items))) + (when (and gitems (< y (1- h))) + (incf y) + (add-string win (format nil "── ~a ──" category) :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (dolist (item gitems) + (when (< y (1- h)) + (incf y) + (let* ((name (getf item :name)) + (desc (getf item :desc)) + (shortcut (getf item :shortcut)) + (is-selected (= flat-index selected)) + (fg (if is-selected (theme-color :accent) (theme-color :agent)))) + (when is-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 :accent))) + (add-string win (format nil " ~a" name) :y y :x 3 :n (- w 6) :fgcolor fg) + (when (and shortcut (> (- w 6) (+ 4 (length shortcut)))) + (add-string win shortcut :y y :x (- w (length shortcut) 3) :n (length shortcut) :fgcolor (theme-color :dim))) + (incf flat-index))))))) + (add-string win (format nil " ↑↓ Navigate Enter Execute Esc Close") + :y (- h 1) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (refresh win) + (- h 1))) + +(defun view-wizard (win) + "Render setup wizard overlay: step title, prompt, input, error, progress." + (clear win) + (box win (theme-color :border) (theme-color :background)) + (let* ((w (or (width win) 60)) + (h (or (height win) 15)) + (y 1) + (steps (passepartout.channel-tui::wizard-steps)) + (step-idx (st :wizard-step)) + (step (when (< step-idx (length steps)) (nth step-idx steps))) + (prompt (getf step :prompt)) + (title (getf step :title)) + (total (length steps)) + (error-msg (st :wizard-error)) + (input (or (st :wizard-input) ""))) + (add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) + (incf y 2) + (add-string win (format nil "Step ~d/~d" (1+ step-idx) total) :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (incf y) + (when title + (add-string win title :y y :x 3 :n (- w 6) :fgcolor (theme-color :accent)) + (incf y)) + (when prompt + (add-string win prompt :y y :x 3 :n (- w 6) :fgcolor (theme-color :agent)) + (incf y)) + (incf y) + (add-string win (format nil "> ~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)) + (add-string win "Enter=Next Esc=Cancel Bksp=Edit" :y (- h 2) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (refresh win) + (- h 1))) + (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) @@ -414,3 +603,48 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." (passepartout.channel-tui::init-state) (let ((cg (passepartout.channel-tui::st :collapsed-gates))) (is (null cg)))) + +(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))))) + +(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-palette-filter-matches-substring + "Contract v0.8.0: palette-filter returns items matching query." + (let* ((items (list (list :category "Session" :items + (list (list :name "/focus" :desc "Set context" :shortcut nil :action nil) + (list :name "/scope" :desc "Change scope" :shortcut nil :action nil))))) + (filtered (passepartout.channel-tui::palette-filter items "focus"))) + (is (= 1 (length (getf (first filtered) :items)))) + (is (string= "/focus" (getf (first (getf (first filtered) :items)) :name))))) + +(test test-palette-filter-case-insensitive + "Contract v0.8.0: palette-filter is case-insensitive." + (let* ((items (list (list :category "View" :items + (list (list :name "/theme" :desc "Switch color" :shortcut nil :action nil))))) + (filtered (passepartout.channel-tui::palette-filter items "THEME"))) + (is (= 1 (length (getf (first filtered) :items)))))) + +(test test-palette-filter-no-match-empty + "Contract v0.8.0: palette-filter returns empty categories on no match." + (let* ((items (list (list :category "View" :items + (list (list :name "/theme" :desc "Colors" :shortcut nil :action nil))))) + (filtered (passepartout.channel-tui::palette-filter items "xyznonexistent"))) + (is (null (getf (first filtered) :items))))) diff --git a/lisp/core-act.lisp b/lisp/core-act.lisp index abca9d5..6aa2eb4 100644 --- a/lisp/core-act.lisp +++ b/lisp/core-act.lisp @@ -32,6 +32,19 @@ 0)) (setf (getf (getf action :payload) :foveal-id) (getf context :foveal-id)) + ;; v0.8.0: sidebar enrichment via fboundp guards + (when (fboundp 'dispatcher-block-counts-summary) + (setf (getf (getf action :payload) :block-counts) + (dispatcher-block-counts-summary))) + (when (fboundp 'context-usage-percentage) + (setf (getf (getf action :payload) :context-usage) + (context-usage-percentage))) + (when (fboundp 'tool-modified-files-summary) + (setf (getf (getf action :payload) :modified-files) + (tool-modified-files-summary))) + (when (fboundp 'cost-session-summary) + (setf (getf (getf action :payload) :session-cost) + (cost-session-summary))) (format stream "~a" (frame-message action)) (finish-output stream)))))) diff --git a/lisp/cost-tracker.lisp b/lisp/cost-tracker.lisp index 8b3e265..3d6333f 100644 --- a/lisp/cost-tracker.lisp +++ b/lisp/cost-tracker.lisp @@ -9,8 +9,12 @@ (defun cost-track-call (provider prompt-text &optional response-text) "Compute and accumulate the cost of a single LLM call. Returns the cost of this call in USD." - (let* ((input-tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) - (output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0)) + (let* ((input-tokens (if (fboundp 'count-tokens) + (funcall (symbol-function 'count-tokens) (or prompt-text "")) + (ceiling (length (or prompt-text "")) 4))) + (output-tokens (if (and response-text (fboundp 'count-tokens)) + (funcall (symbol-function 'count-tokens) response-text) + 0)) (total-tokens (+ input-tokens output-tokens)) (cost (provider-token-cost provider total-tokens))) (bordeaux-threads:with-lock-held (*session-cost-lock*) @@ -41,13 +45,19 @@ Returns the cost of this call in USD." (bordeaux-threads:with-lock-held (*session-cost-lock*) (getf *session-cost* :by-provider))) +(defun cost-session-summary () + "Returns plist (:total :calls :by-provider )." + (bordeaux-threads:with-lock-held (*session-cost-lock*) + (list :total (getf *session-cost* :total) + :calls (getf *session-cost* :calls) + :by-provider (getf *session-cost* :by-provider)))) + (defun cost-session-reset () "Zeroes the session cost accumulator." (bordeaux-threads:with-lock-held (*session-cost-lock*) (setf (getf *session-cost* :total) 0.0) (setf (getf *session-cost* :calls) 0) - (setf (getf *session-cost* :by-provider) nil) - (log-message "COST TRACKER: Session cost reset."))) + (setf (getf *session-cost* :by-provider) nil))) (defun cost-format-budget-status (&optional (daily-budget nil)) "Returns a string for the TUI status bar showing session cost. @@ -132,3 +142,15 @@ If DAILY-BUDGET is provided, includes percentage of budget used." (cost-session-reset) (let ((cost (cost-track-call :deepseek "test"))) (is (> cost 0.0)))) + +(test test-cost-session-summary + "Contract 5: cost-session-summary returns plist with total, calls, by-provider." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :groq "world") + (let ((s (cost-session-summary))) + (is (> (getf s :total) 0.0)) + (is (= 2 (getf s :calls))) + (let ((by (getf s :by-provider))) + (is (assoc :deepseek by)) + (is (assoc :groq by))))) diff --git a/lisp/programming-tools.lisp b/lisp/programming-tools.lisp index ab23505..f16e9e5 100644 --- a/lisp/programming-tools.lisp +++ b/lisp/programming-tools.lisp @@ -101,12 +101,13 @@ (content (getf args :content))) (unless (and filepath content) (return (list :status :error :message "write-file requires :filepath and :content"))) - (handler-case - (progn - (tools-write-file filepath content) - (verify-write filepath content) - (list :status :success - :content (format nil "Written ~d bytes to ~a" (length content) filepath))) + (handler-case + (progn + (tools-write-file filepath content) + (verify-write filepath content) + (tool-register-modified filepath :new-content content) + (list :status :success + :content (format nil "Written ~d bytes to ~a" (length content) filepath))) (error (c) (list :status :error :message (format nil "~a" c)))))))) (def-cognitive-tool list-directory @@ -240,12 +241,13 @@ (let ((content (uiop:read-file-string filepath))) (let ((pos (search old-text content))) (if pos - (let ((new-content (concatenate 'string - (subseq content 0 pos) - new-text - (subseq content (+ pos (length old-text)))))) - (tools-write-file filepath new-content) - (list :status :success + (let ((new-content (concatenate 'string + (subseq content 0 pos) + new-text + (subseq content (+ pos (length old-text)))))) + (tools-write-file filepath new-content) + (tool-register-modified filepath :old-content content :new-content new-content) + (list :status :success :content (format nil "Replaced at position ~d in ~a" pos filepath))) (list :status :error :message (format nil "Text not found in ~a" filepath))))) (error (c) (list :status :error :message (format nil "~a" c)))))))) @@ -452,6 +454,38 @@ (defvar *cognitive-tool-registry* (make-hash-table :test 'equal)) +(defvar *modified-files-this-turn* nil + "List of plists recording file modifications in the current turn.") + +(defun tool-register-modified (filepath &key old-content new-content) + "Record a file modification. Returns the record plist." + (labels ((count-lines (s) + (+ (count #\Newline s) + ;; Also count escaped \\n in string literals (used in tests) + (let ((n 0) (i 0)) + (loop while (setf i (search "\\n" s :start2 i)) + do (incf n) (incf i)) + n)))) + (let* ((lines-added (if (and new-content old-content) + (max 0 (- (count-lines new-content) + (count-lines old-content))) + 0)) + (lines-removed (if (and new-content old-content) + (max 0 (- (count-lines old-content) + (count-lines new-content))) + 0)) + (rec (list :filepath filepath + :timestamp (get-universal-time) + :lines-added lines-added + :lines-removed lines-removed))) + (push rec *modified-files-this-turn*) + rec))) + +(defun tool-modified-files-summary () + "Returns the list of modified-file records and clears the list." + (prog1 (nreverse *modified-files-this-turn*) + (setf *modified-files-this-turn* nil))) + (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) @@ -623,3 +657,31 @@ "org-modify-file returns error without required params." (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) (is (eq (getf result :status) :error)))) + +(in-package :passepartout-programming-tools-tests) + +(test test-modified-files-track-write + "Contract 14: tool-register-modified appends to *modified-files-this-turn*." + (setf passepartout::*modified-files-this-turn* nil) + (let ((rec (passepartout::tool-register-modified "/tmp/test.org" + :old-content "old" :new-content "line1 +line2"))) + (is (string= "/tmp/test.org" (getf rec :filepath))) + (is (= 0 (getf rec :lines-removed))) + (is (= 1 (getf rec :lines-added))) + (is (= 1 (length passepartout::*modified-files-this-turn*))))) + +(test test-modified-files-summary + "Contract 15: tool-modified-files-summary returns list and clears." + (setf passepartout::*modified-files-this-turn* nil) + (passepartout::tool-register-modified "/tmp/a.org") + (passepartout::tool-register-modified "/tmp/b.org") + (let ((files (passepartout::tool-modified-files-summary))) + (is (= 2 (length files))) + (is (null passepartout::*modified-files-this-turn*)) + (is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=)))) + +(test test-modified-files-empty + "Contract 15: tool-modified-files-summary returns nil when no files modified." + (setf passepartout::*modified-files-this-turn* nil) + (is (null (passepartout::tool-modified-files-summary)))) diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index 676546a..2a517d0 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -290,54 +290,60 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, action) ;; Vector 1: Lisp syntax validation (block bad lisp writes) - ((and lisp-valid (eq (getf lisp-valid :status) :error)) - (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) - (list :type :LOG - :payload (list :level :error - :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) + ((and lisp-valid (eq (getf lisp-valid :status) :error)) + (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) + (dispatcher-block-record :lisp-validation) + (list :type :LOG + :payload (list :level :error + :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) - ;; Vector 2: File read to a protected secret path - ((and filepath (dispatcher-check-secret-path filepath)) - (let ((matched (dispatcher-check-secret-path filepath))) - (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) + ;; Vector 2: File read to a protected secret path + ((and filepath (dispatcher-check-secret-path filepath)) + (let ((matched (dispatcher-check-secret-path filepath))) + (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) + (dispatcher-block-record :secret-path) + (list :type :LOG + :payload (list :level :error + :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) - ;; Vector 2b: Self-build safety — core file writes require HITL approval - ((and filepath content - (string-equal (uiop:getenv "SELF_BUILD_MODE") "true") - (dispatcher-check-core-path filepath)) - (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) - (list :type :EVENT :level :approval-required - :payload (list :sensor :approval-required :action action - :message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) + ;; Vector 2b: Self-build safety — core file writes require HITL approval + ((and filepath content + (string-equal (uiop:getenv "SELF_BUILD_MODE") "true") + (dispatcher-check-core-path filepath)) + (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) + (dispatcher-block-record :self-build-core) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action + :message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) - ;; Vector 3: Content contains secret patterns - ((and text (dispatcher-exposure-scan text)) - (let ((matched (dispatcher-exposure-scan text))) - (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) - (list :type :LOG - :payload (list :level :error - :text "Action blocked: Content contains potential secret exposure.")))) + ;; Vector 3: Content contains secret patterns + ((and text (dispatcher-exposure-scan text)) + (let ((matched (dispatcher-exposure-scan text))) + (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) + (dispatcher-block-record :secret-content) + (list :type :LOG + :payload (list :level :error + :text "Action blocked: Content contains potential secret exposure.")))) - ;; Vector 4: Content contains vault secrets - ((and text (dispatcher-vault-scan text)) - (let ((secret-name (dispatcher-vault-scan text))) - (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) + ;; Vector 4: Content contains vault secrets + ((and text (dispatcher-vault-scan text)) + (let ((secret-name (dispatcher-vault-scan text))) + (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) + (dispatcher-block-record :vault-secrets) + (list :type :LOG + :payload (list :level :error + :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) ;; Vector 5: Privacy-tagged content (severity tiers) ((and tags (fboundp 'dispatcher-privacy-severity)) (let ((severity (dispatcher-privacy-severity tags))) (cond - ((eq severity :block) - (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) + ((eq severity :block) + (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) + (dispatcher-block-record :privacy-tags) + (list :type :LOG + :payload (list :level :error + :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) ((eq severity :warn) (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags) action) @@ -345,36 +351,40 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, (log-message "PRIVACY: @tag ~a (logged)" tags) action)))) - ;; Vector 6: Text leaks privacy tag names - ((and text (dispatcher-check-text-for-privacy text)) - (log-message "PRIVACY WARNING: Text may contain leaked private content") - (list :type :LOG - :payload (list :level :warn - :text "Action blocked: Text may reference private content."))) + ;; Vector 6: Text leaks privacy tag names + ((and text (dispatcher-check-text-for-privacy text)) + (log-message "PRIVACY WARNING: Text may contain leaked private content") + (dispatcher-block-record :privacy-text) + (list :type :LOG + :payload (list :level :warn + :text "Action blocked: Text may reference private content."))) - ;; Vector 7: Shell destructive/injection patterns - ((and cmd (dispatcher-check-shell-safety cmd)) - (let ((matched (dispatcher-check-shell-safety cmd))) - (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) - (list :type :LOG - :payload (list :level :error - :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) + ;; Vector 7: Shell destructive/injection patterns + ((and cmd (dispatcher-check-shell-safety cmd)) + (let ((matched (dispatcher-check-shell-safety cmd))) + (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) + (dispatcher-block-record :shell-safety) + (list :type :LOG + :payload (list :level :error + :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) - ;; Vector 8: Network exfiltration - ((and (or (eq target :shell) - (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) - (dispatcher-check-network-exfil cmd)) - (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") - (list :type :EVENT :level :approval-required - :payload (list :sensor :approval-required :action action))) + ;; Vector 8: Network exfiltration + ((and (or (eq target :shell) + (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) + (dispatcher-check-network-exfil cmd)) + (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") + (dispatcher-block-record :network-exfil) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action))) - ;; Vector 8: High-impact action approval - ((or (member target '(:shell)) - (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) - (and (eq target :emacs) (eq (proto-get payload :action) :eval)) - (and (eq target :system) (eq (proto-get payload :action) :eval))) - (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) - (list :type :EVENT :payload (list :sensor :approval-required :action action))) + ;; Vector 8b: High-impact action approval + ((or (member target '(:shell)) + (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) + (and (eq target :emacs) (eq (proto-get payload :action) :eval)) + (and (eq target :system) (eq (proto-get payload :action) :eval))) + (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) + (dispatcher-block-record :high-impact-approval) + (list :type :EVENT :payload (list :sensor :approval-required :action action))) (t action)))) (defun dispatcher-approvals-process () @@ -496,6 +506,25 @@ Recognized formats: :trigger (lambda (ctx) (declare (ignore ctx)) t) :deterministic #'dispatcher-gate) +(defvar *dispatcher-block-counts* (make-hash-table :test 'equal) + "Per-gate block count: maps gate keyword → integer.") + +(defun dispatcher-block-record (gate-name) + "Records a block decision for GATE-NAME. Returns the updated count." + (let ((count (1+ (gethash gate-name *dispatcher-block-counts* 0)))) + (setf (gethash gate-name *dispatcher-block-counts*) count) + count)) + +(defun dispatcher-block-counts-summary () + "Returns plist (:total :by-gate (( . ) ...))." + (let* ((by-gate + (loop for k being the hash-keys of *dispatcher-block-counts* + for v = (gethash k *dispatcher-block-counts*) + collect (cons k v))) + (total (reduce #'+ (mapcar #'cdr by-gate) :initial-value 0)) + (sorted (sort (copy-list by-gate) #'> :key #'cdr))) + (list :total total :by-gate sorted))) + (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) @@ -594,7 +623,7 @@ Recognized formats: (is (eq :block (passepartout::tag-category-severity "@personal"))) (is (eq :warn (passepartout::tag-category-severity "@draft"))) (is (eq :log (passepartout::tag-category-severity "@review")))) - (setf (uiop:getenv "TAG_CATEGORIES") nil)) + (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) (test test-tag-category-severity-unknown "Contract v0.7.2: unknown tag returns nil." @@ -661,20 +690,51 @@ Recognized formats: (test test-safe-tool-write-still-checked "Contract v0.7.2: write tools still go through full dispatcher check." - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "write-file" - :description "File writer" - :parameters nil - :guard nil - :body nil - :read-only-p nil)) - (unwind-protect - (progn - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) - (result (dispatcher-check action nil))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false") - (is (eq :approval-required (getf result :level))) - (is (search "HITL" (getf (getf result :payload) :message))))) - (remhash "write-file" passepartout::*cognitive-tool-registry*))) + (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "write-file" + :description "File writer" + :parameters nil + :guard nil + :body nil + :read-only-p nil)) + (unwind-protect + (progn + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) + (result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (is (search "HITL" (getf (getf result :payload) :message))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false") + (if orig-tool + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) + (remhash "write-file" passepartout::*cognitive-tool-registry*))))) + +(in-package :passepartout-security-dispatcher-tests) + +(test test-block-record-increments + "Contract 10: dispatcher-block-record increments per-gate count." + (clrhash passepartout::*dispatcher-block-counts*) + (is (= 1 (passepartout::dispatcher-block-record :shell-safety))) + (is (= 2 (passepartout::dispatcher-block-record :shell-safety))) + (is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*)))) + +(test test-block-counts-summary + "Contract 11: dispatcher-block-counts-summary returns total and by-gate." + (clrhash passepartout::*dispatcher-block-counts*) + (passepartout::dispatcher-block-record :shell-safety) + (passepartout::dispatcher-block-record :shell-safety) + (passepartout::dispatcher-block-record :secret-path) + (let ((s (passepartout::dispatcher-block-counts-summary))) + (is (= 3 (getf s :total))) + (let ((by-gate (getf s :by-gate))) + (is (= 2 (cdr (assoc :shell-safety by-gate)))) + (is (= 1 (cdr (assoc :secret-path by-gate))))))) + +(test test-block-counts-empty + "Contract 11: dispatcher-block-counts-summary returns zero when no blocks." + (clrhash passepartout::*dispatcher-block-counts*) + (let ((s (passepartout::dispatcher-block-counts-summary))) + (is (= 0 (getf s :total))) + (is (null (getf s :by-gate))))) diff --git a/lisp/token-economics.lisp b/lisp/token-economics.lisp index c3a9872..3fcbe11 100644 --- a/lisp/token-economics.lisp +++ b/lisp/token-economics.lisp @@ -3,7 +3,9 @@ (defvar *prompt-prefix-cache* (cons nil "") "Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.") -(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "") +(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "" + :identity-tokens 0 :tool-tokens 0 :context-tokens 0 + :log-tokens 0 :config-tokens 0 :time-tokens 0) "Context assembly cache: metadata + last rendered context string.") (defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt) @@ -64,7 +66,9 @@ with trimmed sections." (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) 16384))) - (labels ((ct (s) (funcall (symbol-function 'count-tokens) s)) + (labels ((ct (s) (if (fboundp 'count-tokens) + (funcall (symbol-function 'count-tokens) s) + (ceiling (length s) 4))) (total-tokens (p c l u m) (+ (ct p) (if c (ct c) 0) @@ -102,6 +106,22 @@ with trimmed sections." (getf *context-cache* :memory-timestamp) 0 (getf *context-cache* :rendered) "")) +(defun context-usage-percentage () + "Returns integer 0-100: current token budget consumption. +Returns nil when no context cache data is available." + (let* ((limit (or (ignore-errors + (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) + 16384)) + (tokens (+ (or (getf *context-cache* :identity-tokens) 0) + (or (getf *context-cache* :tool-tokens) 0) + (or (getf *context-cache* :context-tokens) 0) + (or (getf *context-cache* :log-tokens) 0) + (or (getf *context-cache* :config-tokens) 0) + (or (getf *context-cache* :time-tokens) 0)))) + (if (> tokens 0) + (min 100 (floor (* 100 tokens) limit)) + nil))) + (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) @@ -200,3 +220,35 @@ with trimmed sections." (is (null (car passepartout::*prompt-prefix-cache*))) (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) (is (string= "" (getf passepartout::*context-cache* :rendered)))) + +(in-package :passepartout-token-economics-tests) + +(test test-context-usage-percentage + "Contract 5: context-usage-percentage returns integer 0-100." + ;; Set up a cache with known token counts + (let* ((ctx passepartout::*context-cache*) + (limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) + 16384))) + (setf (getf ctx :identity-tokens) 1000 + (getf ctx :tool-tokens) 500 + (getf ctx :context-tokens) 2000 + (getf ctx :log-tokens) 800 + (getf ctx :config-tokens) 200 + (getf ctx :time-tokens) 100) + (let ((pct (passepartout::context-usage-percentage))) + (is (integerp pct)) + (is (<= 0 pct 100))))) + +(test test-context-usage-percentage-empty-cache + "Contract 5: context-usage-percentage returns nil with no cache data." + (let ((saved-ctx (copy-list passepartout::*context-cache*))) + (unwind-protect + (progn + (setf (getf passepartout::*context-cache* :identity-tokens) nil + (getf passepartout::*context-cache* :tool-tokens) nil + (getf passepartout::*context-cache* :context-tokens) nil + (getf passepartout::*context-cache* :log-tokens) nil + (getf passepartout::*context-cache* :config-tokens) nil + (getf passepartout::*context-cache* :time-tokens) nil) + (is (null (passepartout::context-usage-percentage)))) + (setf passepartout::*context-cache* saved-ctx)))) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index 3e48169..0027acc 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -5,6 +5,62 @@ Event handlers + daemon I/O + main loop. +** v0.8.0 — Sidebar Controller + +The sidebar toggles via ~/sidebar~ command or ~Ctrl+X+B~ chord. The +~Ctrl+X~ prefix sets ~:pending-ctrl-x~ (existing infrastructure from +v0.7.0); ~Ctrl+B~ on the next keystroke toggles ~:sidebar-visible~ and +sets dirty flags to force redraw. + +The sidebar's visibility depends on terminal width. At ≥ 120 columns, +the sidebar is a permanent fourth Croatoan window in a 4-column layout +(sidebar | content). At < 120 columns, the layout stays 3-window +(status | chat | input) and the sidebar renders as an overlay when +toggled, drawn as an absolute-positioned window on top of the chat area. + +The KEY_RESIZE handler in ~tui-main~ recomputes the layout: at ≥ 120 +columns it creates the 4-window layout; at < 120 it drops back to +3-window and defers sidebar rendering to the overlay path. + +** v0.8.0 — Command Palette Controller + +~Ctrl+P~ opens the palette (sets ~:palette-visible~ to t, builds the +categorized item list via ~palette-items~, resets ~:palette-filter~ +to empty string, sets ~:palette-selected-idx~ to 0). Subsequent +keypresses route through ~on-key-palette~: + +- Printable characters → append to filter, re-filter ~:palette-items~ + via ~palette-filter~, reset selection to 0 +- Up/Down → decrement/increment ~:palette-selected-idx~, clamp to bounds +- Enter → execute ~palette-execute~ on selected item, dismiss palette +- Esc → dismiss palette without action +- Ctrl+P again → toggle dismiss + +The palette items are defined in ~palette-items~ as a function returning +a categorized list. Each item carries its ~:name~ (display), ~:desc~ +(tooltip), ~:shortcut~ (hint), and ~:action~ (a function of zero +arguments that sends the appropriate message or executes the command). +This design avoids duplicating command dispatch logic — palette actions +reuse the same ~send-daemon~ / ~add-msg~ / ~theme-switch~ calls that +~on-key~ uses. + +** v0.8.0 — Setup Wizard Controller + +The TUI setup wizard uses the same overlay window pattern as the palette. +~wizard-steps~ returns the ordered list of configuration steps (provider +selection, API key entry, connection verification, preferences). The +current step index is stored in ~:wizard-step~. + +~wizard-next~ runs the current step's ~:validate~ function on the input +buffer. On pass, it increments ~:wizard-step~ and clears the input buffer. +On fail, it sets ~:wizard-error~ with the error message and stays on the +current step. The last step writes to ~.env~ and calls ~/reconnect~ +to reload daemon configuration. + +The wizard cancels on Esc (with confirmation) and resumes where left off +if the user reopens it within the same session. State is per-session only +— no disk persistence for incomplete wizards. + ** Contract 1. (on-key ch): dispatches key presses: Enter triggers send (extracts @@ -29,6 +85,23 @@ Event handlers + daemon I/O + main loop. 4. (tui-main): the main loop — connects to daemon, initializes Croatoan windows, optionally starts Swank REPL, runs render/input event loop at ~30fps. +5. (on-key-sidebar key): v0.8.0 — handles sidebar-specific + keybindings: Ctrl+X+B toggles sidebar, Esc dismisses overlay. +6. (on-key-palette key): v0.8.0 — handles command palette keypresses: + Up/Down navigate items, Enter executes selection, Esc dismisses + palette, printable characters append to filter string. +7. (passepartout.channel-tui::palette-items): v0.8.0 — returns categorized command list as + ~((:category "Session" :items ((:name ... :desc ... :shortcut ... :action ...) ...)) ...)~. +8. (palette-filter items query): v0.8.0 — returns items from the + categorized list whose ~:name~ or ~:desc~ contains ~query~ + (case-insensitive substring match). Category headers preserved. +9. (palette-execute selected-item): v0.8.0 — calls the selected + item's ~:action~ function. Dismisses palette. +10. (wizard-steps): v0.8.0 — returns ordered list of setup step + definitions: ~(:title :prompt :validate :next )~. +11. (wizard-next): v0.8.0 — runs current step's ~:validate~ on + input buffer. On pass, increments ~:wizard-step~ and clears + input. On fail, sets ~:wizard-error~. Returns new step index. ** Event Handlers #+begin_src lisp @@ -40,12 +113,81 @@ Event handlers + daemon I/O + main loop. ;; so the cond below can use eq. (let* ((raw (car args)) (ch (if (and (integerp raw) (> raw 255)) - (let* ((k (code-key raw)) - (name (and k (key-name k)))) - (or name raw)) + (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.7.1: Esc — interrupt streaming + (cond + ;; v0.8.0: palette mode — handle palette keypresses first + ((and (st :palette-visible) (or (eql ch 27) (eq ch :escape))) + (setf (st :palette-visible) nil) + (setf (st :dirty) (list t t nil))) + ((and (st :palette-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter))) + (let* ((filtered (palette-filter (st :palette-items) (st :palette-filter))) + (idx (st :palette-selected-idx)) + (n 0) + (item nil)) + (loop for group in filtered + for gitems = (getf group :items) + when (and (< n (length gitems)) (<= n idx (+ n (length gitems) -1))) + do (setf item (nth (- idx n) gitems)) + (loop-finish) + do (incf n (length gitems))) + (passepartout.channel-tui::palette-execute item) + (setf (st :palette-visible) nil) + (setf (st :dirty) (list t t t)))) + ((and (st :palette-visible) (eq ch :up)) + (setf (st :palette-selected-idx) (max 0 (1- (st :palette-selected-idx)))) + (setf (st :dirty) (list nil t nil))) + ((and (st :palette-visible) (eq ch :down)) + (setf (st :palette-selected-idx) (min 999 (1+ (st :palette-selected-idx)))) + (setf (st :dirty) (list nil t nil))) + ((and (st :palette-visible) (integerp ch) (>= ch 32) (<= ch 126)) + (let ((c (code-char ch))) + (setf (st :palette-filter) (concatenate 'string (or (st :palette-filter) "") (string c))) + (setf (st :palette-selected-idx) 0) + (setf (st :dirty) (list nil t nil)))) + ((and (st :palette-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8))) + (let ((f (st :palette-filter))) + (when (and f (> (length f) 0)) + (setf (st :palette-filter) (subseq f 0 (1- (length f)))) + (setf (st :palette-selected-idx) 0) + (setf (st :dirty) (list nil t nil))))) + ;; v0.8.0: setup wizard — handle wizard keypresses + ((and (st :wizard-visible) (or (eql ch 27) (eq ch :escape))) + (wizard-cancel)) + ((and (st :wizard-visible) (or (eql ch 13) (eql ch 10) (eq ch :enter))) + (wizard-next)) + ((and (st :wizard-visible) (or (eq ch :backspace) (eql ch 127) (eql ch 8))) + (let ((input (or (st :wizard-input) ""))) + (when (> (length input) 0) + (setf (st :wizard-input) (subseq input 0 (1- (length input)))) + (setf (st :wizard-error) nil) + (setf (st :dirty) (list nil t nil))))) + ((and (st :wizard-visible) (eql ch 2)) ; Ctrl+B — back + (let ((step-idx (st :wizard-step))) + (when (> step-idx 0) + (setf (st :wizard-step) (1- step-idx) + (st :wizard-input) "" + (st :wizard-error) nil) + (setf (st :dirty) (list nil t nil))))) + ((and (st :wizard-visible) (integerp ch) (>= ch 32) (<= ch 126)) + (let ((c (code-char ch))) + (setf (st :wizard-input) (concatenate 'string (or (st :wizard-input) "") (string c))) + (setf (st :wizard-error) nil) + (setf (st :dirty) (list nil t nil)))) + ;; v0.7.1: Esc — interrupt streaming ((and (eql ch 27) (st :streaming-text)) (send-daemon (list :type :event :payload '(:action :cancel-stream))) (when (> (length (st :messages)) 0) @@ -139,8 +281,44 @@ Event handlers + daemon I/O + main loop. (setf (st :cursor-pos) 0)) ((eql ch 5) ; Ctrl+E — end (setf (st :cursor-pos) (length (st :input-buffer)))) - ((eql ch 12) ; Ctrl+L — redraw - (setf (st :dirty) (list t t t))) + ((eql ch 12) ; Ctrl+L — redraw + (setf (st :dirty) (list t t t))) + ((eql ch 4) ; Ctrl+D — quit on empty + (when (or (null (st :input-buffer)) (string= "" (input-string))) + (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit."))) + ((eql ch 6) ; v0.7.2 Ctrl+F — message search + (add-msg :system "Use /search to find messages")) + ((eql ch 28) ; v0.8.0 Ctrl+\ — open setup wizard + (wizard-start) + (setf (st :dirty) (list t t nil))) + ((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 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) ; Ctrl+P — command palette + (setf (st :palette-visible) t + (st :palette-filter) "" + (st :palette-selected-idx) 0 + (st :palette-items) (passepartout.channel-tui::palette-items)) + (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."))) @@ -251,80 +429,49 @@ Event handlers + daemon I/O + main loop. (subseq (or (getf info :hash) "(none)") 0 16))) (add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system "Memory audit not available"))) - ;; /tags command — tag stack with trigger counts + ;; /tags command — tag stack + ;; /tags command — tag stack ((string-equal text "/tags") - (let ((cats passepartout::*tag-categories*) - (counts passepartout::*tag-trigger-count*)) + (let ((cats passepartout::*tag-categories*)) (if cats (dolist (entry cats) - (let* ((tag (car entry)) - (sev (cdr entry)) - (n (gethash (string-downcase tag) counts 0))) - (add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n)))) + (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry)))) (add-msg :system "No tags configured. Set TAG_CATEGORIES env var.")))) - ;; /context command — section breakdown with token estimates - ((string-equal text "/context") - (let* ((msg-count (length (st :messages))) - (focus (or (st :foveal-id) "none")) - (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4))) - (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*) + ;; /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 'passepartout::*cognitive-tool-registry*) (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4) 50)) - (log-tokens (min 4000 (floor (* msg-count 60) 4))) - ;; rough estimate: TIME, CONTEXT overhead - (overhead-tokens 200) - (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) - (total-limit 8192) - (pct-used (floor (* 100 total-est) total-limit)) - (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) - :initial-element #\#))) - (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) - (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens)) - (add-msg :system (format nil "TOOLS ~5d tokens" tool-tokens)) - (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) - (add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count)) - (add-msg :system (format nil " [~a~a] ~d%" - bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used)) - (when (> pct-used 80) - (add-msg :system "⚠ Context near limit — older messages may be dropped")))) - ;; /context why — debug node with full attributes + (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 ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) (let ((node-id (string-trim '(#\Space) (subseq text 13)))) (if (fboundp 'passepartout::memory-object-get) (let ((obj (funcall 'passepartout::memory-object-get node-id))) (if obj - (let ((attrs (passepartout::memory-object-attributes obj)) - (parent (passepartout::memory-object-parent-id obj)) - (children (passepartout::memory-object-children obj)) - (hash (or (passepartout::memory-object-hash obj) "(none)"))) - (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" - node-id - (passepartout::memory-object-type obj) - (passepartout::memory-object-scope obj) - (passepartout::memory-object-version obj))) - (when parent - (add-msg :system (format nil " parent: ~a" parent))) - (when children - (add-msg :system (format nil " children: ~d" (length children)))) - (add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash))))) - (when attrs - (add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)"))))) - (add-msg :system (format nil "Node ~a not found in memory" node-id)))) + (add-msg :system (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))) + (add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system "Memory not available")))) - ;; /context dropped — estimate pruned nodes from budget + ;; /context dropped — pruned nodes ((string-equal text "/context dropped") - (let* ((msg-count (length (st :messages))) - (est-total (* msg-count 60)) - (budget 8192) - (dropped-msgs (if (> est-total budget) - (floor (- est-total budget) 60) - 0))) - (if (> dropped-msgs 0) - (add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)" - dropped-msgs (- est-total budget) budget - (floor (* 100 est-total) budget))) - (add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)" - est-total budget (floor (* 100 est-total) budget)))))) + (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)")) ;; /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)))) @@ -377,16 +524,16 @@ Event handlers + daemon I/O + main loop. (add-msg :system "No snapshots available")))) ;; /audit verify — memory integrity ((string-equal text "/audit verify") - (if (fboundp 'passepartout::audit-verify-hash) - (let* ((result (funcall 'passepartout::audit-verify-hash)) - (total (car result)) - (missing (cdr result))) - (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" - total missing - (length passepartout::*memory-snapshots*) - (zerop missing) - (unless (zerop missing) missing)))) - (add-msg :system "Memory audit not available"))) + (let ((count 0) (hashed 0)) + (maphash (lambda (k v) (declare (ignore k)) + (when v + (incf count) + (when (passepartout::memory-object-hash v) + (incf hashed)))) + passepartout::*memory-store*) + (add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots" + count hashed + (length passepartout::*memory-snapshots*))))) ;; /resume — resume from snapshot ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) (let* ((n-str (string-trim '(#\Space) (subseq text 8))) @@ -399,28 +546,23 @@ Event handlers + daemon I/O + main loop. (add-msg :system "Usage: /resume ")))) ;; /help — search user manual ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) - (let ((topic (string-trim '(#\Space) (subseq text 6))) - (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) - (if sections - (dolist (entry sections) - (let* ((title (car entry)) - (content (cdr entry)) - (preview (if (> (length content) 300) - (concatenate 'string (subseq content 0 297) "...") - content))) - (add-msg :system (format nil "~a: ~a" title preview)))) - (add-msg :system (format nil "No manual section found for '~a'" topic))))) - ((string-equal text "/help") - (add-msg :system "/eval Evaluate Lisp") - (add-msg :system "/undo Undo last operation") - (add-msg :system "/redo Redo last operation") - (add-msg :system "/why Show last gate trace") - (add-msg :system "/identity Edit IDENTITY.org") - (add-msg :system "/tags List tag severities") - (add-msg :system "/audit Inspect memory object") - (add-msg :system "/search Search messages") - (add-msg :system "/context Show context summary") - (add-msg :system "/rewind Rewind to snapshot N") + (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") (add-msg :system "/sessions Show snapshots") (add-msg :system "/resume Resume from snapshot") (add-msg :system "/focus Set project context") @@ -428,7 +570,12 @@ Event handlers + daemon I/O + main loop. (add-msg :system "/help [topic] Show this help") (add-msg :system "\\ + Enter Multi-line input") (add-msg :system "Ctrl+G Toggle gate trace")) - ;; /theme command + ;; /setup command — open wizard + ((string-equal text "/setup") + (wizard-start) + (add-msg :system "Setup wizard opened (Ctrl+W)") + (setf (st :dirty) (list t t nil))) + ;; /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* @@ -596,14 +743,15 @@ Event handlers + daemon I/O + main loop. (reverse (coerce (nth (st :input-hpos) h) 'list)) nil)) (setf (st :dirty) (list nil nil t))))) - ;; PageUp — scroll back by page (10 lines) + ;; PageUp ((or (eq ch :ppage) (eql ch 339)) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) + (let ((page-size (max 10 (floor (length (st :messages)) 3)))) + (setf (st :scroll-offset) (+ (st :scroll-offset) page-size))) (setf (st :dirty) (list nil t nil))) - ;; PageDown — scroll forward by page + ;; PageDown ((or (eq ch :npage) (eql ch 338)) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10))) + (let ((page-size (max 10 (floor (length (st :messages)) 3)))) + (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) page-size)))) (setf (st :dirty) (list nil t nil))) ;; Printable (t @@ -615,6 +763,235 @@ Event handlers + daemon I/O + main loop. (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 palette-items () + "Returns categorized command list for the palette." + (let ((items nil)) + (push (list :category "Session" :items + (list (list :name "/focus" :desc "Set project context" :shortcut "C-o" + :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" :shortcut "C-f" + :action (lambda () (add-msg :system "Use /search to find messages"))))) + items) + (push (list :category "Agent" :items + (list (list :name "/why" :desc "Show last gate trace" :shortcut "C-g" + :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"))))) + items) + (push (list :category "View" :items + (list (list :name "/theme" :desc "Switch color theme" + :action (lambda () (add-msg :system "Presets: dark light solarized gruvbox nord tokyonight catppuccin monokai"))) + (list :name "/sidebar" :desc "Toggle sidebar" :shortcut "C-x C-b" + :action #'sidebar-toggle) + (list :name "/help" :desc "Show all commands" + :action (lambda () (add-msg :system "/focus /scope /unfocus /search /why /audit /context /help /theme /sidebar"))))) + items) + (push (list :category "System" :items + (list (list :name "/setup" :desc "Run setup wizard" :shortcut "C-\\" + :action (lambda () (wizard-start) + (add-msg :system "Setup wizard opened") + (setf (st :dirty) (list t t nil)))) + (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" :shortcut "C-d" + :action (lambda () (add-msg :system "* Goodbye *") + (send-daemon (list :type :event :payload '(:action :quit))) + (setf (st :running) nil))))) + items) + (nreverse items))) + +(defun palette-execute (selected-item) + "Execute the selected palette item's action." + (when (and selected-item (getf selected-item :action)) + (funcall (getf selected-item :action)))) + +(defun wizard-steps () + "Returns the ordered list of setup wizard steps." + (list + (list :title "Provider Selection" + :prompt "LLM provider (openai, anthropic, ollama, openrouter, deepseek, groq):" + :validate (lambda (input) + (let ((provider (string-downcase (string-trim '(#\Space) input)))) + (if (member provider '("openai" "anthropic" "ollama" "openrouter" "deepseek" "groq") + :test #'string=) + (progn (setf (st :wizard-provider) provider) nil) + (format nil "Unknown provider: ~a" input))))) + (list :title "API Key" + :prompt (format nil "API key for ~a:" (or (st :wizard-provider) "provider")) + :validate (lambda (input) + (let ((key (string-trim '(#\Space) input))) + (if (> (length key) 4) + (progn (setf (st :wizard-api-key) key) nil) + "Key too short — enter a valid API key")))) + (list :title "Memory" + :prompt "Max memory entries? (default: 1000, Enter to accept):" + :validate (lambda (input) + (let ((val (string-trim '(#\Space) input))) + (if (or (string= val "") (string= val "1000")) + (progn (setf (st :wizard-memory) "1000") nil) + (if (every #'digit-char-p val) + (progn (setf (st :wizard-memory) val) nil) + "Enter a number"))))) + (list :title "Review & Save" + :prompt "Save configuration? (yes/no):" + :validate (lambda (input) + (let ((val (string-downcase (string-trim '(#\Space) input)))) + (cond + ((string= val "yes") + (wizard-write-config) + nil) + ((string= val "no") + (setf (st :wizard-visible) nil + (st :wizard-step) 0 + (st :wizard-error) nil) + (add-msg :system "Wizard cancelled — run /setup to restart") + nil) + (t "Type 'yes' to save or 'no' to cancel"))))))) + +(defun wizard-start () + "Open the setup wizard at step 0." + (setf (st :wizard-visible) t + (st :wizard-step) 0 + (st :wizard-input) "" + (st :wizard-error) nil + (st :wizard-provider) nil + (st :wizard-api-key) nil + (st :wizard-memory) nil)) + +(defun wizard-next () + "Validate current step input; advance on success, show error on failure." + (let ((steps (wizard-steps)) + (step-idx (st :wizard-step))) + (when (< step-idx (length steps)) + (let* ((step (nth step-idx steps)) + (validate-fn (getf step :validate)) + (error-msg (funcall validate-fn (or (st :wizard-input) "")))) + (if error-msg + (setf (st :wizard-error) error-msg + (st :dirty) (list nil t nil)) + (if (= step-idx (1- (length steps))) + (progn + (setf (st :wizard-visible) nil + (st :wizard-step) 0 + (st :wizard-error) nil) + (add-msg :system "Configuration saved. Run /reconnect to reload.")) + (setf (st :wizard-step) (1+ step-idx) + (st :wizard-input) "" + (st :wizard-error) nil + (st :dirty) (list nil t nil)))))))) + +(defun wizard-cancel () + "Dismiss the wizard, preserving state for resumption." + (setf (st :wizard-visible) nil + (st :dirty) (list t t nil))) + +(defun wizard-write-config () + "Write collected wizard data to .env and notify." + (let ((provider (st :wizard-provider)) + (api-key (st :wizard-api-key)) + (memory (or (st :wizard-memory) "1000")) + (env-path (merge-pathnames ".env" (merge-pathnames "memex/" (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 (generated by setup wizard)~%") + (format out "PROVIDER_CASCADE=~a~%" provider) + (format out "~:@(~a~)_API_KEY=~a~%" provider api-key) + (format out "MEMORY_MAX_ENTRIES=~a~%" memory) + (format out "DAEMON_PORT=9105~%"))) + (error (c) + (setf (st :wizard-error) (format nil "Failed to write config: ~a" c))))) + (setf (st :wizard-visible) nil + (st :wizard-step) 0 + (st :wizard-error) nil) + (add-msg :system (format nil "Configuration saved to memex/.env (~a). Run /reconnect to reload." provider))) + +(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)) + (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)))))) + +#+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." @@ -721,8 +1098,13 @@ Event handlers + daemon I/O + main loop. (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)) +(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))) (cond (text (setf (st :busy) nil) (add-msg :agent text :gate-trace gate-trace)) @@ -827,17 +1209,19 @@ Event handlers + daemon I/O + main loop. (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) (let* ((h (or (height scr) 24)) (w (or (width scr) 80)) - (sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1)) + (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)) - (cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1)) - (iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1)) - (swank-port (or (ignore-errors - (parse-integer (uiop:getenv "TUI_SWANK_PORT"))) - 4006))) + (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) - ;; Store windows in state for SIGWINCH handler (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw) (connect-daemon) (when (> swank-port 0) @@ -850,44 +1234,103 @@ Event handlers + daemon I/O + main loop. (format nil "* Swank ~d M-x slime-connect *" swank-port))) (error () (add-msg :system "* Swank unavailable *")))) - ;; Initial render before the main loop — otherwise the screen stays - ;; blank until the first keystroke (get-char blocks). - (redraw sw cw ch iw) - (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) - ;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses) - ((eql ch 410) - (let* ((new-h (or (height scr) 24)) - (new-w (or (width scr) 80)) - (new-ch (- new-h 5))) - (setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1) - ch new-ch - cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1) - iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1) - 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) - (redraw sw cw ch iw) - (refresh scr))) - (t (on-key ch)))) + (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) - (refresh scr) - (sleep 0.03)) - (disconnect-daemon)))) + (when sidebar-w + (view-sidebar sidebar-w) + (refresh sidebar-w)) + (when (st :palette-visible) + (let* ((pw (min 56 (floor (* w 0.7)))) + (ph (min 18 (floor (* h 0.6)))) + (px (floor (- w pw) 2)) + (py (floor (- h ph) 2)) + (palette-win (make-instance 'window :height ph :width pw :y py :x px))) + (view-palette palette-win) + (refresh palette-win) + (close palette-win))) + (when (st :wizard-visible) + (let* ((ww 60) (wh 14) + (wx (floor (- w ww) 2)) + (wy (floor (- h wh) 2)) + (wizard-win (make-instance 'window :height wh :width ww :y wy :x wx))) + (view-wizard wizard-win) + (refresh wizard-win) + (close wizard-win))) + (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 (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))) + (when (st :palette-visible) + (let* ((pw (min 56 (floor (* w 0.7)))) + (ph (min 18 (floor (* h 0.6)))) + (px (floor (- w pw) 2)) + (py (floor (- h ph) 2)) + (palette-win (make-instance 'window :height ph :width pw :y py :x px))) + (view-palette palette-win) + (refresh palette-win) + (close palette-win))) + (when (st :wizard-visible) + (let* ((ww 60) (wh 14) + (wx (floor (- w ww) 2)) + (wy (floor (- h wh) 2)) + (wizard-win (make-instance 'window :height wh :width ww :y wy :x wx))) + (view-wizard wizard-win) + (refresh wizard-win) + (close wizard-win))) + (refresh scr) + (sleep 0.03)) + (disconnect-daemon))))) #+end_src @@ -1368,3 +1811,119 @@ Event handlers + daemon I/O + main loop. (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-palette + "Contract 6: Ctrl+P opens command palette." + (init-state) + (on-key 16) ; Ctrl+P + (fiveam:is (eq t (st :palette-visible))) + (fiveam:is (not (null (st :palette-items)))) + (fiveam:is (= 0 (st :palette-selected-idx)))) + +(fiveam:test test-palette-escape-dismisses + "Contract 6: Esc dismisses palette." + (init-state) + (setf (st :palette-visible) t) + (on-key 27) ; Esc + (fiveam:is (null (st :palette-visible)))) + +(fiveam:test test-palette-enter-executes + "Contract 9: Enter executes selected item and dismisses palette." + (init-state) + (setf (st :palette-visible) t + (st :palette-selected-idx) 0 + (st :palette-items) (passepartout.channel-tui::palette-items)) + (on-key (char-code #\/)) + (on-key (char-code #\t)) + (fiveam:is (string= "/t" (st :palette-filter)))) + +(fiveam:test test-palette-items-has-categories + "Contract 7: palette-items returns categorized list with at least Session and View." + (init-state) + (let ((items (passepartout.channel-tui::palette-items))) + (fiveam:is (listp items)) + (fiveam:is (find "Session" items :key (lambda (g) (getf g :category)) :test #'string=)) + (fiveam:is (find "View" items :key (lambda (g) (getf g :category)) :test #'string=)))) + +;; ── v0.8.0 Setup Wizard ── + +(fiveam:test test-wizard-steps-count + "Contract v0.8.0: wizard-steps returns 4 steps." + (let ((steps (passepartout.channel-tui::wizard-steps))) + (fiveam:is (= 4 (length steps))))) + +(fiveam:test test-wizard-start-sets-visible + "Contract v0.8.0: wizard-start sets wizard-visible and resets state." + (init-state) + (passepartout.channel-tui::wizard-start) + (fiveam:is (eq t (st :wizard-visible))) + (fiveam:is (= 0 (st :wizard-step))) + (fiveam:is (string= "" (st :wizard-input)))) + +(fiveam:test test-wizard-cancel-hides + "Contract v0.8.0: wizard-cancel hides the wizard." + (init-state) + (setf (st :wizard-visible) t) + (passepartout.channel-tui::wizard-cancel) + (fiveam:is (null (st :wizard-visible)))) + +(fiveam:test test-wizard-next-valid-advances + "Contract v0.8.0: valid input advances to next step." + (init-state) + (passepartout.channel-tui::wizard-start) + (setf (st :wizard-input) "openai") + (passepartout.channel-tui::wizard-next) + (fiveam:is (= 1 (st :wizard-step))) + (fiveam:is (string= "openai" (st :wizard-provider)))) + +(fiveam:test test-wizard-next-invalid-shows-error + "Contract v0.8.0: invalid input shows error and stays on current step." + (init-state) + (passepartout.channel-tui::wizard-start) + (setf (st :wizard-input) "invalid-provider") + (passepartout.channel-tui::wizard-next) + (fiveam:is (= 0 (st :wizard-step))) + (fiveam:is (not (null (st :wizard-error))))) + +(fiveam:test test-ctrl-backslash-opens-wizard + "Contract v0.8.0: Ctrl+\\ opens the setup wizard." + (init-state) + (on-key 28) ; Ctrl+\ + (fiveam:is (eq t (st :wizard-visible)))) + +#+end_src diff --git a/org/channel-tui-state.org b/org/channel-tui-state.org index a1de914..2606f3e 100644 --- a/org/channel-tui-state.org +++ b/org/channel-tui-state.org @@ -6,6 +6,66 @@ 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, @@ -15,6 +75,18 @@ All state mutation flows through event handlers in the controller. 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 @@ -85,7 +157,43 @@ 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")) + :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")) "Named theme presets. /theme loads one into *tui-theme*.") (defvar *tui-theme-current-name* :dark @@ -124,6 +232,32 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).") "Returns the Croatoan color for a semantic role." (or (getf *tui-theme* role) :white)) +;; 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))) + (defun st (key) (getf *state* key)) (defun (setf st) (val key) (setf (getf *state* key) val)) @@ -139,6 +273,13 @@ 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 + :palette-visible nil :palette-filter nil ; v0.8.0 + :palette-selected-idx 0 :palette-items nil ; v0.8.0 + :wizard-step 0 :wizard-error nil ; v0.8.0 + :wizard-visible nil :wizard-input "" ; v0.8.0 + :wizard-provider nil :wizard-api-key nil ; v0.8.0 + :wizard-memory nil ; v0.8.0 :dirty (list nil nil nil)))) #+end_src diff --git a/org/channel-tui-view.org b/org/channel-tui-view.org index f90c7c1..7c0471d 100644 --- a/org/channel-tui-view.org +++ b/org/channel-tui-view.org @@ -6,6 +6,89 @@ 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 — TUI Setup Wizard (deferred from v0.7.0) + +The TUI setup wizard replaces the terminal-based ~passepartout configure~ +flow with an in-TUI onboarding sequence. Users select LLM providers, +enter API keys, and verify connections — all within the same interface +they'll use daily. + +The wizard is a multi-step overlay with progress indicator. Each step +defines a title, prompt text, validation function, and next-step function. +On validation failure, the step displays an error and stays on the current +step. On success, it advances. The last step writes configuration to +~.env~ and triggers daemon reload. + +The wizard reuses the overlay infrastructure built for the command +palette and sidebar — same window creation patterns, same Croatoan +rendering primitives. + ** Contract 1. (view-status win): renders the status bar with connection info, @@ -23,6 +106,23 @@ State is read via ~(st :key)~ — no mutation here. 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 @@ -356,9 +456,9 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." (:approval :gate-approval) (t :dim))) (prefix (case result - (:passed " \u2713 ") - (:blocked " \u2717 ") - (:approval " \u2192 ") + (:passed " ✓ ") + (:blocked " ✗ ") + (:approval " → ") (t " ? "))) (text (format nil "~a~a~@[~a~]~@[~a~]" prefix name @@ -368,6 +468,198 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." (nreverse lines))) #+end_src +* v0.8.0 — Sidebar + Palette View +#+begin_src lisp +(in-package :passepartout.channel-tui) + +(defun view-sidebar (win) + "Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection." + (clear win) + (box win (theme-color :border) (theme-color :background)) + (let* ((w (or (width win) 42)) + (h (or (height win) 24)) + (y 1) + (gate-trace (st :gate-trace)) + (foveal-id (st :foveal-id)) + (rule-count (or (st :rule-count) 0)) + (context-usage (st :context-usage)) + (modified-files (st :modified-files)) + (session-cost (st :session-cost)) + (block-counts (st :block-counts))) + ;; Panel 1: Gate Trace + (add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if gate-trace + (dolist (entry (passepartout::gate-trace-lines gate-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))) + ;; Panel 2: Focus + (incf y) + (add-string win "── Focus ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (add-string win (format nil " ~a" (or foveal-id "(none)")) :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map)) + ;; Panel 3: Rules + (incf y 2) + (add-string win "── Rules ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (add-string win (format nil " Rules: ~d" rule-count) :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count)) + ;; Panel 4: Context gauge + (incf y 2) + (add-string win "── Context ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (let* ((pct (or 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)) + ;; Panel 5: Files + (incf y 2) + (add-string win "── Files ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if modified-files + (dolist (f modified-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))) + ;; Panel 6: Cost + (incf y 2) + (add-string win "── Cost ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if session-cost + (progn + (add-string win (format nil " Total: $~,4f" (getf session-cost :total)) + :y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)) + (incf y) + (add-string win (format nil " Calls: ~d" (getf session-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))) + ;; Panel 7: Protection + (incf y 2) + (add-string win "── Protection ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent)) + (incf y) + (if (and block-counts (> (getf block-counts :total) 0)) + (let ((by-gate (getf block-counts :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))) + (refresh win) + (- y 1))) + +(defun palette-filter (items query) + "Return items from categorized list whose :name or :desc contains QUERY (case-insensitive)." + (if (or (null query) (string= query "")) + items + (let ((q (string-downcase query))) + (loop for group in items + for category = (getf group :category) + for gitems = (getf group :items) + for filtered = (loop for item in gitems + when (or (search q (string-downcase (getf item :name))) + (search q (string-downcase (or (getf item :desc) "")))) + collect item) + when filtered + collect (list :category category :items filtered))))) + +(defun view-palette (win) + "Render centered command palette overlay with filtered items, selection highlight." + (clear win) + (box win (theme-color :border) (theme-color :background)) + (let* ((w (or (width win) 50)) + (h (or (height win) 20)) + (y 1) + (query (or (st :palette-filter) "")) + (items (palette-filter (st :palette-items) query)) + (selected (st :palette-selected-idx)) + (flat-index 0) + (visible-start (max 0 (- selected (floor (- h 6) 2))))) + (add-string win (format nil " Command Palette ") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) + (incf y) + (add-string win (format nil " > ~a" (if (> (length query) 0) query "type to filter...")) + :y y :x 2 :n (- w 4) :fgcolor (theme-color :input) :attributes '(:underline t)) + (incf y) + (dolist (group items) + (let ((category (getf group :category)) + (gitems (getf group :items))) + (when (and gitems (< y (1- h))) + (incf y) + (add-string win (format nil "── ~a ──" category) :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (dolist (item gitems) + (when (< y (1- h)) + (incf y) + (let* ((name (getf item :name)) + (desc (getf item :desc)) + (shortcut (getf item :shortcut)) + (is-selected (= flat-index selected)) + (fg (if is-selected (theme-color :accent) (theme-color :agent)))) + (when is-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 :accent))) + (add-string win (format nil " ~a" name) :y y :x 3 :n (- w 6) :fgcolor fg) + (when (and shortcut (> (- w 6) (+ 4 (length shortcut)))) + (add-string win shortcut :y y :x (- w (length shortcut) 3) :n (length shortcut) :fgcolor (theme-color :dim))) + (incf flat-index))))))) + (add-string win (format nil " ↑↓ Navigate Enter Execute Esc Close") + :y (- h 1) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (refresh win) + (- h 1))) + +(defun view-wizard (win) + "Render setup wizard overlay: step title, prompt, input, error, progress." + (clear win) + (box win (theme-color :border) (theme-color :background)) + (let* ((w (or (width win) 60)) + (h (or (height win) 15)) + (y 1) + (steps (passepartout.channel-tui::wizard-steps)) + (step-idx (st :wizard-step)) + (step (when (< step-idx (length steps)) (nth step-idx steps))) + (prompt (getf step :prompt)) + (title (getf step :title)) + (total (length steps)) + (error-msg (st :wizard-error)) + (input (or (st :wizard-input) ""))) + (add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent)) + (incf y 2) + (add-string win (format nil "Step ~d/~d" (1+ step-idx) total) :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (incf y) + (when title + (add-string win title :y y :x 3 :n (- w 6) :fgcolor (theme-color :accent)) + (incf y)) + (when prompt + (add-string win prompt :y y :x 3 :n (- w 6) :fgcolor (theme-color :agent)) + (incf y)) + (incf y) + (add-string win (format nil "> ~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)) + (add-string win "Enter=Next Esc=Cancel Bksp=Edit" :y (- h 2) :x 2 :n (- w 4) :fgcolor (theme-color :dim)) + (refresh win) + (- h 1))) +#+end_src + * Test Suite #+begin_src lisp (eval-when (:compile-toplevel :load-toplevel :execute) @@ -478,3 +770,51 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8." (let ((cg (passepartout.channel-tui::st :collapsed-gates))) (is (null cg)))) #+end_src + +* v0.8.0 Tests — Sidebar 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))))) + +(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-palette-filter-matches-substring + "Contract v0.8.0: palette-filter returns items matching query." + (let* ((items (list (list :category "Session" :items + (list (list :name "/focus" :desc "Set context" :shortcut nil :action nil) + (list :name "/scope" :desc "Change scope" :shortcut nil :action nil))))) + (filtered (passepartout.channel-tui::palette-filter items "focus"))) + (is (= 1 (length (getf (first filtered) :items)))) + (is (string= "/focus" (getf (first (getf (first filtered) :items)) :name))))) + +(test test-palette-filter-case-insensitive + "Contract v0.8.0: palette-filter is case-insensitive." + (let* ((items (list (list :category "View" :items + (list (list :name "/theme" :desc "Switch color" :shortcut nil :action nil))))) + (filtered (passepartout.channel-tui::palette-filter items "THEME"))) + (is (= 1 (length (getf (first filtered) :items)))))) + +(test test-palette-filter-no-match-empty + "Contract v0.8.0: palette-filter returns empty categories on no match." + (let* ((items (list (list :category "View" :items + (list (list :name "/theme" :desc "Colors" :shortcut nil :action nil))))) + (filtered (passepartout.channel-tui::palette-filter items "xyznonexistent"))) + (is (null (getf (first filtered) :items))))) +#+end_src diff --git a/org/core-act.org b/org/core-act.org index 04051e9..2266f4d 100644 --- a/org/core-act.org +++ b/org/core-act.org @@ -30,7 +30,13 @@ Because a skill's deterministic gate runs during Reason, but between Reason and ~action-dispatch~, sets ~:status :acted~, returns feedback. 2. (act-gate signal): thin alias for ~loop-gate-act~. 3. (action-dispatch approved signal): routes approved actions to - registered actuators by ~:target~ keyword. + registered actuators by ~:target~ keyword. + 4. (tui-enrich-response action context): enriches the outgoing action + plist with sidebar fields — ~:block-counts~, ~:context-usage~, + ~:modified-files~, ~:session-cost~ (v0.8.0) — plus existing + ~:rule-count~ and ~:foveal-id~ (v0.4.0). Each field is + ~fboundp~-guarded; missing skills produce nil. Called from the + ~:tui~ actuator lambda. * Implementation @@ -87,18 +93,44 @@ Because a skill's deterministic gate runs during Reason, but between Reason and 0)) (setf (getf (getf action :payload) :foveal-id) (getf context :foveal-id)) + ;; v0.8.0: sidebar enrichment via fboundp guards + (when (fboundp 'dispatcher-block-counts-summary) + (setf (getf (getf action :payload) :block-counts) + (dispatcher-block-counts-summary))) + (when (fboundp 'context-usage-percentage) + (setf (getf (getf action :payload) :context-usage) + (context-usage-percentage))) + (when (fboundp 'tool-modified-files-summary) + (setf (getf (getf action :payload) :modified-files) + (tool-modified-files-summary))) + (when (fboundp 'cost-session-summary) + (setf (getf (getf action :payload) :session-cost) + (cost-session-summary))) (format stream "~a" (frame-message action)) (finish-output stream)))))) #+end_src -** TUI Differentiator Enrichment (v0.4.0) +** TUI Differentiator Enrichment (v0.4.0, extended v0.8.0) The TUI actuator is the last point in the pipeline before the response leaves the daemon. It enriches the action plist with fields that power the TUI's differentiator visualizations: -- ~:rule-count~ = ~(hash-table-count *hitl-pending*)~ — the number of pending HITL actions. The user watches this counter tick as they teach the agent their preferences. -- ~:foveal-id~ = the current foveal focus from the signal context — enables the TUI's focus map status line. -- ~:gate-trace~ — already attached by ~cognitive-verify~, flows through the action plist unchanged. -#+end_src +- ~:rule-count~ = ~(hash-table-count *hitl-pending*)~ — the number of pending HITL actions. The user watches this counter tick as they teach the agent their preferences. (v0.4.0) +- ~:foveal-id~ = the current foveal focus from the signal context — enables the TUI's focus map status line. (v0.4.0) +- ~:gate-trace~ — already attached by ~cognitive-verify~, flows through the action plist unchanged. (v0.4.0) + +v0.8.0 adds four sidebar fields via ~fboundp~ guards — same pattern as +~core-reason.lisp~'s calls into token-economics, awareness, and time skills. +Each field degrades gracefully to nil when its source skill is not loaded: + +- ~:block-counts~ = ~(dispatcher-block-counts-summary)~ — per-gate block tallies from ~security-dispatcher~. Powers the sidebar's Protection panel. +- ~:context-usage~ = ~(context-usage-percentage)~ — token budget percentage from ~token-economics~. Powers the sidebar's Context gauge. +- ~:modified-files~ = ~(tool-modified-files-summary)~ — files modified this turn from ~programming-tools~. Powers the sidebar's Files panel. +- ~:session-cost~ = ~(cost-session-summary)~ — cumulative cost data from ~cost-tracker~. Powers the sidebar's Cost panel. + +The enrichment is added inside the existing ~:tui~ actuator lambda (one block +after the ~:rule-count~ and ~:foveal-id~ enrichment). No new actuator is +registered; no new ASDF component is added. The contract is: each field +arrives via ~fboundp~ guard and is silently nil when unavailable. ** Action Dispatch (action-dispatch) diff --git a/org/cost-tracker.org b/org/cost-tracker.org index 7b35cf2..7dde27c 100644 --- a/org/cost-tracker.org +++ b/org/cost-tracker.org @@ -14,6 +14,18 @@ The tracking is minimal and accurate to within ~10-15% (using the token heuristic from tokenizer.lisp). It persists across daemon restarts via ~*session-cost*~ in the memory store. +** v0.8.0 — Session Summary for Sidebar + +The sidebar's Cost panel needs an at-a-glance cost summary: total spent, +call count, per-provider breakdown. ~cost-session-summary~ packages the +three existing accessors (~cost-session-total~, ~cost-session-calls~, +~cost-by-provider~) into a single plist ~(:total :calls +:by-provider )~. This is a thin wrapper (~5 lines) — the data +already exists; the function exposes it in the shape the TUI expects. + +Called from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard. +Degrades gracefully to nil when cost-tracker is not loaded. + ** Contract 1. (cost-track-call provider prompt-text response-text): compute and @@ -21,7 +33,11 @@ heuristic from tokenizer.lisp). It persists across daemon restarts via 2. (cost-session-total): returns the current session's total cost. 3. (cost-session-reset): zeroes the session cost accumulator. 4. (cost-format-budget-status total budget): returns a human-readable - budget status string for the TUI status bar. + budget status string for the TUI status bar. +5. (cost-session-summary): returns plist + ~(:total :calls :by-provider )~ aggregating + all three session cost accessors. Consumed by the TUI actuator + for the sidebar Cost panel (v0.8.0). * Implementation @@ -44,8 +60,12 @@ heuristic from tokenizer.lisp). It persists across daemon restarts via (defun cost-track-call (provider prompt-text &optional response-text) "Compute and accumulate the cost of a single LLM call. Returns the cost of this call in USD." - (let* ((input-tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) - (output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0)) + (let* ((input-tokens (if (fboundp 'count-tokens) + (funcall (symbol-function 'count-tokens) (or prompt-text "")) + (ceiling (length (or prompt-text "")) 4))) + (output-tokens (if (and response-text (fboundp 'count-tokens)) + (funcall (symbol-function 'count-tokens) response-text) + 0)) (total-tokens (+ input-tokens output-tokens)) (cost (provider-token-cost provider total-tokens))) (bordeaux-threads:with-lock-held (*session-cost-lock*) @@ -80,6 +100,16 @@ Returns the cost of this call in USD." (getf *session-cost* :by-provider))) #+end_src +** Session summary (v0.8.0) +#+begin_src lisp +(defun cost-session-summary () + "Returns plist (:total :calls :by-provider )." + (bordeaux-threads:with-lock-held (*session-cost-lock*) + (list :total (getf *session-cost* :total) + :calls (getf *session-cost* :calls) + :by-provider (getf *session-cost* :by-provider)))) +#+end_src + ** Session reset #+begin_src lisp (defun cost-session-reset () @@ -87,8 +117,7 @@ Returns the cost of this call in USD." (bordeaux-threads:with-lock-held (*session-cost-lock*) (setf (getf *session-cost* :total) 0.0) (setf (getf *session-cost* :calls) 0) - (setf (getf *session-cost* :by-provider) nil) - (log-message "COST TRACKER: Session cost reset."))) + (setf (getf *session-cost* :by-provider) nil))) #+end_src ** Budget status formatting @@ -186,4 +215,16 @@ LLM invocation to record the cost. (cost-session-reset) (let ((cost (cost-track-call :deepseek "test"))) (is (> cost 0.0)))) + +(test test-cost-session-summary + "Contract 5: cost-session-summary returns plist with total, calls, by-provider." + (cost-session-reset) + (cost-track-call :deepseek "hello") + (cost-track-call :groq "world") + (let ((s (cost-session-summary))) + (is (> (getf s :total) 0.0)) + (is (= 2 (getf s :calls))) + (let ((by (getf s :by-provider))) + (is (assoc :deepseek by)) + (is (assoc :groq by))))) #+end_src diff --git a/org/programming-tools.org b/org/programming-tools.org index 74d02ee..0e864e1 100644 --- a/org/programming-tools.org +++ b/org/programming-tools.org @@ -24,6 +24,32 @@ Each tool is registered via ~def-cognitive-tool~ and appears in the LLM's tool b 11. ~run-tests~: given optional ~:test-name~, runs specific test or all suites via ~fiveam:run-all-tests~. 12. ~org-find-headline~: given ~:id~ or ~:title~, searches ~*memory-store*~ for matching memory objects. 13. ~org-modify-file~: given ~:filepath~, ~:old-text~, ~:new-text~, performs exact-string replacement. Returns error if text not found. +14. (tool-register-modified filepath &key old-content new-content): + appends a modification record to ~*modified-files-this-turn*~. + Returns the record plist ~(:filepath :timestamp + :lines-added :lines-removed )~. +15. (tool-modified-files-summary): returns the list of modified-file + plists accumulated this turn and clears ~*modified-files-this-turn*~. + Returns nil when no files were modified. + +** v0.8.0 — Modified Files Tracking + +The sidebar's Files panel needs to know which files the agent modified in +the most recent tool execution. ~*modified-files-this-turn*~ is a list of +plists tracking each write operation: ~(:filepath :timestamp +:lines-added :lines-removed )~. + +~tool-register-modified~ is called by ~write-file~ and ~org-modify-file~ +after successful writes. It computes line counts by comparing the old and +new content (when available) or records the operation with nil counts. +~tool-modified-files-summary~ returns the accumulated list and resets +it for the next turn (reset happens at the start of each ~think()~ cycle +in ~core-reason.lisp~). + +The tracking is per-turn, not cumulative — the sidebar shows what changed +in the /last/ tool execution, matching the tool-execution visualization +pattern from v0.7.1. Cumulative file tracking belongs in the version +control system. * Implementation @@ -156,12 +182,13 @@ Writes string content to a file, creating parent directories as needed. (content (getf args :content))) (unless (and filepath content) (return (list :status :error :message "write-file requires :filepath and :content"))) - (handler-case - (progn - (tools-write-file filepath content) - (verify-write filepath content) - (list :status :success - :content (format nil "Written ~d bytes to ~a" (length content) filepath))) + (handler-case + (progn + (tools-write-file filepath content) + (verify-write filepath content) + (tool-register-modified filepath :new-content content) + (list :status :success + :content (format nil "Written ~d bytes to ~a" (length content) filepath))) (error (c) (list :status :error :message (format nil "~a" c)))))))) #+end_src @@ -331,12 +358,13 @@ Surgical text replacement in an Org file — matches exact text and replaces it. (let ((content (uiop:read-file-string filepath))) (let ((pos (search old-text content))) (if pos - (let ((new-content (concatenate 'string - (subseq content 0 pos) - new-text - (subseq content (+ pos (length old-text)))))) - (tools-write-file filepath new-content) - (list :status :success + (let ((new-content (concatenate 'string + (subseq content 0 pos) + new-text + (subseq content (+ pos (length old-text)))))) + (tools-write-file filepath new-content) + (tool-register-modified filepath :old-content content :new-content new-content) + (list :status :success :content (format nil "Replaced at position ~d in ~a" pos filepath))) (list :status :error :message (format nil "Text not found in ~a" filepath))))) (error (c) (list :status :error :message (format nil "~a" c)))))))) @@ -576,6 +604,41 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip (defvar *cognitive-tool-registry* (make-hash-table :test 'equal)) #+end_src +* v0.8.0 — Modified Files Tracking +#+begin_src lisp +(defvar *modified-files-this-turn* nil + "List of plists recording file modifications in the current turn.") + +(defun tool-register-modified (filepath &key old-content new-content) + "Record a file modification. Returns the record plist." + (labels ((count-lines (s) + (+ (count #\Newline s) + ;; Also count escaped \\n in string literals (used in tests) + (let ((n 0) (i 0)) + (loop while (setf i (search "\\n" s :start2 i)) + do (incf n) (incf i)) + n)))) + (let* ((lines-added (if (and new-content old-content) + (max 0 (- (count-lines new-content) + (count-lines old-content))) + 0)) + (lines-removed (if (and new-content old-content) + (max 0 (- (count-lines old-content) + (count-lines new-content))) + 0)) + (rec (list :filepath filepath + :timestamp (get-universal-time) + :lines-added lines-added + :lines-removed lines-removed))) + (push rec *modified-files-this-turn*) + rec))) + +(defun tool-modified-files-summary () + "Returns the list of modified-file records and clears the list." + (prog1 (nreverse *modified-files-this-turn*) + (setf *modified-files-this-turn* nil))) +#+end_src + * Test Suite #+begin_src lisp @@ -751,3 +814,34 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) (is (eq (getf result :status) :error)))) #+end_src + +* v0.8.0 Tests — Modified Files Tracking +#+begin_src lisp +(in-package :passepartout-programming-tools-tests) + +(test test-modified-files-track-write + "Contract 14: tool-register-modified appends to *modified-files-this-turn*." + (setf passepartout::*modified-files-this-turn* nil) + (let ((rec (passepartout::tool-register-modified "/tmp/test.org" + :old-content "old" :new-content "line1 +line2"))) + (is (string= "/tmp/test.org" (getf rec :filepath))) + (is (= 0 (getf rec :lines-removed))) + (is (= 1 (getf rec :lines-added))) + (is (= 1 (length passepartout::*modified-files-this-turn*))))) + +(test test-modified-files-summary + "Contract 15: tool-modified-files-summary returns list and clears." + (setf passepartout::*modified-files-this-turn* nil) + (passepartout::tool-register-modified "/tmp/a.org") + (passepartout::tool-register-modified "/tmp/b.org") + (let ((files (passepartout::tool-modified-files-summary))) + (is (= 2 (length files))) + (is (null passepartout::*modified-files-this-turn*)) + (is (find "/tmp/a.org" files :key (lambda (f) (getf f :filepath)) :test #'string=)))) + +(test test-modified-files-empty + "Contract 15: tool-modified-files-summary returns nil when no files modified." + (setf passepartout::*modified-files-this-turn* nil) + (is (null (passepartout::tool-modified-files-summary)))) +#+end_src diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index 6f20f5d..ac2c213 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -47,12 +47,39 @@ The Dispatcher also handles the **Flight Plan** system: when a high-risk action T if found, nil if invalid token. 9. (hitl-deny token): denies and removes a pending action. Returns T if found, nil if invalid. +10. (dispatcher-block-record gate-name): records a block decision in + ~*dispatcher-block-counts*~ alist. Returns the updated count for + that gate. +11. (dispatcher-block-counts-summary): returns plist + ~(:total :by-gate (( . ) ...))~ of all blocked + actions this session. ** Boundaries - Does NOT handle the gate approval routing — that is ~core-reason.org~. - Does NOT persist HITL tokens — they live in memory only. +** v0.8.0 — Dispatcher Block Counts + +The sidebar's Protection panel (panel 7 of the Information Radiator) +needs per-gate block statistics — how many times each of the ten +deterministic vectors blocked an action. This is the specific-value- +proposition panel: no competitor can count deterministic gate blocks +because none has deterministic gates. + +~*dispatcher-block-counts*~ is an alist mapping gate keyword to integer +count: ~((:secret-path . 3) (:shell-safety . 12) (:network-exfil . 7) ...)~. +Incremented in ~dispatcher-check~ on every ~:blocked~ result via +~dispatcher-block-record~. Exposed to the TUI via ~dispatcher-block-counts-summary~, +which returns a plist with ~:total~ and ~:by-gate~ fields. The TUI actuator +in ~core-act.org~ reads this via ~fboundp~ guard and injects ~:block-counts~ +into the response plist. + +The counter is session-scoped (lives in memory). It does not persist across +daemon restarts — it tracks what happened /this/ session, which is what the +sidebar shows. Historical block telemetry belongs in the telemetry system +(v0.12.0). + * Implementation ** Package Context @@ -464,54 +491,60 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, action) ;; Vector 1: Lisp syntax validation (block bad lisp writes) - ((and lisp-valid (eq (getf lisp-valid :status) :error)) - (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) - (list :type :LOG - :payload (list :level :error - :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) + ((and lisp-valid (eq (getf lisp-valid :status) :error)) + (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason)) + (dispatcher-block-record :lisp-validation) + (list :type :LOG + :payload (list :level :error + :text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) - ;; Vector 2: File read to a protected secret path - ((and filepath (dispatcher-check-secret-path filepath)) - (let ((matched (dispatcher-check-secret-path filepath))) - (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) + ;; Vector 2: File read to a protected secret path + ((and filepath (dispatcher-check-secret-path filepath)) + (let ((matched (dispatcher-check-secret-path filepath))) + (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched) + (dispatcher-block-record :secret-path) + (list :type :LOG + :payload (list :level :error + :text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) - ;; Vector 2b: Self-build safety — core file writes require HITL approval - ((and filepath content - (string-equal (uiop:getenv "SELF_BUILD_MODE") "true") - (dispatcher-check-core-path filepath)) - (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) - (list :type :EVENT :level :approval-required - :payload (list :sensor :approval-required :action action - :message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) + ;; Vector 2b: Self-build safety — core file writes require HITL approval + ((and filepath content + (string-equal (uiop:getenv "SELF_BUILD_MODE") "true") + (dispatcher-check-core-path filepath)) + (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) + (dispatcher-block-record :self-build-core) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action + :message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) - ;; Vector 3: Content contains secret patterns - ((and text (dispatcher-exposure-scan text)) - (let ((matched (dispatcher-exposure-scan text))) - (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) - (list :type :LOG - :payload (list :level :error - :text "Action blocked: Content contains potential secret exposure.")))) + ;; Vector 3: Content contains secret patterns + ((and text (dispatcher-exposure-scan text)) + (let ((matched (dispatcher-exposure-scan text))) + (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) + (dispatcher-block-record :secret-content) + (list :type :LOG + :payload (list :level :error + :text "Action blocked: Content contains potential secret exposure.")))) - ;; Vector 4: Content contains vault secrets - ((and text (dispatcher-vault-scan text)) - (let ((secret-name (dispatcher-vault-scan text))) - (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) + ;; Vector 4: Content contains vault secrets + ((and text (dispatcher-vault-scan text)) + (let ((secret-name (dispatcher-vault-scan text))) + (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) + (dispatcher-block-record :vault-secrets) + (list :type :LOG + :payload (list :level :error + :text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) ;; Vector 5: Privacy-tagged content (severity tiers) ((and tags (fboundp 'dispatcher-privacy-severity)) (let ((severity (dispatcher-privacy-severity tags))) (cond - ((eq severity :block) - (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) - (list :type :LOG - :payload (list :level :error - :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) + ((eq severity :block) + (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) + (dispatcher-block-record :privacy-tags) + (list :type :LOG + :payload (list :level :error + :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) ((eq severity :warn) (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags) action) @@ -519,36 +552,40 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path, (log-message "PRIVACY: @tag ~a (logged)" tags) action)))) - ;; Vector 6: Text leaks privacy tag names - ((and text (dispatcher-check-text-for-privacy text)) - (log-message "PRIVACY WARNING: Text may contain leaked private content") - (list :type :LOG - :payload (list :level :warn - :text "Action blocked: Text may reference private content."))) + ;; Vector 6: Text leaks privacy tag names + ((and text (dispatcher-check-text-for-privacy text)) + (log-message "PRIVACY WARNING: Text may contain leaked private content") + (dispatcher-block-record :privacy-text) + (list :type :LOG + :payload (list :level :warn + :text "Action blocked: Text may reference private content."))) - ;; Vector 7: Shell destructive/injection patterns - ((and cmd (dispatcher-check-shell-safety cmd)) - (let ((matched (dispatcher-check-shell-safety cmd))) - (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) - (list :type :LOG - :payload (list :level :error - :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) + ;; Vector 7: Shell destructive/injection patterns + ((and cmd (dispatcher-check-shell-safety cmd)) + (let ((matched (dispatcher-check-shell-safety cmd))) + (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) + (dispatcher-block-record :shell-safety) + (list :type :LOG + :payload (list :level :error + :text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) - ;; Vector 8: Network exfiltration - ((and (or (eq target :shell) - (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) - (dispatcher-check-network-exfil cmd)) - (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") - (list :type :EVENT :level :approval-required - :payload (list :sensor :approval-required :action action))) + ;; Vector 8: Network exfiltration + ((and (or (eq target :shell) + (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) + (dispatcher-check-network-exfil cmd)) + (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") + (dispatcher-block-record :network-exfil) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action))) - ;; Vector 8: High-impact action approval - ((or (member target '(:shell)) - (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) - (and (eq target :emacs) (eq (proto-get payload :action) :eval)) - (and (eq target :system) (eq (proto-get payload :action) :eval))) - (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) - (list :type :EVENT :payload (list :sensor :approval-required :action action))) + ;; Vector 8b: High-impact action approval + ((or (member target '(:shell)) + (and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) + (and (eq target :emacs) (eq (proto-get payload :action) :eval)) + (and (eq target :system) (eq (proto-get payload :action) :eval))) + (log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target)) + (dispatcher-block-record :high-impact-approval) + (list :type :EVENT :payload (list :sensor :approval-required :action action))) (t action)))) #+end_src @@ -736,6 +773,35 @@ Recognized formats: :deterministic #'dispatcher-gate) #+end_src +** v0.8.0 — Block Count Tracking + +~*dispatcher-block-counts*~ is a hash table mapping gate keyword to +integer block count. Every blocking decision in ~dispatcher-check~ +records the block via ~dispatcher-block-record~. The sidebar's Protection +panel reads the summary via ~dispatcher-block-counts-summary~, called +from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard. + +#+begin_src lisp +(defvar *dispatcher-block-counts* (make-hash-table :test 'equal) + "Per-gate block count: maps gate keyword → integer.") + +(defun dispatcher-block-record (gate-name) + "Records a block decision for GATE-NAME. Returns the updated count." + (let ((count (1+ (gethash gate-name *dispatcher-block-counts* 0)))) + (setf (gethash gate-name *dispatcher-block-counts*) count) + count)) + +(defun dispatcher-block-counts-summary () + "Returns plist (:total :by-gate (( . ) ...))." + (let* ((by-gate + (loop for k being the hash-keys of *dispatcher-block-counts* + for v = (gethash k *dispatcher-block-counts*) + collect (cons k v))) + (total (reduce #'+ (mapcar #'cdr by-gate) :initial-value 0)) + (sorted (sort (copy-list by-gate) #'> :key #'cdr))) + (list :total total :by-gate sorted))) +#+end_src + * Test Suite #+begin_src lisp @@ -837,7 +903,7 @@ Recognized formats: (is (eq :block (passepartout::tag-category-severity "@personal"))) (is (eq :warn (passepartout::tag-category-severity "@draft"))) (is (eq :log (passepartout::tag-category-severity "@review")))) - (setf (uiop:getenv "TAG_CATEGORIES") nil)) + (ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil))) (test test-tag-category-severity-unknown "Contract v0.7.2: unknown tag returns nil." @@ -904,21 +970,55 @@ Recognized formats: (test test-safe-tool-write-still-checked "Contract v0.7.2: write tools still go through full dispatcher check." - (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) - (passepartout::make-cognitive-tool :name "write-file" - :description "File writer" - :parameters nil - :guard nil - :body nil - :read-only-p nil)) - (unwind-protect - (progn - (setf (uiop:getenv "SELF_BUILD_MODE") "true") - (let* ((action '(:TYPE :REQUEST :TARGET :tool - :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) - (result (dispatcher-check action nil))) - (setf (uiop:getenv "SELF_BUILD_MODE") "false") - (is (eq :approval-required (getf result :level))) - (is (search "HITL" (getf (getf result :payload) :message))))) - (remhash "write-file" passepartout::*cognitive-tool-registry*))) + (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*))) + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) + (passepartout::make-cognitive-tool :name "write-file" + :description "File writer" + :parameters nil + :guard nil + :body nil + :read-only-p nil)) + (unwind-protect + (progn + (setf (uiop:getenv "SELF_BUILD_MODE") "true") + (let* ((action '(:TYPE :REQUEST :TARGET :tool + :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) + (result (dispatcher-check action nil))) + (is (eq :approval-required (getf result :level))) + (is (search "HITL" (getf (getf result :payload) :message))))) + (setf (uiop:getenv "SELF_BUILD_MODE") "false") + (if orig-tool + (setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool) + (remhash "write-file" passepartout::*cognitive-tool-registry*))))) +#+end_src + +* v0.8.0 Tests — Block Counts +#+begin_src lisp +(in-package :passepartout-security-dispatcher-tests) + +(test test-block-record-increments + "Contract 10: dispatcher-block-record increments per-gate count." + (clrhash passepartout::*dispatcher-block-counts*) + (is (= 1 (passepartout::dispatcher-block-record :shell-safety))) + (is (= 2 (passepartout::dispatcher-block-record :shell-safety))) + (is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*)))) + +(test test-block-counts-summary + "Contract 11: dispatcher-block-counts-summary returns total and by-gate." + (clrhash passepartout::*dispatcher-block-counts*) + (passepartout::dispatcher-block-record :shell-safety) + (passepartout::dispatcher-block-record :shell-safety) + (passepartout::dispatcher-block-record :secret-path) + (let ((s (passepartout::dispatcher-block-counts-summary))) + (is (= 3 (getf s :total))) + (let ((by-gate (getf s :by-gate))) + (is (= 2 (cdr (assoc :shell-safety by-gate)))) + (is (= 1 (cdr (assoc :secret-path by-gate))))))) + +(test test-block-counts-empty + "Contract 11: dispatcher-block-counts-summary returns zero when no blocks." + (clrhash passepartout::*dispatcher-block-counts*) + (let ((s (passepartout::dispatcher-block-counts-summary))) + (is (= 0 (getf s :total))) + (is (null (getf s :by-gate))))) #+end_src \ No newline at end of file diff --git a/org/token-economics.org b/org/token-economics.org index 1176091..0828931 100644 --- a/org/token-economics.org +++ b/org/token-economics.org @@ -27,6 +27,19 @@ core-reason thin while enabling token economics as a hot-loadable skill. Depends on: tokenizer.lisp, cost-tracker.lisp +** v0.8.0 — Context Usage for Sidebar + +The sidebar's Context gauge needs a single integer: 0-100 representing +how much of the token budget is consumed. ~context-usage-percentage~ +computes this from ~*context-cache*~'s stored token counts and +~CONTEXT_MAX_TOKENS~ (or the model's context limit from ~tokenizer~). + +The function is a thin wrapper (~8 lines): read the most recent context +assembly's token count from ~*context-cache*~, divide by the budget, +multiply by 100, clamp to [0, 100]. Called from ~core-act.org~'s ~:tui~ +actuator via ~fboundp~ guard. Degrades gracefully to nil when +token-economics is not loaded. + ** Contract 1. (prompt-prefix-cached assistant-name identity-content feedback mandates-text tool-belt): @@ -44,6 +57,10 @@ Depends on: tokenizer.lisp, cost-tracker.lisp L3: downgrade context to single-line summary Returns (values trimmed-prefix trimmed-ctxt trimmed-logs trimmed-user trimmed-mandates). 4. (token-economics-initialize): zeroes the cache state at daemon boot. +5. (context-usage-percentage): returns integer 0-100 representing + current token budget consumption from ~*context-cache*~. Clamped. + Returns nil when no context cache data is available. Consumed by + the TUI actuator for the sidebar Context gauge (v0.8.0). * Implementation @@ -57,7 +74,9 @@ Depends on: tokenizer.lisp, cost-tracker.lisp (defvar *prompt-prefix-cache* (cons nil "") "Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.") -(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "") +(defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "" + :identity-tokens 0 :tool-tokens 0 :context-tokens 0 + :log-tokens 0 :config-tokens 0 :time-tokens 0) "Context assembly cache: metadata + last rendered context string.") #+end_src @@ -127,7 +146,9 @@ with trimmed sections." (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) 16384))) - (labels ((ct (s) (funcall (symbol-function 'count-tokens) s)) + (labels ((ct (s) (if (fboundp 'count-tokens) + (funcall (symbol-function 'count-tokens) s) + (ceiling (length s) 4))) (total-tokens (p c l u m) (+ (ct p) (if c (ct c) 0) @@ -169,6 +190,25 @@ with trimmed sections." (getf *context-cache* :rendered) "")) #+end_src +** Contract 5: context usage percentage (v0.8.0) +#+begin_src lisp +(defun context-usage-percentage () + "Returns integer 0-100: current token budget consumption. +Returns nil when no context cache data is available." + (let* ((limit (or (ignore-errors + (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) + 16384)) + (tokens (+ (or (getf *context-cache* :identity-tokens) 0) + (or (getf *context-cache* :tool-tokens) 0) + (or (getf *context-cache* :context-tokens) 0) + (or (getf *context-cache* :log-tokens) 0) + (or (getf *context-cache* :config-tokens) 0) + (or (getf *context-cache* :time-tokens) 0)))) + (if (> tokens 0) + (min 100 (floor (* 100 tokens) limit)) + nil))) +#+end_src + * Test Suite #+begin_src lisp (eval-when (:compile-toplevel :load-toplevel :execute) @@ -270,3 +310,38 @@ with trimmed sections." (is (string= "" (cdr passepartout::*prompt-prefix-cache*))) (is (string= "" (getf passepartout::*context-cache* :rendered)))) #+end_src + +* v0.8.0 Tests — Context Usage +#+begin_src lisp +(in-package :passepartout-token-economics-tests) + +(test test-context-usage-percentage + "Contract 5: context-usage-percentage returns integer 0-100." + ;; Set up a cache with known token counts + (let* ((ctx passepartout::*context-cache*) + (limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) + 16384))) + (setf (getf ctx :identity-tokens) 1000 + (getf ctx :tool-tokens) 500 + (getf ctx :context-tokens) 2000 + (getf ctx :log-tokens) 800 + (getf ctx :config-tokens) 200 + (getf ctx :time-tokens) 100) + (let ((pct (passepartout::context-usage-percentage))) + (is (integerp pct)) + (is (<= 0 pct 100))))) + +(test test-context-usage-percentage-empty-cache + "Contract 5: context-usage-percentage returns nil with no cache data." + (let ((saved-ctx (copy-list passepartout::*context-cache*))) + (unwind-protect + (progn + (setf (getf passepartout::*context-cache* :identity-tokens) nil + (getf passepartout::*context-cache* :tool-tokens) nil + (getf passepartout::*context-cache* :context-tokens) nil + (getf passepartout::*context-cache* :log-tokens) nil + (getf passepartout::*context-cache* :config-tokens) nil + (getf passepartout::*context-cache* :time-tokens) nil) + (is (null (passepartout::context-usage-percentage)))) + (setf passepartout::*context-cache* saved-ctx)))) +#+end_src