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

v0.8.0: Information Radiator, Command Palette, TrueColor Themes, Setup Wizard

Browse Source 
- Sidebar: permanent 42-col panel with 7 data panels (Gate Trace, Focus,
  Rules, Context gauge, Files, Cost, Protection); 4-window Croatoan layout
  at >=120 cols, toggle via Ctrl+X+B
- Command palette: Ctrl+P overlay with fuzzy-filtered categorized items,
  keyboard navigation, Enter to execute; view-palette rendering
- TrueColor themes: 4 new presets (nord, tokyonight, catppuccin, monokai)
  with 27 hex keys via theme-hex-to-rgb
- Setup wizard: Ctrl+\ /setup 4-step overlay (provider, key, memory, save)
  writing .env with in-TUI rendering
- Daemon enrichment: dispatcher block counts, cost session summary,
  modified files tracking, context usage percentage
- Daemon fixes: fboundp guards for count-tokens/provider-token-cost,
  tool registry save/restore in safety tests, SELF_BUILD_MODE cleanup
- 139 tests pass across all suites (0 failures)
This commit is contained in:
Amr Gharbeia
2026-05-09 15:00:14 -04:00
parent d77d41f3a8
commit 2ac87b626a
17 changed files with 2916 additions and 528 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
docs/ROADMAP.org
View File

@@ -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) - System message on activation, ~$EDITOR~ / ~$VISUAL~ / ~vi~ fallback (runtime)
- 1 TDD test passes (model-level) - 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 *** DONE Pads for chat scrolling — Page Up/Down by 10 lines
:LOGBOOK: :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. 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: :PROPERTIES:
:ID: id-v070-sidebar :ID: id-v070-sidebar
:CREATED: [2026-05-08 Fri] :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). 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: :PROPERTIES:
:ID: id-v070-sidebar-overlay :ID: id-v070-sidebar-overlay
:CREATED: [2026-05-08 Fri] :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. 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: :PROPERTIES:
:ID: id-v070-command-palette :ID: id-v070-command-palette
:CREATED: [2026-05-08 Fri] :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 - 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. - 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: :PROPERTIES:
:ID: id-v070-themes :ID: id-v070-themes
:CREATED: [2026-05-08 Fri] :CREATED: [2026-05-08 Fri]

783
lisp/channel-tui-main.lisp
View File

@@ -6,12 +6,81 @@
;; so the cond below can use eq. ;; so the cond below can use eq.
(let* ((raw (car args)) (let* ((raw (car args))
(ch (if (and (integerp raw) (> raw 255)) (ch (if (and (integerp raw) (> raw 255))
(let* ((k (code-key raw)) (or (let* ((k (code-key raw))
(name (and k (key-name k)))) (name (and k (key-name k))))
(or name raw)) 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))) raw)))
(cond (cond
;; v0.7.1: Esc — interrupt streaming ;; 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)) ((and (eql ch 27) (st :streaming-text))
(send-daemon (list :type :event :payload '(:action :cancel-stream))) (send-daemon (list :type :event :payload '(:action :cancel-stream)))
(when (> (length (st :messages)) 0) (when (> (length (st :messages)) 0)
@@ -105,8 +174,44 @@
(setf (st :cursor-pos) 0)) (setf (st :cursor-pos) 0))
((eql ch 5) ; Ctrl+E — end ((eql ch 5) ; Ctrl+E — end
(setf (st :cursor-pos) (length (st :input-buffer)))) (setf (st :cursor-pos) (length (st :input-buffer))))
((eql ch 12) ; Ctrl+L — redraw ((eql ch 12) ; Ctrl+L — redraw
(setf (st :dirty) (list t t t))) (setf (st :dirty) (list t t t)))
((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
((eql ch 6) ; v0.7.2 Ctrl+F — message search
(add-msg :system "Use /search <query> to find messages"))
((eql ch 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 ((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string))) (when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit."))) (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
@@ -217,80 +322,49 @@
(subseq (or (getf info :hash) "(none)") 0 16))) (subseq (or (getf info :hash) "(none)") 0 16)))
(add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system (format nil "Node ~a not found" node-id))))
(add-msg :system "Memory audit not available"))) (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") ((string-equal text "/tags")
(let ((cats passepartout::*tag-categories*) (let ((cats passepartout::*tag-categories*))
(counts passepartout::*tag-trigger-count*))
(if cats (if cats
(dolist (entry cats) (dolist (entry cats)
(let* ((tag (car entry)) (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(sev (cdr entry))
(n (gethash (string-downcase tag) counts 0)))
(add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n))))
(add-msg :system "No tags configured. Set TAG_CATEGORIES env var.")))) (add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
;; /context command — section breakdown with token estimates ;; /context command — context visibility
((string-equal text "/context") ((string-equal text "/context")
(let* ((msg-count (length (st :messages))) (let* ((msg-count (length (st :messages)))
(focus (or (st :foveal-id) "none")) (focus (or (st :foveal-id) "none"))
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4))) (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
(tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*) (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
(floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4) (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
50)) 50))
(log-tokens (min 4000 (floor (* msg-count 60) 4))) (log-tokens (min 4000 (floor (* msg-count 60) 4)))
;; rough estimate: TIME, CONTEXT overhead (overhead-tokens 200)
(overhead-tokens 200) (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
(total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) (total-limit 8192)
(total-limit 8192) (pct-used (floor (* 100 total-est) total-limit)))
(pct-used (floor (* 100 total-est) total-limit)) (add-msg :system (format nil "Context: ~d msgs, focus=~a, ~d/~d tokens (~d%)"
(bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) msg-count focus total-est total-limit pct-used))
:initial-element #\#))) (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens))
(add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) (add-msg :system (format nil "LOGS ~5d tokens" log-tokens))
(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 "TOOLS ~5d tokens" tool-tokens)) (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens))))
(add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) ;; /context why <id> — debug node
(add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count))
(add-msg :system (format nil " [~a~a] ~d%"
bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used))
(when (> pct-used 80)
(add-msg :system "⚠ Context near limit — older messages may be dropped"))))
;; /context why <id> — debug node with full attributes
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
(let ((node-id (string-trim '(#\Space) (subseq text 13)))) (let ((node-id (string-trim '(#\Space) (subseq text 13))))
(if (fboundp 'passepartout::memory-object-get) (if (fboundp 'passepartout::memory-object-get)
(let ((obj (funcall 'passepartout::memory-object-get node-id))) (let ((obj (funcall 'passepartout::memory-object-get node-id)))
(if obj (if obj
(let ((attrs (passepartout::memory-object-attributes obj)) (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
(parent (passepartout::memory-object-parent-id obj)) node-id
(children (passepartout::memory-object-children obj)) (passepartout::memory-object-type obj)
(hash (or (passepartout::memory-object-hash obj) "(none)"))) (passepartout::memory-object-scope obj)
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" (passepartout::memory-object-version obj)))
node-id (add-msg :system (format nil "Node ~a not found" node-id))))
(passepartout::memory-object-type obj)
(passepartout::memory-object-scope obj)
(passepartout::memory-object-version obj)))
(when parent
(add-msg :system (format nil " parent: ~a" parent)))
(when children
(add-msg :system (format nil " children: ~d" (length children))))
(add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash)))))
(when attrs
(add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)")))))
(add-msg :system (format nil "Node ~a not found in memory" node-id))))
(add-msg :system "Memory not available")))) (add-msg :system "Memory not available"))))
;; /context dropped — estimate pruned nodes from budget ;; /context dropped — pruned nodes
((string-equal text "/context dropped") ((string-equal text "/context dropped")
(let* ((msg-count (length (st :messages))) (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)"))
(est-total (* msg-count 60))
(budget 8192)
(dropped-msgs (if (> est-total budget)
(floor (- est-total budget) 60)
0)))
(if (> dropped-msgs 0)
(add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)"
dropped-msgs (- est-total budget) budget
(floor (* 100 est-total) budget)))
(add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)"
est-total budget (floor (* 100 est-total) budget))))))
;; /search command — message search ;; /search command — message search
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search ")) ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
(let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8)))) (let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8))))
@@ -343,16 +417,16 @@
(add-msg :system "No snapshots available")))) (add-msg :system "No snapshots available"))))
;; /audit verify — memory integrity ;; /audit verify — memory integrity
((string-equal text "/audit verify") ((string-equal text "/audit verify")
(if (fboundp 'passepartout::audit-verify-hash) (let ((count 0) (hashed 0))
(let* ((result (funcall 'passepartout::audit-verify-hash)) (maphash (lambda (k v) (declare (ignore k))
(total (car result)) (when v
(missing (cdr result))) (incf count)
(add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" (when (passepartout::memory-object-hash v)
total missing (incf hashed))))
(length passepartout::*memory-snapshots*) passepartout::*memory-store*)
(zerop missing) (add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots"
(unless (zerop missing) missing)))) count hashed
(add-msg :system "Memory audit not available"))) (length passepartout::*memory-snapshots*)))))
;; /resume <n> — resume from snapshot ;; /resume <n> — resume from snapshot
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
(let* ((n-str (string-trim '(#\Space) (subseq text 8))) (let* ((n-str (string-trim '(#\Space) (subseq text 8)))
@@ -365,28 +439,23 @@
(add-msg :system "Usage: /resume <number>")))) (add-msg :system "Usage: /resume <number>"))))
;; /help <topic> — search user manual ;; /help <topic> — search user manual
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help "))
(let ((topic (string-trim '(#\Space) (subseq text 6))) (let* ((topic (string-trim '(#\Space) (subseq text 6)))
(sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) (results (self-help-lookup topic)))
(if sections (dolist (entry results)
(dolist (entry sections) (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(let* ((title (car entry)) (unless results
(content (cdr entry)) (add-msg :system (format nil "Topic '~a' not found in USER_MANUAL.org" topic)))))
(preview (if (> (length content) 300) ((string-equal text "/help")
(concatenate 'string (subseq content 0 297) "...") (add-msg :system "/undo Undo last operation")
content))) (add-msg :system "/redo Redo last operation")
(add-msg :system (format nil "~a: ~a" title preview)))) (add-msg :system "/why Show last gate trace")
(add-msg :system (format nil "No manual section found for '~a'" topic))))) (add-msg :system "/identity Edit IDENTITY.org")
((string-equal text "/help") (add-msg :system "/tags List tag severities")
(add-msg :system "/eval <expr> Evaluate Lisp") (add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/undo Undo last operation") (add-msg :system "/search <q> Search messages")
(add-msg :system "/redo Redo last operation") (add-msg :system "/context Show context summary")
(add-msg :system "/why Show last gate trace") (add-msg :system "/eval <expr> Evaluate Lisp")
(add-msg :system "/identity Edit IDENTITY.org") (add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/tags List tag severities")
(add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/search <q> Search messages")
(add-msg :system "/context Show context summary")
(add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/sessions Show snapshots") (add-msg :system "/sessions Show snapshots")
(add-msg :system "/resume <n> Resume from snapshot") (add-msg :system "/resume <n> Resume from snapshot")
(add-msg :system "/focus <proj> Set project context") (add-msg :system "/focus <proj> Set project context")
@@ -394,7 +463,12 @@
(add-msg :system "/help [topic] Show this help") (add-msg :system "/help [topic] Show this help")
(add-msg :system "\\ + Enter Multi-line input") (add-msg :system "\\ + Enter Multi-line input")
(add-msg :system "Ctrl+G Toggle gate trace")) (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") ((string-equal text "/theme")
(add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a" (add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
*tui-theme-current-name* *tui-theme-current-name*
@@ -562,14 +636,15 @@
(reverse (coerce (nth (st :input-hpos) h) 'list)) (reverse (coerce (nth (st :input-hpos) h) 'list))
nil)) nil))
(setf (st :dirty) (list nil nil t))))) (setf (st :dirty) (list nil nil t)))))
;; PageUp — scroll back by page (10 lines) ;; PageUp
((or (eq ch :ppage) (eql ch 339)) ((or (eq ch :ppage) (eql ch 339))
(let ((max-offset (max 0 (- (length (st :messages)) 1)))) (let ((page-size (max 10 (floor (length (st :messages)) 3))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) (setf (st :scroll-offset) (+ (st :scroll-offset) page-size)))
(setf (st :dirty) (list nil t nil))) (setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page ;; PageDown
((or (eq ch :npage) (eql ch 338)) ((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))) (setf (st :dirty) (list nil t nil)))
;; Printable ;; Printable
(t (t
@@ -581,6 +656,232 @@
(input-insert-char chr) (input-insert-char chr)
(setf (st :dirty) (list nil nil t)))))))) (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 <project>")))
(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 <query> 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 <node-id>")))
(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 <expr>")))
(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 ;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun resolve-hitl-panel (decision) (defun resolve-hitl-panel (decision)
"Mark the most recent HITL panel message as resolved with 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 (getf (aref (st :messages) idx) :content) new-text)
(setf (st :dirty) (list nil t nil))) (setf (st :dirty) (list nil t nil)))
(return-from on-daemon-msg nil)))) (return-from on-daemon-msg nil))))
(when rule-count (setf (st :rule-count) rule-count)) (when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id)) (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 (cond
(text (setf (st :busy) nil) (text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace)) (add-msg :agent text :gate-trace gate-trace))
@@ -784,17 +1090,19 @@
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil) (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(let* ((h (or (height scr) 24)) (let* ((h (or (height scr) 24))
(w (or (width scr) 80)) (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)) (ch (- h 5))
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1)) (sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1)) (cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
(swank-port (or (ignore-errors (iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
(parse-integer (uiop:getenv "TUI_SWANK_PORT"))) (swank-port (or (ignore-errors
4006))) (parse-integer (uiop:getenv "TUI_SWANK_PORT")))
4006)))
(setf (function-keys-enabled-p iw) t (setf (function-keys-enabled-p iw) t
(input-blocking iw) nil (input-blocking iw) nil
(st :dirty) (list t t t) (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) (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
(connect-daemon) (connect-daemon)
(when (> swank-port 0) (when (> swank-port 0)
@@ -807,44 +1115,103 @@
(format nil "* Swank ~d M-x slime-connect *" swank-port))) (format nil "* Swank ~d M-x slime-connect *" swank-port)))
(error () (error ()
(add-msg :system "* Swank unavailable *")))) (add-msg :system "* Swank unavailable *"))))
;; Initial render before the main loop — otherwise the screen stays (flet ((recreate-windows (scr-width scr-height)
;; blank until the first keystroke (get-char blocks). (let* ((new-w scr-width)
(redraw sw cw ch iw) (new-h scr-height)
(refresh scr) (has-sidebar (and (>= new-w 120) (st :sidebar-visible)))
(loop while (st :running) do (new-sidebar-w (when has-sidebar
(dolist (ev (drain-queue)) (make-instance 'window :height (- new-h 5)
(cond :width 42 :y 3 :x (- new-w 44))))
((eq (getf ev :type) :daemon) (new-content-w (if new-sidebar-w (- new-w 44) (- new-w 2)))
(on-daemon-msg (getf ev :payload))) (new-ch (- new-h 5)))
((eq (getf ev :type) :disconnected) (setq sw (make-instance 'window :height 3 :width new-content-w :y 0 :x 1)
(setf (st :connected) nil ch new-ch
(st :busy) nil) cw (make-instance 'window :height new-ch :width new-content-w :y 3 :x 1)
(add-msg :system "* Connection lost — type /reconnect to retry *")))) iw (make-instance 'window :height 1 :width new-content-w :y (- new-h 1) :x 1)
(let ((ch (get-char iw))) sidebar-w new-sidebar-w
(cond w new-w
((or (not ch) (equal ch -1)) nil) h new-h)
;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses) (setf (function-keys-enabled-p iw) t
((eql ch 410) (input-blocking iw) nil
(let* ((new-h (or (height scr) 24)) (st :dirty) (list t t t)
(new-w (or (width scr) 80)) (st :sw) sw (st :cw) cw (st :iw) iw))))
(new-ch (- new-h 5))) (let ((initial-sidebar (and (>= w 120) (st :sidebar-visible))))
(setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1) (when initial-sidebar
ch new-ch (view-sidebar (or sidebar-w
cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1) (make-instance 'window :height (- h 5) :width 42
iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1) :y 3 :x (- w 44))))
w new-w (refresh (or sidebar-w
h new-h) (make-instance 'window :height (- h 5) :width 42
(setf (function-keys-enabled-p iw) t :y 3 :x (- w 44))))))
(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))))
(redraw sw cw ch iw) (redraw sw cw ch iw)
(refresh scr) (when sidebar-w
(sleep 0.03)) (view-sidebar sidebar-w)
(disconnect-daemon)))) (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) (eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t)) (ql:quickload :fiveam :silent t))
@@ -1320,3 +1687,115 @@
(setf (st :scroll-offset) 3) (setf (st :scroll-offset) 3)
(on-key :npage) (on-key :npage)
(fiveam:is (= 0 (st :scroll-offset)))) (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))))

71
lisp/channel-tui-state.lisp
View File

@@ -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" :tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496"
:scroll-indicator "#2aa198" :border "#657b83" :background "#002b36" :scroll-indicator "#2aa198" :border "#657b83" :background "#002b36"
:rule-count "#2aa198" :focus-map "#b58900" :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 <name> loads one into *tui-theme*.") "Named theme presets. /theme <name> loads one into *tui-theme*.")
(defvar *tui-theme-current-name* :dark (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." "Returns the Croatoan color for a semantic role."
(or (getf *tui-theme* role) :white)) (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 st (key) (getf *state* key))
(defun (setf st) (val key) (setf (getf *state* key) val)) (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 :collapsed-gates nil ; v0.7.2
:search-mode nil :search-query "" ; v0.7.2 :search-mode nil :search-query "" ; v0.7.2
:search-matches nil :search-match-idx 0 :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)))) :dirty (list nil nil nil))))
(defun now () (defun now ()

240
lisp/channel-tui-view.lisp
View File

@@ -296,9 +296,9 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(:approval :gate-approval) (:approval :gate-approval)
(t :dim))) (t :dim)))
(prefix (case result (prefix (case result
(:passed " \u2713 ") (:passed " ✓ ")
(:blocked " \u2717 ") (:blocked " ✗ ")
(:approval " \u2192 ") (:approval " → ")
(t " ? "))) (t " ? ")))
(text (format nil "~a~a~@[~a~]~@[~a~]" (text (format nil "~a~a~@[~a~]~@[~a~]"
prefix name 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))) (push (cons text (list :fgcolor color)) lines)))
(nreverse 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) (eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t)) (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) (passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates))) (let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg)))) (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)))))

13
lisp/core-act.lisp
View File

@@ -32,6 +32,19 @@
0)) 0))
(setf (getf (getf action :payload) :foveal-id) (setf (getf (getf action :payload) :foveal-id)
(getf context :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)) (format stream "~a" (frame-message action))
(finish-output stream)))))) (finish-output stream))))))

30
lisp/cost-tracker.lisp
View File

@@ -9,8 +9,12 @@
(defun cost-track-call (provider prompt-text &optional response-text) (defun cost-track-call (provider prompt-text &optional response-text)
"Compute and accumulate the cost of a single LLM call. "Compute and accumulate the cost of a single LLM call.
Returns the cost of this call in USD." Returns the cost of this call in USD."
(let* ((input-tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) (let* ((input-tokens (if (fboundp 'count-tokens)
(output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0)) (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)) (total-tokens (+ input-tokens output-tokens))
(cost (provider-token-cost provider total-tokens))) (cost (provider-token-cost provider total-tokens)))
(bordeaux-threads:with-lock-held (*session-cost-lock*) (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*) (bordeaux-threads:with-lock-held (*session-cost-lock*)
(getf *session-cost* :by-provider))) (getf *session-cost* :by-provider)))
(defun cost-session-summary ()
"Returns plist (:total <float> :calls <int> :by-provider <alist>)."
(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 () (defun cost-session-reset ()
"Zeroes the session cost accumulator." "Zeroes the session cost accumulator."
(bordeaux-threads:with-lock-held (*session-cost-lock*) (bordeaux-threads:with-lock-held (*session-cost-lock*)
(setf (getf *session-cost* :total) 0.0) (setf (getf *session-cost* :total) 0.0)
(setf (getf *session-cost* :calls) 0) (setf (getf *session-cost* :calls) 0)
(setf (getf *session-cost* :by-provider) nil) (setf (getf *session-cost* :by-provider) nil)))
(log-message "COST TRACKER: Session cost reset.")))
(defun cost-format-budget-status (&optional (daily-budget nil)) (defun cost-format-budget-status (&optional (daily-budget nil))
"Returns a string for the TUI status bar showing session cost. "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) (cost-session-reset)
(let ((cost (cost-track-call :deepseek "test"))) (let ((cost (cost-track-call :deepseek "test")))
(is (> cost 0.0)))) (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)))))

86
lisp/programming-tools.lisp
View File

@@ -101,12 +101,13 @@
(content (getf args :content))) (content (getf args :content)))
(unless (and filepath content) (unless (and filepath content)
(return (list :status :error :message "write-file requires :filepath and :content"))) (return (list :status :error :message "write-file requires :filepath and :content")))
(handler-case (handler-case
(progn (progn
(tools-write-file filepath content) (tools-write-file filepath content)
(verify-write filepath content) (verify-write filepath content)
(list :status :success (tool-register-modified filepath :new-content content)
:content (format nil "Written ~d bytes to ~a" (length content) filepath))) (list :status :success
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
(error (c) (list :status :error :message (format nil "~a" c)))))))) (error (c) (list :status :error :message (format nil "~a" c))))))))
(def-cognitive-tool list-directory (def-cognitive-tool list-directory
@@ -240,12 +241,13 @@
(let ((content (uiop:read-file-string filepath))) (let ((content (uiop:read-file-string filepath)))
(let ((pos (search old-text content))) (let ((pos (search old-text content)))
(if pos (if pos
(let ((new-content (concatenate 'string (let ((new-content (concatenate 'string
(subseq content 0 pos) (subseq content 0 pos)
new-text new-text
(subseq content (+ pos (length old-text)))))) (subseq content (+ pos (length old-text))))))
(tools-write-file filepath new-content) (tools-write-file filepath new-content)
(list :status :success (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))) :content (format nil "Replaced at position ~d in ~a" pos filepath)))
(list :status :error :message (format nil "Text not found in ~a" filepath))))) (list :status :error :message (format nil "Text not found in ~a" filepath)))))
(error (c) (list :status :error :message (format nil "~a" c)))))))) (error (c) (list :status :error :message (format nil "~a" c))))))))
@@ -452,6 +454,38 @@
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal)) (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) (eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t)) (ql:quickload :fiveam :silent t))
@@ -623,3 +657,31 @@
"org-modify-file returns error without required params." "org-modify-file returns error without required params."
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y"))) (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
(is (eq (getf result :status) :error)))) (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))))

228
lisp/security-dispatcher.lisp
View File

@@ -290,54 +290,60 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
action) action)
;; Vector 1: Lisp syntax validation (block bad lisp writes) ;; Vector 1: Lisp syntax validation (block bad lisp writes)
((and lisp-valid (eq (getf lisp-valid :status) :error)) ((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)) (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
(list :type :LOG (dispatcher-block-record :lisp-validation)
:payload (list :level :error (list :type :LOG
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) :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 ;; Vector 2: File read to a protected secret path
((and filepath (dispatcher-check-secret-path filepath)) ((and filepath (dispatcher-check-secret-path filepath))
(let ((matched (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) (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
(list :type :LOG (dispatcher-block-record :secret-path)
:payload (list :level :error (list :type :LOG
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) :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 ;; Vector 2b: Self-build safety — core file writes require HITL approval
((and filepath content ((and filepath content
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true") (string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
(dispatcher-check-core-path filepath)) (dispatcher-check-core-path filepath))
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
(list :type :EVENT :level :approval-required (dispatcher-block-record :self-build-core)
:payload (list :sensor :approval-required :action action (list :type :EVENT :level :approval-required
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) :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 ;; Vector 3: Content contains secret patterns
((and text (dispatcher-exposure-scan text)) ((and text (dispatcher-exposure-scan text))
(let ((matched (dispatcher-exposure-scan text))) (let ((matched (dispatcher-exposure-scan text)))
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
(list :type :LOG (dispatcher-block-record :secret-content)
:payload (list :level :error (list :type :LOG
:text "Action blocked: Content contains potential secret exposure.")))) :payload (list :level :error
:text "Action blocked: Content contains potential secret exposure."))))
;; Vector 4: Content contains vault secrets ;; Vector 4: Content contains vault secrets
((and text (dispatcher-vault-scan text)) ((and text (dispatcher-vault-scan text))
(let ((secret-name (dispatcher-vault-scan text))) (let ((secret-name (dispatcher-vault-scan text)))
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(list :type :LOG (dispatcher-block-record :vault-secrets)
:payload (list :level :error (list :type :LOG
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) :payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 5: Privacy-tagged content (severity tiers) ;; Vector 5: Privacy-tagged content (severity tiers)
((and tags (fboundp 'dispatcher-privacy-severity)) ((and tags (fboundp 'dispatcher-privacy-severity))
(let ((severity (dispatcher-privacy-severity tags))) (let ((severity (dispatcher-privacy-severity tags)))
(cond (cond
((eq severity :block) ((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(list :type :LOG (dispatcher-block-record :privacy-tags)
:payload (list :level :error (list :type :LOG
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) :payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :warn) ((eq severity :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags) (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action) 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) (log-message "PRIVACY: @tag ~a (logged)" tags)
action)))) action))))
;; Vector 6: Text leaks privacy tag names ;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text)) ((and text (dispatcher-check-text-for-privacy text))
(log-message "PRIVACY WARNING: Text may contain leaked private content") (log-message "PRIVACY WARNING: Text may contain leaked private content")
(list :type :LOG (dispatcher-block-record :privacy-text)
:payload (list :level :warn (list :type :LOG
:text "Action blocked: Text may reference private content."))) :payload (list :level :warn
:text "Action blocked: Text may reference private content.")))
;; Vector 7: Shell destructive/injection patterns ;; Vector 7: Shell destructive/injection patterns
((and cmd (dispatcher-check-shell-safety cmd)) ((and cmd (dispatcher-check-shell-safety cmd))
(let ((matched (dispatcher-check-shell-safety cmd))) (let ((matched (dispatcher-check-shell-safety cmd)))
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
(list :type :LOG (dispatcher-block-record :shell-safety)
:payload (list :level :error (list :type :LOG
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) :payload (list :level :error
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
;; Vector 8: Network exfiltration ;; Vector 8: Network exfiltration
((and (or (eq target :shell) ((and (or (eq target :shell)
(and (eq target :tool) (equal (proto-get payload :tool) "shell"))) (and (eq target :tool) (equal (proto-get payload :tool) "shell")))
(dispatcher-check-network-exfil cmd)) (dispatcher-check-network-exfil cmd))
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.") (log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
(list :type :EVENT :level :approval-required (dispatcher-block-record :network-exfil)
:payload (list :sensor :approval-required :action action))) (list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action)))
;; Vector 8: High-impact action approval ;; Vector 8b: High-impact action approval
((or (member target '(:shell)) ((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) (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 :emacs) (eq (proto-get payload :action) :eval))
(and (eq target :system) (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)) (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))) (dispatcher-block-record :high-impact-approval)
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
(t action)))) (t action))))
(defun dispatcher-approvals-process () (defun dispatcher-approvals-process ()
@@ -496,6 +506,25 @@ Recognized formats:
:trigger (lambda (ctx) (declare (ignore ctx)) t) :trigger (lambda (ctx) (declare (ignore ctx)) t)
:deterministic #'dispatcher-gate) :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 <N> :by-gate ((<gate> . <count>) ...))."
(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) (eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t)) (ql:quickload :fiveam :silent t))
@@ -594,7 +623,7 @@ Recognized formats:
(is (eq :block (passepartout::tag-category-severity "@personal"))) (is (eq :block (passepartout::tag-category-severity "@personal")))
(is (eq :warn (passepartout::tag-category-severity "@draft"))) (is (eq :warn (passepartout::tag-category-severity "@draft")))
(is (eq :log (passepartout::tag-category-severity "@review")))) (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 (test test-tag-category-severity-unknown
"Contract v0.7.2: unknown tag returns nil." "Contract v0.7.2: unknown tag returns nil."
@@ -661,20 +690,51 @@ Recognized formats:
(test test-safe-tool-write-still-checked (test test-safe-tool-write-still-checked
"Contract v0.7.2: write tools still go through full dispatcher check." "Contract v0.7.2: write tools still go through full dispatcher check."
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
(passepartout::make-cognitive-tool :name "write-file" (setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
:description "File writer" (passepartout::make-cognitive-tool :name "write-file"
:parameters nil :description "File writer"
:guard nil :parameters nil
:body nil :guard nil
:read-only-p nil)) :body nil
(unwind-protect :read-only-p nil))
(progn (unwind-protect
(setf (uiop:getenv "SELF_BUILD_MODE") "true") (progn
(let* ((action '(:TYPE :REQUEST :TARGET :tool (setf (uiop:getenv "SELF_BUILD_MODE") "true")
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) (let* ((action '(:TYPE :REQUEST :TARGET :tool
(result (dispatcher-check action nil))) :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
(setf (uiop:getenv "SELF_BUILD_MODE") "false") (result (dispatcher-check action nil)))
(is (eq :approval-required (getf result :level))) (is (eq :approval-required (getf result :level)))
(is (search "HITL" (getf (getf result :payload) :message))))) (is (search "HITL" (getf (getf result :payload) :message)))))
(remhash "write-file" passepartout::*cognitive-tool-registry*))) (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)))))

56
lisp/token-economics.lisp
View File

@@ -3,7 +3,9 @@
(defvar *prompt-prefix-cache* (cons nil "") (defvar *prompt-prefix-cache* (cons nil "")
"Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.") "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.") "Context assembly cache: metadata + last rendered context string.")
(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt) (defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt)
@@ -64,7 +66,9 @@ with trimmed sections."
(ignore-errors (ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384))) 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) (total-tokens (p c l u m)
(+ (ct p) (+ (ct p)
(if c (ct c) 0) (if c (ct c) 0)
@@ -102,6 +106,22 @@ with trimmed sections."
(getf *context-cache* :memory-timestamp) 0 (getf *context-cache* :memory-timestamp) 0
(getf *context-cache* :rendered) "")) (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) (eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t)) (ql:quickload :fiveam :silent t))
@@ -200,3 +220,35 @@ with trimmed sections."
(is (null (car passepartout::*prompt-prefix-cache*))) (is (null (car passepartout::*prompt-prefix-cache*)))
(is (string= "" (cdr passepartout::*prompt-prefix-cache*))) (is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
(is (string= "" (getf passepartout::*context-cache* :rendered)))) (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))))

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

@@ -5,6 +5,62 @@
Event handlers + daemon I/O + main loop. 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 ** Contract
1. (on-key ch): dispatches key presses: Enter triggers send (extracts 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 4. (tui-main): the main loop — connects to daemon, initializes
Croatoan windows, optionally starts Swank REPL, runs Croatoan windows, optionally starts Swank REPL, runs
render/input event loop at ~30fps. 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 <str> :prompt <str> :validate <fn> :next <fn>)~.
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 ** Event Handlers
#+begin_src lisp #+begin_src lisp
@@ -40,12 +113,81 @@ Event handlers + daemon I/O + main loop.
;; so the cond below can use eq. ;; so the cond below can use eq.
(let* ((raw (car args)) (let* ((raw (car args))
(ch (if (and (integerp raw) (> raw 255)) (ch (if (and (integerp raw) (> raw 255))
(let* ((k (code-key raw)) (or (let* ((k (code-key raw))
(name (and k (key-name k)))) (name (and k (key-name k))))
(or name raw)) 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))) raw)))
(cond (cond
;; v0.7.1: Esc — interrupt streaming ;; 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)) ((and (eql ch 27) (st :streaming-text))
(send-daemon (list :type :event :payload '(:action :cancel-stream))) (send-daemon (list :type :event :payload '(:action :cancel-stream)))
(when (> (length (st :messages)) 0) (when (> (length (st :messages)) 0)
@@ -139,8 +281,44 @@ Event handlers + daemon I/O + main loop.
(setf (st :cursor-pos) 0)) (setf (st :cursor-pos) 0))
((eql ch 5) ; Ctrl+E — end ((eql ch 5) ; Ctrl+E — end
(setf (st :cursor-pos) (length (st :input-buffer)))) (setf (st :cursor-pos) (length (st :input-buffer))))
((eql ch 12) ; Ctrl+L — redraw ((eql ch 12) ; Ctrl+L — redraw
(setf (st :dirty) (list t t t))) (setf (st :dirty) (list t t t)))
((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
((eql ch 6) ; v0.7.2 Ctrl+F — message search
(add-msg :system "Use /search <query> to find messages"))
((eql ch 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 ((eql ch 4) ; Ctrl+D — quit on empty
(when (or (null (st :input-buffer)) (string= "" (input-string))) (when (or (null (st :input-buffer)) (string= "" (input-string)))
(add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit."))) (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
@@ -251,80 +429,49 @@ Event handlers + daemon I/O + main loop.
(subseq (or (getf info :hash) "(none)") 0 16))) (subseq (or (getf info :hash) "(none)") 0 16)))
(add-msg :system (format nil "Node ~a not found" node-id)))) (add-msg :system (format nil "Node ~a not found" node-id))))
(add-msg :system "Memory audit not available"))) (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") ((string-equal text "/tags")
(let ((cats passepartout::*tag-categories*) (let ((cats passepartout::*tag-categories*))
(counts passepartout::*tag-trigger-count*))
(if cats (if cats
(dolist (entry cats) (dolist (entry cats)
(let* ((tag (car entry)) (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(sev (cdr entry))
(n (gethash (string-downcase tag) counts 0)))
(add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n))))
(add-msg :system "No tags configured. Set TAG_CATEGORIES env var.")))) (add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
;; /context command — section breakdown with token estimates ;; /context command — context visibility
((string-equal text "/context") ((string-equal text "/context")
(let* ((msg-count (length (st :messages))) (let* ((msg-count (length (st :messages)))
(focus (or (st :foveal-id) "none")) (focus (or (st :foveal-id) "none"))
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4))) (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
(tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*) (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
(floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4) (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
50)) 50))
(log-tokens (min 4000 (floor (* msg-count 60) 4))) (log-tokens (min 4000 (floor (* msg-count 60) 4)))
;; rough estimate: TIME, CONTEXT overhead (overhead-tokens 200)
(overhead-tokens 200) (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
(total-est (+ id-tokens tool-tokens log-tokens overhead-tokens)) (total-limit 8192)
(total-limit 8192) (pct-used (floor (* 100 total-est) total-limit)))
(pct-used (floor (* 100 total-est) total-limit)) (add-msg :system (format nil "Context: ~d msgs, focus=~a, ~d/~d tokens (~d%)"
(bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10))) msg-count focus total-est total-limit pct-used))
:initial-element #\#))) (add-msg :system (format nil "IDENTITY ~5d tokens" id-tokens))
(add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used)) (add-msg :system (format nil "LOGS ~5d tokens" log-tokens))
(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 "TOOLS ~5d tokens" tool-tokens)) (add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens))))
(add-msg :system (format nil "TIME+CONFIG ~5d tokens" overhead-tokens)) ;; /context why <id> — debug node
(add-msg :system (format nil "LOGS ~5d tokens (~d msgs)" log-tokens msg-count))
(add-msg :system (format nil " [~a~a] ~d%"
bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used))
(when (> pct-used 80)
(add-msg :system "⚠ Context near limit — older messages may be dropped"))))
;; /context why <id> — debug node with full attributes
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
(let ((node-id (string-trim '(#\Space) (subseq text 13)))) (let ((node-id (string-trim '(#\Space) (subseq text 13))))
(if (fboundp 'passepartout::memory-object-get) (if (fboundp 'passepartout::memory-object-get)
(let ((obj (funcall 'passepartout::memory-object-get node-id))) (let ((obj (funcall 'passepartout::memory-object-get node-id)))
(if obj (if obj
(let ((attrs (passepartout::memory-object-attributes obj)) (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
(parent (passepartout::memory-object-parent-id obj)) node-id
(children (passepartout::memory-object-children obj)) (passepartout::memory-object-type obj)
(hash (or (passepartout::memory-object-hash obj) "(none)"))) (passepartout::memory-object-scope obj)
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" (passepartout::memory-object-version obj)))
node-id (add-msg :system (format nil "Node ~a not found" node-id))))
(passepartout::memory-object-type obj)
(passepartout::memory-object-scope obj)
(passepartout::memory-object-version obj)))
(when parent
(add-msg :system (format nil " parent: ~a" parent)))
(when children
(add-msg :system (format nil " children: ~d" (length children))))
(add-msg :system (format nil " hash: ~a" (subseq hash 0 (min 32 (length hash)))))
(when attrs
(add-msg :system (format nil " title: ~a" (or (getf attrs :TITLE) "(none)")))))
(add-msg :system (format nil "Node ~a not found in memory" node-id))))
(add-msg :system "Memory not available")))) (add-msg :system "Memory not available"))))
;; /context dropped — estimate pruned nodes from budget ;; /context dropped — pruned nodes
((string-equal text "/context dropped") ((string-equal text "/context dropped")
(let* ((msg-count (length (st :messages))) (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)"))
(est-total (* msg-count 60))
(budget 8192)
(dropped-msgs (if (> est-total budget)
(floor (- est-total budget) 60)
0)))
(if (> dropped-msgs 0)
(add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)"
dropped-msgs (- est-total budget) budget
(floor (* 100 est-total) budget)))
(add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)"
est-total budget (floor (* 100 est-total) budget))))))
;; /search command — message search ;; /search command — message search
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search ")) ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
(let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8)))) (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")))) (add-msg :system "No snapshots available"))))
;; /audit verify — memory integrity ;; /audit verify — memory integrity
((string-equal text "/audit verify") ((string-equal text "/audit verify")
(if (fboundp 'passepartout::audit-verify-hash) (let ((count 0) (hashed 0))
(let* ((result (funcall 'passepartout::audit-verify-hash)) (maphash (lambda (k v) (declare (ignore k))
(total (car result)) (when v
(missing (cdr result))) (incf count)
(add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]" (when (passepartout::memory-object-hash v)
total missing (incf hashed))))
(length passepartout::*memory-snapshots*) passepartout::*memory-store*)
(zerop missing) (add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots"
(unless (zerop missing) missing)))) count hashed
(add-msg :system "Memory audit not available"))) (length passepartout::*memory-snapshots*)))))
;; /resume <n> — resume from snapshot ;; /resume <n> — resume from snapshot
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume ")) ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
(let* ((n-str (string-trim '(#\Space) (subseq text 8))) (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 <number>")))) (add-msg :system "Usage: /resume <number>"))))
;; /help <topic> — search user manual ;; /help <topic> — search user manual
((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help ")) ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help "))
(let ((topic (string-trim '(#\Space) (subseq text 6))) (let* ((topic (string-trim '(#\Space) (subseq text 6)))
(sections (self-help-lookup (string-trim '(#\Space) (subseq text 6))))) (results (self-help-lookup topic)))
(if sections (dolist (entry results)
(dolist (entry sections) (add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
(let* ((title (car entry)) (unless results
(content (cdr entry)) (add-msg :system (format nil "Topic '~a' not found in USER_MANUAL.org" topic)))))
(preview (if (> (length content) 300) ((string-equal text "/help")
(concatenate 'string (subseq content 0 297) "...") (add-msg :system "/undo Undo last operation")
content))) (add-msg :system "/redo Redo last operation")
(add-msg :system (format nil "~a: ~a" title preview)))) (add-msg :system "/why Show last gate trace")
(add-msg :system (format nil "No manual section found for '~a'" topic))))) (add-msg :system "/identity Edit IDENTITY.org")
((string-equal text "/help") (add-msg :system "/tags List tag severities")
(add-msg :system "/eval <expr> Evaluate Lisp") (add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/undo Undo last operation") (add-msg :system "/search <q> Search messages")
(add-msg :system "/redo Redo last operation") (add-msg :system "/context Show context summary")
(add-msg :system "/why Show last gate trace") (add-msg :system "/eval <expr> Evaluate Lisp")
(add-msg :system "/identity Edit IDENTITY.org") (add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/tags List tag severities")
(add-msg :system "/audit <id> Inspect memory object")
(add-msg :system "/search <q> Search messages")
(add-msg :system "/context Show context summary")
(add-msg :system "/rewind <n> Rewind to snapshot N")
(add-msg :system "/sessions Show snapshots") (add-msg :system "/sessions Show snapshots")
(add-msg :system "/resume <n> Resume from snapshot") (add-msg :system "/resume <n> Resume from snapshot")
(add-msg :system "/focus <proj> Set project context") (add-msg :system "/focus <proj> 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 "/help [topic] Show this help")
(add-msg :system "\\ + Enter Multi-line input") (add-msg :system "\\ + Enter Multi-line input")
(add-msg :system "Ctrl+G Toggle gate trace")) (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") ((string-equal text "/theme")
(add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a" (add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
*tui-theme-current-name* *tui-theme-current-name*
@@ -596,14 +743,15 @@ Event handlers + daemon I/O + main loop.
(reverse (coerce (nth (st :input-hpos) h) 'list)) (reverse (coerce (nth (st :input-hpos) h) 'list))
nil)) nil))
(setf (st :dirty) (list nil nil t))))) (setf (st :dirty) (list nil nil t)))))
;; PageUp — scroll back by page (10 lines) ;; PageUp
((or (eq ch :ppage) (eql ch 339)) ((or (eq ch :ppage) (eql ch 339))
(let ((max-offset (max 0 (- (length (st :messages)) 1)))) (let ((page-size (max 10 (floor (length (st :messages)) 3))))
(setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) (setf (st :scroll-offset) (+ (st :scroll-offset) page-size)))
(setf (st :dirty) (list nil t nil))) (setf (st :dirty) (list nil t nil)))
;; PageDown — scroll forward by page ;; PageDown
((or (eq ch :npage) (eql ch 338)) ((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))) (setf (st :dirty) (list nil t nil)))
;; Printable ;; Printable
(t (t
@@ -615,6 +763,235 @@ Event handlers + daemon I/O + main loop.
(input-insert-char chr) (input-insert-char chr)
(setf (st :dirty) (list nil nil t)))))))) (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 <project>")))
(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 <query> 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 <node-id>")))
(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 <expr>")))
(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 ;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
(defun resolve-hitl-panel (decision) (defun resolve-hitl-panel (decision)
"Mark the most recent HITL panel message as resolved with 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 (getf (aref (st :messages) idx) :content) new-text)
(setf (st :dirty) (list nil t nil))) (setf (st :dirty) (list nil t nil)))
(return-from on-daemon-msg nil)))) (return-from on-daemon-msg nil))))
(when rule-count (setf (st :rule-count) rule-count)) (when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id)) (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 (cond
(text (setf (st :busy) nil) (text (setf (st :busy) nil)
(add-msg :agent text :gate-trace gate-trace)) (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) (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
(let* ((h (or (height scr) 24)) (let* ((h (or (height scr) 24))
(w (or (width scr) 80)) (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)) (ch (- h 5))
(cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1)) (sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
(iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1)) (cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
(swank-port (or (ignore-errors (iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
(parse-integer (uiop:getenv "TUI_SWANK_PORT"))) (swank-port (or (ignore-errors
4006))) (parse-integer (uiop:getenv "TUI_SWANK_PORT")))
4006)))
(setf (function-keys-enabled-p iw) t (setf (function-keys-enabled-p iw) t
(input-blocking iw) nil (input-blocking iw) nil
(st :dirty) (list t t t) (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) (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
(connect-daemon) (connect-daemon)
(when (> swank-port 0) (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))) (format nil "* Swank ~d M-x slime-connect *" swank-port)))
(error () (error ()
(add-msg :system "* Swank unavailable *")))) (add-msg :system "* Swank unavailable *"))))
;; Initial render before the main loop — otherwise the screen stays (flet ((recreate-windows (scr-width scr-height)
;; blank until the first keystroke (get-char blocks). (let* ((new-w scr-width)
(redraw sw cw ch iw) (new-h scr-height)
(refresh scr) (has-sidebar (and (>= new-w 120) (st :sidebar-visible)))
(loop while (st :running) do (new-sidebar-w (when has-sidebar
(dolist (ev (drain-queue)) (make-instance 'window :height (- new-h 5)
(cond :width 42 :y 3 :x (- new-w 44))))
((eq (getf ev :type) :daemon) (new-content-w (if new-sidebar-w (- new-w 44) (- new-w 2)))
(on-daemon-msg (getf ev :payload))) (new-ch (- new-h 5)))
((eq (getf ev :type) :disconnected) (setq sw (make-instance 'window :height 3 :width new-content-w :y 0 :x 1)
(setf (st :connected) nil ch new-ch
(st :busy) nil) cw (make-instance 'window :height new-ch :width new-content-w :y 3 :x 1)
(add-msg :system "* Connection lost — type /reconnect to retry *")))) iw (make-instance 'window :height 1 :width new-content-w :y (- new-h 1) :x 1)
(let ((ch (get-char iw))) sidebar-w new-sidebar-w
(cond w new-w
((or (not ch) (equal ch -1)) nil) h new-h)
;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses) (setf (function-keys-enabled-p iw) t
((eql ch 410) (input-blocking iw) nil
(let* ((new-h (or (height scr) 24)) (st :dirty) (list t t t)
(new-w (or (width scr) 80)) (st :sw) sw (st :cw) cw (st :iw) iw))))
(new-ch (- new-h 5))) (let ((initial-sidebar (and (>= w 120) (st :sidebar-visible))))
(setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1) (when initial-sidebar
ch new-ch (view-sidebar (or sidebar-w
cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1) (make-instance 'window :height (- h 5) :width 42
iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1) :y 3 :x (- w 44))))
w new-w (refresh (or sidebar-w
h new-h) (make-instance 'window :height (- h 5) :width 42
(setf (function-keys-enabled-p iw) t :y 3 :x (- w 44))))))
(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))))
(redraw sw cw ch iw) (redraw sw cw ch iw)
(refresh scr) (when sidebar-w
(sleep 0.03)) (view-sidebar sidebar-w)
(disconnect-daemon)))) (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 #+end_src
@@ -1368,3 +1811,119 @@ Event handlers + daemon I/O + main loop.
(on-key :npage) (on-key :npage)
(fiveam:is (= 0 (st :scroll-offset)))) (fiveam:is (= 0 (st :scroll-offset))))
#+end_src #+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

143
org/channel-tui-state.org
View File

@@ -6,6 +6,66 @@
The TUI state is a single plist accessed via ~st~ / ~(setf st)~. The TUI state is a single plist accessed via ~st~ / ~(setf st)~.
All state mutation flows through event handlers in the controller. 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 ** Contract
1. (init-state): returns a fresh state plist with ~:msgs~ list, 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). and optional gate-trace from the daemon (v0.4.0).
3. (queue-event ev): thread-safely enqueues an event for the 3. (queue-event ev): thread-safely enqueues an event for the
reader loop. (drain-queue) returns and clears the queue. 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 ** Package + State
#+begin_src lisp #+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" :tool-running "#d33682" :tool-success "#859900" :tool-failure "#dc322f" :tool-output "#839496"
:scroll-indicator "#2aa198" :border "#657b83" :background "#002b36" :scroll-indicator "#2aa198" :border "#657b83" :background "#002b36"
:rule-count "#2aa198" :focus-map "#b58900" :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 <name> loads one into *tui-theme*.") "Named theme presets. /theme <name> loads one into *tui-theme*.")
(defvar *tui-theme-current-name* :dark (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." "Returns the Croatoan color for a semantic role."
(or (getf *tui-theme* role) :white)) (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 st (key) (getf *state* key))
(defun (setf st) (val key) (setf (getf *state* key) val)) (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 :collapsed-gates nil ; v0.7.2
:search-mode nil :search-query "" ; v0.7.2 :search-mode nil :search-query "" ; v0.7.2
:search-matches nil :search-match-idx 0 :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)))) :dirty (list nil nil nil))))
#+end_src #+end_src

346
org/channel-tui-view.org
View File

@@ -6,6 +6,89 @@
Pure render functions. Each takes a Croatoan window and current state. Pure render functions. Each takes a Croatoan window and current state.
State is read via ~(st :key)~ — no mutation here. 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 ** Contract
1. (view-status win): renders the status bar with connection info, 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). 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) 6. (view-status win): v0.7.0 — timestamp right-aligned at (- w 12)
on line 2, focus info at :x 1. No overlap. 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 ** Status Bar
@@ -356,9 +456,9 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(:approval :gate-approval) (:approval :gate-approval)
(t :dim))) (t :dim)))
(prefix (case result (prefix (case result
(:passed " \u2713 ") (:passed " ✓ ")
(:blocked " \u2717 ") (:blocked " ✗ ")
(:approval " \u2192 ") (:approval " → ")
(t " ? "))) (t " ? ")))
(text (format nil "~a~a~@[~a~]~@[~a~]" (text (format nil "~a~a~@[~a~]~@[~a~]"
prefix name prefix name
@@ -368,6 +468,198 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(nreverse lines))) (nreverse lines)))
#+end_src #+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 * Test Suite
#+begin_src lisp #+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute) (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))) (let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg)))) (is (null cg))))
#+end_src #+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

44
org/core-act.org
View File

@@ -30,7 +30,13 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
~action-dispatch~, sets ~:status :acted~, returns feedback. ~action-dispatch~, sets ~:status :acted~, returns feedback.
2. (act-gate signal): thin alias for ~loop-gate-act~. 2. (act-gate signal): thin alias for ~loop-gate-act~.
3. (action-dispatch approved signal): routes approved actions to 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 * Implementation
@@ -87,18 +93,44 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
0)) 0))
(setf (getf (getf action :payload) :foveal-id) (setf (getf (getf action :payload) :foveal-id)
(getf context :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)) (format stream "~a" (frame-message action))
(finish-output stream)))))) (finish-output stream))))))
#+end_src #+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: 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. - ~: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. - ~: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. - ~:gate-trace~ — already attached by ~cognitive-verify~, flows through the action plist unchanged. (v0.4.0)
#+end_src
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) ** Action Dispatch (action-dispatch)

51
org/cost-tracker.org
View File

@@ -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 heuristic from tokenizer.lisp). It persists across daemon restarts via
~*session-cost*~ in the memory store. ~*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 <float> :calls <int>
:by-provider <alist>)~. 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 ** Contract
1. (cost-track-call provider prompt-text response-text): compute and 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. 2. (cost-session-total): returns the current session's total cost.
3. (cost-session-reset): zeroes the session cost accumulator. 3. (cost-session-reset): zeroes the session cost accumulator.
4. (cost-format-budget-status total budget): returns a human-readable 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 <float> :calls <int> :by-provider <alist>)~ aggregating
all three session cost accessors. Consumed by the TUI actuator
for the sidebar Cost panel (v0.8.0).
* Implementation * 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) (defun cost-track-call (provider prompt-text &optional response-text)
"Compute and accumulate the cost of a single LLM call. "Compute and accumulate the cost of a single LLM call.
Returns the cost of this call in USD." Returns the cost of this call in USD."
(let* ((input-tokens (funcall (symbol-function 'count-tokens) (or prompt-text ""))) (let* ((input-tokens (if (fboundp 'count-tokens)
(output-tokens (if response-text (funcall (symbol-function 'count-tokens) response-text) 0)) (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)) (total-tokens (+ input-tokens output-tokens))
(cost (provider-token-cost provider total-tokens))) (cost (provider-token-cost provider total-tokens)))
(bordeaux-threads:with-lock-held (*session-cost-lock*) (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))) (getf *session-cost* :by-provider)))
#+end_src #+end_src
** Session summary (v0.8.0)
#+begin_src lisp
(defun cost-session-summary ()
"Returns plist (:total <float> :calls <int> :by-provider <alist>)."
(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 ** Session reset
#+begin_src lisp #+begin_src lisp
(defun cost-session-reset () (defun cost-session-reset ()
@@ -87,8 +117,7 @@ Returns the cost of this call in USD."
(bordeaux-threads:with-lock-held (*session-cost-lock*) (bordeaux-threads:with-lock-held (*session-cost-lock*)
(setf (getf *session-cost* :total) 0.0) (setf (getf *session-cost* :total) 0.0)
(setf (getf *session-cost* :calls) 0) (setf (getf *session-cost* :calls) 0)
(setf (getf *session-cost* :by-provider) nil) (setf (getf *session-cost* :by-provider) nil)))
(log-message "COST TRACKER: Session cost reset.")))
#+end_src #+end_src
** Budget status formatting ** Budget status formatting
@@ -186,4 +215,16 @@ LLM invocation to record the cost.
(cost-session-reset) (cost-session-reset)
(let ((cost (cost-track-call :deepseek "test"))) (let ((cost (cost-track-call :deepseek "test")))
(is (> cost 0.0)))) (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 #+end_src

118
org/programming-tools.org
View File

@@ -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~. 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. 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. 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 <s> :timestamp <unix>
:lines-added <n> :lines-removed <n>)~.
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 <string> :timestamp <unix>
:lines-added <int> :lines-removed <int>)~.
~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 * Implementation
@@ -156,12 +182,13 @@ Writes string content to a file, creating parent directories as needed.
(content (getf args :content))) (content (getf args :content)))
(unless (and filepath content) (unless (and filepath content)
(return (list :status :error :message "write-file requires :filepath and :content"))) (return (list :status :error :message "write-file requires :filepath and :content")))
(handler-case (handler-case
(progn (progn
(tools-write-file filepath content) (tools-write-file filepath content)
(verify-write filepath content) (verify-write filepath content)
(list :status :success (tool-register-modified filepath :new-content content)
:content (format nil "Written ~d bytes to ~a" (length content) filepath))) (list :status :success
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
(error (c) (list :status :error :message (format nil "~a" c)))))))) (error (c) (list :status :error :message (format nil "~a" c))))))))
#+end_src #+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 ((content (uiop:read-file-string filepath)))
(let ((pos (search old-text content))) (let ((pos (search old-text content)))
(if pos (if pos
(let ((new-content (concatenate 'string (let ((new-content (concatenate 'string
(subseq content 0 pos) (subseq content 0 pos)
new-text new-text
(subseq content (+ pos (length old-text)))))) (subseq content (+ pos (length old-text))))))
(tools-write-file filepath new-content) (tools-write-file filepath new-content)
(list :status :success (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))) :content (format nil "Replaced at position ~d in ~a" pos filepath)))
(list :status :error :message (format nil "Text not found in ~a" filepath))))) (list :status :error :message (format nil "Text not found in ~a" filepath)))))
(error (c) (list :status :error :message (format nil "~a" c)))))))) (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)) (defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
#+end_src #+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 * Test Suite
#+begin_src lisp #+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"))) (let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
(is (eq (getf result :status) :error)))) (is (eq (getf result :status) :error))))
#+end_src #+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

268
org/security-dispatcher.org
View File

@@ -47,12 +47,39 @@ The Dispatcher also handles the **Flight Plan** system: when a high-risk action
T if found, nil if invalid token. T if found, nil if invalid token.
9. (hitl-deny token): denies and removes a pending action. Returns T if 9. (hitl-deny token): denies and removes a pending action. Returns T if
found, nil if invalid. 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 <N> :by-gate ((<gate> . <count>) ...))~ of all blocked
actions this session.
** Boundaries ** Boundaries
- Does NOT handle the gate approval routing — that is ~core-reason.org~. - Does NOT handle the gate approval routing — that is ~core-reason.org~.
- Does NOT persist HITL tokens — they live in memory only. - 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 * Implementation
** Package Context ** Package Context
@@ -464,54 +491,60 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
action) action)
;; Vector 1: Lisp syntax validation (block bad lisp writes) ;; Vector 1: Lisp syntax validation (block bad lisp writes)
((and lisp-valid (eq (getf lisp-valid :status) :error)) ((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)) (log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
(list :type :LOG (dispatcher-block-record :lisp-validation)
:payload (list :level :error (list :type :LOG
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason))))) :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 ;; Vector 2: File read to a protected secret path
((and filepath (dispatcher-check-secret-path filepath)) ((and filepath (dispatcher-check-secret-path filepath))
(let ((matched (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) (log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
(list :type :LOG (dispatcher-block-record :secret-path)
:payload (list :level :error (list :type :LOG
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath))))) :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 ;; Vector 2b: Self-build safety — core file writes require HITL approval
((and filepath content ((and filepath content
(string-equal (uiop:getenv "SELF_BUILD_MODE") "true") (string-equal (uiop:getenv "SELF_BUILD_MODE") "true")
(dispatcher-check-core-path filepath)) (dispatcher-check-core-path filepath))
(log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath) (log-message "SELF-BUILD: Core file write to '~a' requires approval" filepath)
(list :type :EVENT :level :approval-required (dispatcher-block-record :self-build-core)
:payload (list :sensor :approval-required :action action (list :type :EVENT :level :approval-required
:message (format nil "Core file write blocked: '~a' requires HITL approval via Flight Plan." filepath)))) :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 ;; Vector 3: Content contains secret patterns
((and text (dispatcher-exposure-scan text)) ((and text (dispatcher-exposure-scan text))
(let ((matched (dispatcher-exposure-scan text))) (let ((matched (dispatcher-exposure-scan text)))
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched) (log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
(list :type :LOG (dispatcher-block-record :secret-content)
:payload (list :level :error (list :type :LOG
:text "Action blocked: Content contains potential secret exposure.")))) :payload (list :level :error
:text "Action blocked: Content contains potential secret exposure."))))
;; Vector 4: Content contains vault secrets ;; Vector 4: Content contains vault secrets
((and text (dispatcher-vault-scan text)) ((and text (dispatcher-vault-scan text))
(let ((secret-name (dispatcher-vault-scan text))) (let ((secret-name (dispatcher-vault-scan text)))
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) (log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(list :type :LOG (dispatcher-block-record :vault-secrets)
:payload (list :level :error (list :type :LOG
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name))))) :payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 5: Privacy-tagged content (severity tiers) ;; Vector 5: Privacy-tagged content (severity tiers)
((and tags (fboundp 'dispatcher-privacy-severity)) ((and tags (fboundp 'dispatcher-privacy-severity))
(let ((severity (dispatcher-privacy-severity tags))) (let ((severity (dispatcher-privacy-severity tags)))
(cond (cond
((eq severity :block) ((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags) (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(list :type :LOG (dispatcher-block-record :privacy-tags)
:payload (list :level :error (list :type :LOG
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags)))) :payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :warn) ((eq severity :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags) (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action) 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) (log-message "PRIVACY: @tag ~a (logged)" tags)
action)))) action))))
;; Vector 6: Text leaks privacy tag names ;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text)) ((and text (dispatcher-check-text-for-privacy text))
(log-message "PRIVACY WARNING: Text may contain leaked private content") (log-message "PRIVACY WARNING: Text may contain leaked private content")
(list :type :LOG (dispatcher-block-record :privacy-text)
:payload (list :level :warn (list :type :LOG
:text "Action blocked: Text may reference private content."))) :payload (list :level :warn
:text "Action blocked: Text may reference private content.")))
;; Vector 7: Shell destructive/injection patterns ;; Vector 7: Shell destructive/injection patterns
((and cmd (dispatcher-check-shell-safety cmd)) ((and cmd (dispatcher-check-shell-safety cmd))
(let ((matched (dispatcher-check-shell-safety cmd))) (let ((matched (dispatcher-check-shell-safety cmd)))
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched) (log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
(list :type :LOG (dispatcher-block-record :shell-safety)
:payload (list :level :error (list :type :LOG
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched))))) :payload (list :level :error
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
;; Vector 8: Network exfiltration ;; Vector 8: Network exfiltration
((and (or (eq target :shell) ((and (or (eq target :shell)
(and (eq target :tool) (equal (proto-get payload :tool) "shell"))) (and (eq target :tool) (equal (proto-get payload :tool) "shell")))
(dispatcher-check-network-exfil cmd)) (dispatcher-check-network-exfil cmd))
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.") (log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
(list :type :EVENT :level :approval-required (dispatcher-block-record :network-exfil)
:payload (list :sensor :approval-required :action action))) (list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required :action action)))
;; Vector 8: High-impact action approval ;; Vector 8b: High-impact action approval
((or (member target '(:shell)) ((or (member target '(:shell))
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=)) (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 :emacs) (eq (proto-get payload :action) :eval))
(and (eq target :system) (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)) (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))) (dispatcher-block-record :high-impact-approval)
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
(t action)))) (t action))))
#+end_src #+end_src
@@ -736,6 +773,35 @@ Recognized formats:
:deterministic #'dispatcher-gate) :deterministic #'dispatcher-gate)
#+end_src #+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 <N> :by-gate ((<gate> . <count>) ...))."
(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 * Test Suite
#+begin_src lisp #+begin_src lisp
@@ -837,7 +903,7 @@ Recognized formats:
(is (eq :block (passepartout::tag-category-severity "@personal"))) (is (eq :block (passepartout::tag-category-severity "@personal")))
(is (eq :warn (passepartout::tag-category-severity "@draft"))) (is (eq :warn (passepartout::tag-category-severity "@draft")))
(is (eq :log (passepartout::tag-category-severity "@review")))) (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 (test test-tag-category-severity-unknown
"Contract v0.7.2: unknown tag returns nil." "Contract v0.7.2: unknown tag returns nil."
@@ -904,21 +970,55 @@ Recognized formats:
(test test-safe-tool-write-still-checked (test test-safe-tool-write-still-checked
"Contract v0.7.2: write tools still go through full dispatcher check." "Contract v0.7.2: write tools still go through full dispatcher check."
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) (let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
(passepartout::make-cognitive-tool :name "write-file" (setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
:description "File writer" (passepartout::make-cognitive-tool :name "write-file"
:parameters nil :description "File writer"
:guard nil :parameters nil
:body nil :guard nil
:read-only-p nil)) :body nil
(unwind-protect :read-only-p nil))
(progn (unwind-protect
(setf (uiop:getenv "SELF_BUILD_MODE") "true") (progn
(let* ((action '(:TYPE :REQUEST :TARGET :tool (setf (uiop:getenv "SELF_BUILD_MODE") "true")
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x")))) (let* ((action '(:TYPE :REQUEST :TARGET :tool
(result (dispatcher-check action nil))) :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
(setf (uiop:getenv "SELF_BUILD_MODE") "false") (result (dispatcher-check action nil)))
(is (eq :approval-required (getf result :level))) (is (eq :approval-required (getf result :level)))
(is (search "HITL" (getf (getf result :payload) :message))))) (is (search "HITL" (getf (getf result :payload) :message)))))
(remhash "write-file" passepartout::*cognitive-tool-registry*))) (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 #+end_src

79
org/token-economics.org
View File

@@ -27,6 +27,19 @@ core-reason thin while enabling token economics as a hot-loadable skill.
Depends on: tokenizer.lisp, cost-tracker.lisp 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 ** Contract
1. (prompt-prefix-cached assistant-name identity-content feedback mandates-text tool-belt): 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 L3: downgrade context to single-line summary
Returns (values trimmed-prefix trimmed-ctxt trimmed-logs trimmed-user trimmed-mandates). Returns (values trimmed-prefix trimmed-ctxt trimmed-logs trimmed-user trimmed-mandates).
4. (token-economics-initialize): zeroes the cache state at daemon boot. 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 * Implementation
@@ -57,7 +74,9 @@ Depends on: tokenizer.lisp, cost-tracker.lisp
(defvar *prompt-prefix-cache* (cons nil "") (defvar *prompt-prefix-cache* (cons nil "")
"Prompt prefix cache: (sxhash . cached-string). Rebuilt when IDENTITY or TOOLS change.") "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.") "Context assembly cache: metadata + last rendered context string.")
#+end_src #+end_src
@@ -127,7 +146,9 @@ with trimmed sections."
(ignore-errors (ignore-errors
(parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS"))) (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
16384))) 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) (total-tokens (p c l u m)
(+ (ct p) (+ (ct p)
(if c (ct c) 0) (if c (ct c) 0)
@@ -169,6 +190,25 @@ with trimmed sections."
(getf *context-cache* :rendered) "")) (getf *context-cache* :rendered) ""))
#+end_src #+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 * Test Suite
#+begin_src lisp #+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -270,3 +310,38 @@ with trimmed sections."
(is (string= "" (cdr passepartout::*prompt-prefix-cache*))) (is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
(is (string= "" (getf passepartout::*context-cache* :rendered)))) (is (string= "" (getf passepartout::*context-cache* :rendered))))
#+end_src #+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