v0.3.0 deferred: tab completion, multi-line, /help, activity indicator, context persistence, theming
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s

- Tab completion: Tab key autocompletes / commands (Tab handler in on-key)
- Multi-line input: backslash + Enter inserts literal newline instead of sending
- /help command: displays full command listing with descriptions
- Activity indicator: :busy flag shows "...thinking" in status bar during LLM wait
- Context persistence: context-save/context-load persist *context-stack* to disk
  (~/.cache/passepartout/context.lisp). Auto-restores on skill load.
  Added push-context, pop-context, focus-*, unfocus, context-save/load exports.
- Theming: *tui-theme* plist with semantic color roles, /theme command
  View functions (view-chat, view-status, view-input) use theme-color
- TUI test suite: 19 tests, 53 checks (100% pass)
- Context test suite: 2 tests, 6 checks (100% pass)
- Total: 5 suites, 81 checks, 0 failures
This commit is contained in:
2026-05-05 18:02:50 -04:00
parent cd86509e3a
commit 61ea5767d6
10 changed files with 580 additions and 145 deletions

View File

@@ -38,10 +38,20 @@
#:snapshot-memory
#:rollback-memory
#:context-get-system-logs
#:telemetry-track
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
#:current-scope
#:context-stack-depth
#:context-save
#:context-load
#:focus-project
#:focus-session
#:focus-memex
#:unfocus
#:process-signal
#:loop-process
#:perceive-gate

View File

@@ -3,61 +3,105 @@
(defun on-key (&rest args)
(let ((ch (car args)))
(cond
;; Enter
((or (eql ch 10) (eql ch 13) (eq ch :enter)
(eql ch #\Newline) (eql ch #\Return))
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
(when (> (length text) 0)
(push text (st :input-history))
(setf (st :input-hpos) 0)
(setf (st :scroll-offset) 0)
(cond
;; /eval command
((and (>= (length text) 6)
(string-equal (subseq text 0 6) "/eval "))
(handler-case
(let* ((*read-eval* t)
(*package* (find-package :passepartout.gateway-tui))
(r (eval (read-from-string (subseq text 6)))))
(add-msg :system (format nil "=> ~s" r)))
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
;; /focus <project> — set project context
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/focus "))
(let ((project (string-trim '(#\Space) (subseq text 7))))
(if (and (fboundp 'focus-project) (> (length project) 0))
(progn (funcall 'focus-project project nil)
(add-msg :system (format nil "Focused on project: ~a" project)))
(add-msg :system "Usage: /focus <project-name>"))))
;; /scope <scope> — change context scope
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/scope "))
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
(cond
((and (fboundp 'focus-session) (string-equal scope-str "session"))
(funcall 'focus-session)
(add-msg :system "Scope: session"))
((and (fboundp 'focus-project) (string-equal scope-str "project"))
(funcall 'focus-project nil nil)
(add-msg :system "Scope: project"))
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
(funcall 'focus-memex)
(add-msg :system "Scope: memex"))
(t (add-msg :system "Usage: /scope memex|session|project")))))
;; /unfocus — pop context
((and (>= (length text) 8)
(string-equal (subseq text 0 8) "/unfocus"))
(if (fboundp 'unfocus)
(progn (funcall 'unfocus)
(add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded")))
;; Normal message
(t
(add-msg :user text)
(send-daemon (list :type :event
:payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil)
(setf (st :dirty) (list t t t)))))
;; Enter
((or (eql ch 10) (eql ch 13) (eq ch :enter)
(eql ch #\Newline) (eql ch #\Return))
;; Multi-line: if buffer ends with \, strip it and insert newline
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
(progn (pop (st :input-buffer))
(push #\Newline (st :input-buffer))
(setf (st :dirty) (list nil nil t)))
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
(when (> (length text) 0)
(push text (st :input-history))
(setf (st :input-hpos) 0)
(setf (st :scroll-offset) 0)
(cond
;; /help command
((string-equal text "/help")
(add-msg :system
"/eval <expr> Evaluate Lisp expression")
(add-msg :system
"/focus <proj> Set project context")
(add-msg :system
"/scope <s> Change scope (memex/session/project)")
(add-msg :system
"/unfocus Pop context stack")
(add-msg :system
"/theme Show current color theme")
(add-msg :system
"/help Show this help")
(add-msg :system
"\\ + Enter Multi-line input"))
;; /theme command
((string-equal text "/theme")
(add-msg :system
(format nil "Theme: user=~a agent=~a system=~a input=~a"
(getf *tui-theme* :user)
(getf *tui-theme* :agent)
(getf *tui-theme* :system)
(getf *tui-theme* :input))))
;; /eval command
((and (>= (length text) 6)
(string-equal (subseq text 0 6) "/eval "))
(handler-case
(let* ((*read-eval* t)
(*package* (find-package :passepartout.gateway-tui))
(r (eval (read-from-string (subseq text 6)))))
(add-msg :system (format nil "=> ~s" r)))
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
;; /focus <project> — set project context
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/focus "))
(let ((project (string-trim '(#\Space) (subseq text 7))))
(if (and (fboundp 'focus-project) (> (length project) 0))
(progn (funcall 'focus-project project nil)
(add-msg :system (format nil "Focused on project: ~a" project)))
(add-msg :system "Usage: /focus <project-name>"))))
;; /scope <scope> — change context scope
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/scope "))
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
(cond
((and (fboundp 'focus-session) (string-equal scope-str "session"))
(funcall 'focus-session)
(add-msg :system "Scope: session"))
((and (fboundp 'focus-project) (string-equal scope-str "project"))
(funcall 'focus-project nil nil)
(add-msg :system "Scope: project"))
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
(funcall 'focus-memex)
(add-msg :system "Scope: memex"))
(t (add-msg :system "Usage: /scope memex|session|project")))))
;; /unfocus — pop context
((and (>= (length text) 8)
(string-equal (subseq text 0 8) "/unfocus"))
(if (fboundp 'unfocus)
(progn (funcall 'unfocus)
(add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded")))
;; Normal message
(t
(add-msg :user text)
(setf (st :busy) t)
(send-daemon (list :type :event
:payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil)
(setf (st :dirty) (list t t t))))))
;; Tab — command completion
((or (eql ch 9) (eq ch :tab))
(let ((text (input-string)))
(when (and (> (length text) 1) (eql (char text 0) #\/))
(let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme"))
(match (find text cmds :test
(lambda (in cmd)
(and (>= (length cmd) (length in))
(string-equal cmd in :end1 (length in)))))))
(when match
(setf (st :input-buffer) (reverse (coerce match 'list)))
(when (member match '("/eval" "/focus" "/scope") :test #'string=)
(push #\Space (st :input-buffer)))
(setf (st :dirty) (list nil nil t)))))))
;; Backspace
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
(when (st :input-buffer) (pop (st :input-buffer)))
@@ -103,7 +147,8 @@
(text (getf payload :text))
(action (getf payload :action)))
(cond
(text (add-msg :agent text))
(text (setf (st :busy) nil)
(add-msg :agent text))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))))
@@ -214,7 +259,8 @@
(fiveam:is (eq nil (st :connected)))
(fiveam:is (eq nil (st :stream)))
(fiveam:is (eq nil (st :messages)))
(fiveam:is (eq 0 (st :scroll-offset))))
(fiveam:is (eq 0 (st :scroll-offset)))
(fiveam:is (eq nil (st :busy))))
(fiveam:test test-add-msg
"Contract model.2: add-msg appends a message with role, content, and time."
@@ -343,3 +389,61 @@
(on-key 13)
(let ((msg (first (st :messages))))
(fiveam:is (eq :system (getf msg :role)))))
(fiveam:test test-on-key-tab-completion
"Contract 1: Tab completes / commands when input starts with /."
(init-state)
;; Type "/ev" then Tab
(dolist (ch (coerce "/ev" 'list))
(on-key (char-code ch)))
(on-key 9) ; Tab
(fiveam:is (string= "/eval " (input-string))))
(fiveam:test test-on-key-tab-no-slash
"Contract 1: Tab does nothing when input doesn't start with /."
(init-state)
(dolist (ch (coerce "hello" 'list))
(on-key (char-code ch)))
(on-key 9) ; Tab
(fiveam:is (string= "hello" (input-string))))
(fiveam:test test-on-key-multiline
"Contract 1: \\ + Enter inserts newline instead of sending."
(init-state)
(dolist (ch (coerce "line1" 'list))
(on-key (char-code ch)))
(on-key (char-code #\\))
(on-key 13)
(fiveam:is (search "line1" (input-string)))
(fiveam:is (search (string #\Newline) (input-string))))
(fiveam:test test-on-key-help
"Contract 1: /help displays command list."
(init-state)
(dolist (ch (coerce "/help" 'list))
(on-key (char-code ch)))
(on-key 13)
(let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 3))
(fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs))))
(fiveam:test test-activity-indicator
"Contract model: :busy flag is set on send and cleared on agent response."
(init-state)
(fiveam:is (eq nil (st :busy)))
;; Simulate sending a normal message (sets busy)
(dolist (ch (coerce "hello" 'list))
(on-key (char-code ch)))
(on-key 13)
(fiveam:is (eq t (st :busy)))
;; Simulate receiving an agent response (clears busy)
(on-daemon-msg '(:type :event :payload (:text "hi back")))
(fiveam:is (eq nil (st :busy))))
(fiveam:test test-theme
"Contract view: *tui-theme* provides color mappings."
(fiveam:is (eq :green (getf *tui-theme* :user)))
(fiveam:is (eq :white (getf *tui-theme* :agent)))
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
(fiveam:is (eq :white (theme-color :unknown-role))))

View File

@@ -4,13 +4,23 @@
:queue-event :drain-queue :init-state
:view-status :view-chat :view-input :redraw
:on-key :on-daemon-msg :send-daemon
:connect-daemon :disconnect-daemon))
:connect-daemon :disconnect-daemon
:*tui-theme* :theme-color))
(in-package :passepartout.gateway-tui)
(defvar *state* nil)
(defvar *event-queue* nil)
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
(defvar *tui-theme*
'(:user :green :agent :white :system :yellow :input :cyan
:connected :green :disconnected :red :timestamp :yellow)
"Color theme plist. Keys are semantic roles, values are Croatoan colors.")
(defun theme-color (role)
"Returns the Croatoan color for a semantic role."
(or (getf *tui-theme* role) :white))
(defun st (key) (getf *state* key))
(defun (setf st) (val key) (setf (getf *state* key) val))
@@ -18,7 +28,8 @@
(setf *state*
(list :running t :mode :chat :connected nil :stream nil
:input-buffer nil :input-history nil :input-hpos 0
:messages nil :scroll-offset 0 :dirty (list nil nil nil))))
:messages nil :scroll-offset 0 :busy nil
:dirty (list nil nil nil))))
(defun now ()
(multiple-value-bind (h m) (get-decoded-time)

View File

@@ -4,13 +4,14 @@
(clear win)
(box win 0 0)
(add-string win
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a"
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0"))
:y 1 :x 1 :fgcolor (if (st :connected) :green :red))
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor :yellow)
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(if (st :busy) " …thinking" ""))
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
(refresh win))
(defun view-chat (win h)
@@ -33,11 +34,11 @@
(:agent (format nil "⬇ [~a] ~a" time content))
(:system (format nil " [~a] ~a" time content))
(t (format nil " [~a] ~a" time content))))
(color (case role
(:user :green)
(:agent :white)
(:system :yellow)
(t :white))))
(color (theme-color (case role
(:user :user)
(:agent :agent)
(:system :system)
(t :agent)))))
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
(incf y)))))
(refresh win))
@@ -47,7 +48,7 @@
(w (or (width win) 78))
(clip (min (length text) (1- w))))
(clear win)
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor :cyan)
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
(setf (cursor-position win) (list 0 clip)))
(refresh win))

View File

@@ -1,3 +1,5 @@
(in-package :passepartout)
(defvar *context-stack* nil
"Stack of context plists. Each plist has :project, :base-path, :scope.
Top of stack (car) is the current context.")
@@ -39,6 +41,7 @@ Returns the new context plist."
:base-path base-path
:scope scope)))
(push context *context-stack*)
(context-save)
(log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth))
context))
@@ -47,6 +50,7 @@ Returns the new context plist."
Returns the restored context or nil if stack becomes empty."
(if *context-stack*
(let ((popped (pop *context-stack*)))
(context-save)
(log-message "CONTEXT: Popped ~a (depth ~d)"
(getf popped :project) (context-stack-depth))
(current-context))
@@ -107,6 +111,46 @@ until stack is empty or :memex context is reached."
"Pop the top context and return to the previous one."
(pop-context))
(defvar *context-persistence-file* nil
"Path to the context stack persistence file.")
(defun context-persist-file ()
"Returns the full path to the context persistence file."
(or *context-persistence-file*
(setf *context-persistence-file*
(merge-pathnames ".cache/passepartout/context.lisp"
(user-homedir-pathname)))))
(defun context-save ()
"Writes *context-stack* to the persistence file."
(handler-case
(let ((path (context-persist-file)))
(ensure-directories-exist (make-pathname :directory (pathname-directory path)))
(with-open-file (s path :direction :output :if-exists :supersede
:if-does-not-exist :create)
(prin1 *context-stack* s))
(log-message "CONTEXT: Saved stack (depth ~d) to ~a"
(length *context-stack*) path))
(error (c)
(log-message "CONTEXT: Failed to save: ~a" c))))
(defun context-load ()
"Restores *context-stack* from the persistence file."
(handler-case
(let ((path (context-persist-file)))
(when (probe-file path)
(with-open-file (s path :direction :input)
(let ((*read-eval* nil)
(data (read s nil nil)))
(when (listp data)
(setf *context-stack* data)
(log-message "CONTEXT: Restored stack (depth ~d) from ~a"
(length *context-stack*) path))
t))))
(error (c)
(log-message "CONTEXT: Failed to load: ~a" c)
nil)))
(defskill :passepartout-system-context-manager
:priority 90
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
@@ -119,3 +163,40 @@ until stack is empty or :memex context is reached."
(when (boundp '*scope-resolver*)
(setf *scope-resolver* #'current-scope))
;; Restore persisted context on load
(context-load)
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-context-tests
(:use :cl :passepartout)
(:export #:context-suite))
(in-package :passepartout-context-tests)
(fiveam:def-suite context-suite :description "Context manager verification")
(fiveam:in-suite context-suite)
(fiveam:test test-push-pop-context
"Contract 1-2: push-context and pop-context maintain stack order."
(let ((passepartout::*context-stack* nil))
(push-context :project "testapp" :base-path "/tmp" :scope :project)
(fiveam:is (= 1 (length passepartout::*context-stack*)))
(fiveam:is (string= "testapp" (getf (car passepartout::*context-stack*) :project)))
(pop-context)
(fiveam:is (null passepartout::*context-stack*))))
(fiveam:test test-context-save-load
"Contract 3-4: context-save and context-load round-trip."
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory)))
(passepartout::*context-persistence-file* tmpfile)
(passepartout::*context-stack* (list '(:project "test" :base-path "/tmp" :scope :project))))
(context-save)
(fiveam:is (probe-file tmpfile))
(setf passepartout::*context-stack* nil)
(context-load)
(fiveam:is (= 1 (length passepartout::*context-stack*)))
(fiveam:is (string= "test" (getf (car passepartout::*context-stack*) :project)))
(delete-file tmpfile)))

View File

@@ -63,10 +63,20 @@ The package definition. All public symbols are exported here.
#:snapshot-memory
#:rollback-memory
#:context-get-system-logs
#:telemetry-track
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
#:current-scope
#:context-stack-depth
#:context-save
#:context-load
#:focus-project
#:focus-session
#:focus-memex
#:unfocus
#:process-signal
#:loop-process
#:perceive-gate

View File

@@ -9,10 +9,12 @@ Event handlers + daemon I/O + main loop.
1. (on-key ch): dispatches key presses: Enter triggers send (extracts
input buffer, pushes history, sends to daemon, clears buffer),
~/eval <expr>~ evaluates a Lisp expression, ~/focus <proj>~ switches
project context, ~/scope <scope>~ changes context scope,
~/unfocus~ pops context, Backspace deletes, arrows scroll chat
and history. Non-printable keys are ignored.
~\\ + Enter~ inserts a literal newline (multi-line input),
~/help~ lists all commands, ~/eval <expr>~ evaluates a Lisp
expression, ~/focus <proj>~ switches project context,
~/scope <scope>~ changes context scope, ~/unfocus~ pops context,
Tab completes command names, Backspace deletes, arrows scroll
chat and history. Non-printable keys are ignored.
2. (on-daemon-msg msg): processes inbound daemon messages. Routes
text responses to chat display (:agent), handshake to system
messages, routes errors to log via ~log-message~.
@@ -29,61 +31,105 @@ Event handlers + daemon I/O + main loop.
(defun on-key (&rest args)
(let ((ch (car args)))
(cond
;; Enter
((or (eql ch 10) (eql ch 13) (eq ch :enter)
(eql ch #\Newline) (eql ch #\Return))
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
(when (> (length text) 0)
(push text (st :input-history))
(setf (st :input-hpos) 0)
(setf (st :scroll-offset) 0)
(cond
;; /eval command
((and (>= (length text) 6)
(string-equal (subseq text 0 6) "/eval "))
(handler-case
(let* ((*read-eval* t)
(*package* (find-package :passepartout.gateway-tui))
(r (eval (read-from-string (subseq text 6)))))
(add-msg :system (format nil "=> ~s" r)))
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
;; /focus <project> — set project context
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/focus "))
(let ((project (string-trim '(#\Space) (subseq text 7))))
(if (and (fboundp 'focus-project) (> (length project) 0))
(progn (funcall 'focus-project project nil)
(add-msg :system (format nil "Focused on project: ~a" project)))
(add-msg :system "Usage: /focus <project-name>"))))
;; /scope <scope> — change context scope
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/scope "))
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
(cond
((and (fboundp 'focus-session) (string-equal scope-str "session"))
(funcall 'focus-session)
(add-msg :system "Scope: session"))
((and (fboundp 'focus-project) (string-equal scope-str "project"))
(funcall 'focus-project nil nil)
(add-msg :system "Scope: project"))
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
(funcall 'focus-memex)
(add-msg :system "Scope: memex"))
(t (add-msg :system "Usage: /scope memex|session|project")))))
;; /unfocus — pop context
((and (>= (length text) 8)
(string-equal (subseq text 0 8) "/unfocus"))
(if (fboundp 'unfocus)
(progn (funcall 'unfocus)
(add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded")))
;; Normal message
(t
(add-msg :user text)
(send-daemon (list :type :event
:payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil)
(setf (st :dirty) (list t t t)))))
;; Enter
((or (eql ch 10) (eql ch 13) (eq ch :enter)
(eql ch #\Newline) (eql ch #\Return))
;; Multi-line: if buffer ends with \, strip it and insert newline
(if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
(progn (pop (st :input-buffer))
(push #\Newline (st :input-buffer))
(setf (st :dirty) (list nil nil t)))
(let ((text (string-trim '(#\Space #\Tab) (input-string))))
(when (> (length text) 0)
(push text (st :input-history))
(setf (st :input-hpos) 0)
(setf (st :scroll-offset) 0)
(cond
;; /help command
((string-equal text "/help")
(add-msg :system
"/eval <expr> Evaluate Lisp expression")
(add-msg :system
"/focus <proj> Set project context")
(add-msg :system
"/scope <s> Change scope (memex/session/project)")
(add-msg :system
"/unfocus Pop context stack")
(add-msg :system
"/theme Show current color theme")
(add-msg :system
"/help Show this help")
(add-msg :system
"\\ + Enter Multi-line input"))
;; /theme command
((string-equal text "/theme")
(add-msg :system
(format nil "Theme: user=~a agent=~a system=~a input=~a"
(getf *tui-theme* :user)
(getf *tui-theme* :agent)
(getf *tui-theme* :system)
(getf *tui-theme* :input))))
;; /eval command
((and (>= (length text) 6)
(string-equal (subseq text 0 6) "/eval "))
(handler-case
(let* ((*read-eval* t)
(*package* (find-package :passepartout.gateway-tui))
(r (eval (read-from-string (subseq text 6)))))
(add-msg :system (format nil "=> ~s" r)))
(error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
;; /focus <project> — set project context
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/focus "))
(let ((project (string-trim '(#\Space) (subseq text 7))))
(if (and (fboundp 'focus-project) (> (length project) 0))
(progn (funcall 'focus-project project nil)
(add-msg :system (format nil "Focused on project: ~a" project)))
(add-msg :system "Usage: /focus <project-name>"))))
;; /scope <scope> — change context scope
((and (>= (length text) 7)
(string-equal (subseq text 0 7) "/scope "))
(let ((scope-str (string-trim '(#\Space) (subseq text 7))))
(cond
((and (fboundp 'focus-session) (string-equal scope-str "session"))
(funcall 'focus-session)
(add-msg :system "Scope: session"))
((and (fboundp 'focus-project) (string-equal scope-str "project"))
(funcall 'focus-project nil nil)
(add-msg :system "Scope: project"))
((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
(funcall 'focus-memex)
(add-msg :system "Scope: memex"))
(t (add-msg :system "Usage: /scope memex|session|project")))))
;; /unfocus — pop context
((and (>= (length text) 8)
(string-equal (subseq text 0 8) "/unfocus"))
(if (fboundp 'unfocus)
(progn (funcall 'unfocus)
(add-msg :system "Popped context"))
(add-msg :system "Context manager not loaded")))
;; Normal message
(t
(add-msg :user text)
(setf (st :busy) t)
(send-daemon (list :type :event
:payload (list :sensor :user-input :text text)))))
(setf (st :input-buffer) nil)
(setf (st :dirty) (list t t t))))))
;; Tab — command completion
((or (eql ch 9) (eq ch :tab))
(let ((text (input-string)))
(when (and (> (length text) 1) (eql (char text 0) #\/))
(let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme"))
(match (find text cmds :test
(lambda (in cmd)
(and (>= (length cmd) (length in))
(string-equal cmd in :end1 (length in)))))))
(when match
(setf (st :input-buffer) (reverse (coerce match 'list)))
(when (member match '("/eval" "/focus" "/scope") :test #'string=)
(push #\Space (st :input-buffer)))
(setf (st :dirty) (list nil nil t)))))))
;; Backspace
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
(when (st :input-buffer) (pop (st :input-buffer)))
@@ -129,7 +175,8 @@ Event handlers + daemon I/O + main loop.
(text (getf payload :text))
(action (getf payload :action)))
(cond
(text (add-msg :agent text))
(text (setf (st :busy) nil)
(add-msg :agent text))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))))
@@ -253,7 +300,8 @@ Event handlers + daemon I/O + main loop.
(fiveam:is (eq nil (st :connected)))
(fiveam:is (eq nil (st :stream)))
(fiveam:is (eq nil (st :messages)))
(fiveam:is (eq 0 (st :scroll-offset))))
(fiveam:is (eq 0 (st :scroll-offset)))
(fiveam:is (eq nil (st :busy))))
(fiveam:test test-add-msg
"Contract model.2: add-msg appends a message with role, content, and time."
@@ -382,4 +430,62 @@ Event handlers + daemon I/O + main loop.
(on-key 13)
(let ((msg (first (st :messages))))
(fiveam:is (eq :system (getf msg :role)))))
(fiveam:test test-on-key-tab-completion
"Contract 1: Tab completes / commands when input starts with /."
(init-state)
;; Type "/ev" then Tab
(dolist (ch (coerce "/ev" 'list))
(on-key (char-code ch)))
(on-key 9) ; Tab
(fiveam:is (string= "/eval " (input-string))))
(fiveam:test test-on-key-tab-no-slash
"Contract 1: Tab does nothing when input doesn't start with /."
(init-state)
(dolist (ch (coerce "hello" 'list))
(on-key (char-code ch)))
(on-key 9) ; Tab
(fiveam:is (string= "hello" (input-string))))
(fiveam:test test-on-key-multiline
"Contract 1: \\ + Enter inserts newline instead of sending."
(init-state)
(dolist (ch (coerce "line1" 'list))
(on-key (char-code ch)))
(on-key (char-code #\\))
(on-key 13)
(fiveam:is (search "line1" (input-string)))
(fiveam:is (search (string #\Newline) (input-string))))
(fiveam:test test-on-key-help
"Contract 1: /help displays command list."
(init-state)
(dolist (ch (coerce "/help" 'list))
(on-key (char-code ch)))
(on-key 13)
(let ((msgs (st :messages)))
(fiveam:is (>= (length msgs) 3))
(fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs))))
(fiveam:test test-activity-indicator
"Contract model: :busy flag is set on send and cleared on agent response."
(init-state)
(fiveam:is (eq nil (st :busy)))
;; Simulate sending a normal message (sets busy)
(dolist (ch (coerce "hello" 'list))
(on-key (char-code ch)))
(on-key 13)
(fiveam:is (eq t (st :busy)))
;; Simulate receiving an agent response (clears busy)
(on-daemon-msg '(:type :event :payload (:text "hi back")))
(fiveam:is (eq nil (st :busy))))
(fiveam:test test-theme
"Contract view: *tui-theme* provides color mappings."
(fiveam:is (eq :green (getf *tui-theme* :user)))
(fiveam:is (eq :white (getf *tui-theme* :agent)))
(fiveam:is (eq :yellow (getf *tui-theme* :system)))
(fiveam:is (eq :cyan (getf *tui-theme* :input)))
(fiveam:is (eq :white (theme-color :unknown-role))))
#+end_src

View File

@@ -9,7 +9,7 @@ All state mutation flows through event handlers in the controller.
** Contract
1. (init-state): returns a fresh state plist with ~:msgs~ list,
~:input~ buffer, ~:dirty~ flag, and ~:connection~ status.
~:input~ buffer, ~:dirty~ flag, ~:busy~ flag, and ~:connection~ status.
2. (add-msg type text): appends a message to the ~:msgs~ list in
~*state*~, tagged with a timestamp and type. Truncates at the
message buffer limit.
@@ -24,13 +24,23 @@ All state mutation flows through event handlers in the controller.
:queue-event :drain-queue :init-state
:view-status :view-chat :view-input :redraw
:on-key :on-daemon-msg :send-daemon
:connect-daemon :disconnect-daemon))
:connect-daemon :disconnect-daemon
:*tui-theme* :theme-color))
(in-package :passepartout.gateway-tui)
(defvar *state* nil)
(defvar *event-queue* nil)
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
(defvar *tui-theme*
'(:user :green :agent :white :system :yellow :input :cyan
:connected :green :disconnected :red :timestamp :yellow)
"Color theme plist. Keys are semantic roles, values are Croatoan colors.")
(defun theme-color (role)
"Returns the Croatoan color for a semantic role."
(or (getf *tui-theme* role) :white))
(defun st (key) (getf *state* key))
(defun (setf st) (val key) (setf (getf *state* key) val))
@@ -38,7 +48,8 @@ All state mutation flows through event handlers in the controller.
(setf *state*
(list :running t :mode :chat :connected nil :stream nil
:input-buffer nil :input-history nil :input-hpos 0
:messages nil :scroll-offset 0 :dirty (list nil nil nil))))
:messages nil :scroll-offset 0 :busy nil
:dirty (list nil nil nil))))
#+end_src
** Helpers

View File

@@ -26,13 +26,14 @@ State is read via ~(st :key)~ — no mutation here.
(clear win)
(box win 0 0)
(add-string win
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a"
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0"))
:y 1 :x 1 :fgcolor (if (st :connected) :green :red))
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor :yellow)
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(if (st :busy) " …thinking" ""))
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
(refresh win))
#+end_src
@@ -58,11 +59,11 @@ State is read via ~(st :key)~ — no mutation here.
(:agent (format nil "⬇ [~a] ~a" time content))
(:system (format nil " [~a] ~a" time content))
(t (format nil " [~a] ~a" time content))))
(color (case role
(:user :green)
(:agent :white)
(:system :yellow)
(t :white))))
(color (theme-color (case role
(:user :user)
(:agent :agent)
(:system :system)
(t :agent)))))
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
(incf y)))))
(refresh win))
@@ -75,7 +76,7 @@ State is read via ~(st :key)~ — no mutation here.
(w (or (width win) 78))
(clip (min (length text) (1- w))))
(clear win)
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor :cyan)
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
(setf (cursor-position win) (list 0 clip)))
(refresh win))
#+end_src

View File

@@ -20,6 +20,8 @@ scope means for each project, and how the stack is managed.
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(in-package :passepartout)
(defvar *context-stack* nil
"Stack of context plists. Each plist has :project, :base-path, :scope.
Top of stack (car) is the current context.")
@@ -93,6 +95,7 @@ Returns the new context plist."
:base-path base-path
:scope scope)))
(push context *context-stack*)
(context-save)
(log-message "CONTEXT: Pushed ~a (depth ~d)" project (context-stack-depth))
context))
@@ -105,6 +108,7 @@ Returns the new context plist."
Returns the restored context or nil if stack becomes empty."
(if *context-stack*
(let ((popped (pop *context-stack*)))
(context-save)
(log-message "CONTEXT: Popped ~a (depth ~d)"
(getf popped :project) (context-stack-depth))
(current-context))
@@ -212,6 +216,53 @@ until stack is empty or :memex context is reached."
** Skill Registration
** Persistence
;; REPL-VERIFIED: 2026-05-05T12:00:00
#+begin_src lisp
(defvar *context-persistence-file* nil
"Path to the context stack persistence file.")
(defun context-persist-file ()
"Returns the full path to the context persistence file."
(or *context-persistence-file*
(setf *context-persistence-file*
(merge-pathnames ".cache/passepartout/context.lisp"
(user-homedir-pathname)))))
(defun context-save ()
"Writes *context-stack* to the persistence file."
(handler-case
(let ((path (context-persist-file)))
(ensure-directories-exist (make-pathname :directory (pathname-directory path)))
(with-open-file (s path :direction :output :if-exists :supersede
:if-does-not-exist :create)
(prin1 *context-stack* s))
(log-message "CONTEXT: Saved stack (depth ~d) to ~a"
(length *context-stack*) path))
(error (c)
(log-message "CONTEXT: Failed to save: ~a" c))))
(defun context-load ()
"Restores *context-stack* from the persistence file."
(handler-case
(let ((path (context-persist-file)))
(when (probe-file path)
(with-open-file (s path :direction :input)
(let ((*read-eval* nil)
(data (read s nil nil)))
(when (listp data)
(setf *context-stack* data)
(log-message "CONTEXT: Restored stack (depth ~d) from ~a"
(length *context-stack*) path))
t))))
(error (c)
(log-message "CONTEXT: Failed to load: ~a" c)
nil)))
#+end_src
** Skill Registration
#+begin_src lisp
(defskill :passepartout-system-context-manager
:priority 90
@@ -228,8 +279,57 @@ until stack is empty or :memex context is reached."
Registers ~current-scope~ into the core ~*scope-resolver*~ hook so the
perceive gate tags ingested objects with the active context scope.
Also restores any previously saved context stack.
#+begin_src lisp
(when (boundp '*scope-resolver*)
(setf *scope-resolver* #'current-scope))
;; Restore persisted context on load
(context-load)
#+end_src
* Contract
1. (push-context &key project base-path scope): pushes a context plist
onto ~*context-stack*~ and persists to disk.
2. (pop-context): pops the top context, persists, returns restored context.
3. (context-save): serializes ~*context-stack*~ to the persistence file.
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-context-tests
(:use :cl :passepartout)
(:export #:context-suite))
(in-package :passepartout-context-tests)
(fiveam:def-suite context-suite :description "Context manager verification")
(fiveam:in-suite context-suite)
(fiveam:test test-push-pop-context
"Contract 1-2: push-context and pop-context maintain stack order."
(let ((passepartout::*context-stack* nil))
(push-context :project "testapp" :base-path "/tmp" :scope :project)
(fiveam:is (= 1 (length passepartout::*context-stack*)))
(fiveam:is (string= "testapp" (getf (car passepartout::*context-stack*) :project)))
(pop-context)
(fiveam:is (null passepartout::*context-stack*))))
(fiveam:test test-context-save-load
"Contract 3-4: context-save and context-load round-trip."
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory)))
(passepartout::*context-persistence-file* tmpfile)
(passepartout::*context-stack* (list '(:project "test" :base-path "/tmp" :scope :project))))
(context-save)
(fiveam:is (probe-file tmpfile))
(setf passepartout::*context-stack* nil)
(context-load)
(fiveam:is (= 1 (length passepartout::*context-stack*)))
(fiveam:is (string= "test" (getf (car passepartout::*context-stack*) :project)))
(delete-file tmpfile)))
#+end_src