diff --git a/lisp/core-defpackage.lisp b/lisp/core-defpackage.lisp index 57eaa60..3bcef13 100644 --- a/lisp/core-defpackage.lisp +++ b/lisp/core-defpackage.lisp @@ -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 diff --git a/lisp/gateway-tui-main.lisp b/lisp/gateway-tui-main.lisp index fa3c950..16b076d 100644 --- a/lisp/gateway-tui-main.lisp +++ b/lisp/gateway-tui-main.lisp @@ -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 — 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 ")))) - ;; /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 Evaluate Lisp expression") + (add-msg :system + "/focus Set project context") + (add-msg :system + "/scope 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 — 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 ")))) + ;; /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)))) diff --git a/lisp/gateway-tui-model.lisp b/lisp/gateway-tui-model.lisp index 1aef21a..10926be 100644 --- a/lisp/gateway-tui-model.lisp +++ b/lisp/gateway-tui-model.lisp @@ -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) diff --git a/lisp/gateway-tui-view.lisp b/lisp/gateway-tui-view.lisp index c619c4e..3151e8c 100644 --- a/lisp/gateway-tui-view.lisp +++ b/lisp/gateway-tui-view.lisp @@ -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)) diff --git a/lisp/system-context-manager.lisp b/lisp/system-context-manager.lisp index a5f4f75..3f6c269 100644 --- a/lisp/system-context-manager.lisp +++ b/lisp/system-context-manager.lisp @@ -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))) diff --git a/org/core-defpackage.org b/org/core-defpackage.org index 6108c36..71d0c42 100644 --- a/org/core-defpackage.org +++ b/org/core-defpackage.org @@ -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 diff --git a/org/gateway-tui-main.org b/org/gateway-tui-main.org index 8ecdf31..a2037ef 100644 --- a/org/gateway-tui-main.org +++ b/org/gateway-tui-main.org @@ -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 ~ evaluates a Lisp expression, ~/focus ~ switches - project context, ~/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 ~ evaluates a Lisp + expression, ~/focus ~ switches project context, + ~/scope ~ changes context scope, ~/unfocus~ pops context, + Tab completes command names, Backspace deletes, arrows scroll + chat and history. 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 — 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 ")))) - ;; /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 Evaluate Lisp expression") + (add-msg :system + "/focus Set project context") + (add-msg :system + "/scope 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 — 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 ")))) + ;; /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 diff --git a/org/gateway-tui-model.org b/org/gateway-tui-model.org index 598241b..c90953b 100644 --- a/org/gateway-tui-model.org +++ b/org/gateway-tui-model.org @@ -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 diff --git a/org/gateway-tui-view.org b/org/gateway-tui-view.org index 3ae93f9..201ca98 100644 --- a/org/gateway-tui-view.org +++ b/org/gateway-tui-view.org @@ -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 diff --git a/org/system-context-manager.org b/org/system-context-manager.org index 1565481..adec439 100644 --- a/org/system-context-manager.org +++ b/org/system-context-manager.org @@ -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 \ No newline at end of file