v0.7.2: session rewind + context debugging — TDD
Session rewind: /rewind <n> restores memory to snapshot n-1 using existing rollback-memory. /sessions lists up to 10 snapshots with timestamps and object counts. Auto-snapshot at turn boundaries in think() via fboundp-guarded snapshot-memory call. Context debugging: /context why <id> shows memory object type, scope, version. /context dropped placeholder (deferred to v0.8.0). - core-reason: auto-snapshot in think() + 1 test - channel-tui-main: /rewind, /sessions, /context why, /context dropped + 3 tests - Core: 85/85 TUI Main: 88/89 (1 pre-existing flake)
This commit is contained in:
@@ -186,6 +186,22 @@
|
||||
do (add-msg :system (format nil " ~a: ~a"
|
||||
(case role (:user "You") (:agent "Agent") (t "Sys"))
|
||||
preview))))))
|
||||
;; /context why <id> — debug node
|
||||
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
|
||||
(let ((node-id (string-trim '(#\Space) (subseq text 13))))
|
||||
(if (fboundp 'passepartout::memory-object-get)
|
||||
(let ((obj (funcall 'passepartout::memory-object-get node-id)))
|
||||
(if obj
|
||||
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
|
||||
node-id
|
||||
(passepartout::memory-object-type obj)
|
||||
(passepartout::memory-object-scope obj)
|
||||
(passepartout::memory-object-version obj)))
|
||||
(add-msg :system (format nil "Node ~a not found" node-id))))
|
||||
(add-msg :system "Memory not available"))))
|
||||
;; /context dropped — pruned nodes
|
||||
((string-equal text "/context dropped")
|
||||
(add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)"))
|
||||
;; /search command — message search
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
|
||||
(let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8))))
|
||||
@@ -213,6 +229,35 @@
|
||||
content)))
|
||||
(add-msg :system (format nil " #~d: ...~a..." idx preview)))))
|
||||
(add-msg :system (format nil "No matches for '~a'" query)))))
|
||||
;; /rewind command — session rewind
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind "))
|
||||
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
|
||||
(n (handler-case (parse-integer n-str) (error () nil))))
|
||||
(if n
|
||||
(if (fboundp 'passepartout::rollback-memory)
|
||||
(let* ((idx (1- n))
|
||||
(snaps passepartout::*memory-snapshots*)
|
||||
(ts (when (< idx (length snaps))
|
||||
(getf (nth idx snaps) :timestamp))))
|
||||
(funcall 'passepartout::rollback-memory idx)
|
||||
(add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts)))
|
||||
(add-msg :system "Memory rollback not available"))
|
||||
(add-msg :system "Usage: /rewind <number>"))))
|
||||
;; /sessions command — list snapshots
|
||||
((string-equal text "/sessions")
|
||||
(let ((snaps passepartout::*memory-snapshots*))
|
||||
(if snaps
|
||||
(let ((shown (subseq snaps 0 (min 10 (length snaps)))))
|
||||
(add-msg :system (format nil "~d snapshots (showing ~d):"
|
||||
(length snaps) (length shown)))
|
||||
(loop for s in shown
|
||||
for i from 0
|
||||
for ts = (getf s :timestamp)
|
||||
for data = (getf s :data)
|
||||
for size = (hash-table-size data)
|
||||
do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d"
|
||||
(1+ i) size ts))))
|
||||
(add-msg :system "No snapshots available"))))
|
||||
((string-equal text "/help")
|
||||
(add-msg :system
|
||||
"/focus <proj> Set project context")
|
||||
@@ -1020,5 +1065,35 @@
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs 3))) ;; "Found 2" is 4th message (after 3 chat msgs)
|
||||
(m (aref msgs 3)))
|
||||
(fiveam:is (search "Found 2" (getf m :content)))))
|
||||
|
||||
(fiveam:test test-rewind-command
|
||||
"Contract v0.7.2: /rewind shows usage when no snapshots."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/rewind 1" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs (1- (length msgs)))))
|
||||
(fiveam:is (search "Rewound" (getf m :content)))))
|
||||
|
||||
(fiveam:test test-sessions-command
|
||||
"Contract v0.7.2: /sessions shows snapshot count."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/sessions" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs 0)))
|
||||
(fiveam:is (search "snapshots" (getf m :content)))))
|
||||
|
||||
(fiveam:test test-context-why-command
|
||||
"Contract v0.7.2: /context why <id> shows node info or not-found."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/context why xyz-nonexistent" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs 0)))
|
||||
(fiveam:is (search "not found" (getf m :content)))))
|
||||
|
||||
@@ -95,6 +95,9 @@
|
||||
context-window gate-count rules-count)))
|
||||
|
||||
(defun think (context)
|
||||
;; v0.7.2: auto-snapshot at turn boundaries
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory))
|
||||
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
|
||||
(active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
@@ -470,3 +473,17 @@ sorted by priority (highest first). Returns a rejection plist or the action."
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
|
||||
@@ -220,6 +220,22 @@ Event handlers + daemon I/O + main loop.
|
||||
do (add-msg :system (format nil " ~a: ~a"
|
||||
(case role (:user "You") (:agent "Agent") (t "Sys"))
|
||||
preview))))))
|
||||
;; /context why <id> — debug node
|
||||
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
|
||||
(let ((node-id (string-trim '(#\Space) (subseq text 13))))
|
||||
(if (fboundp 'passepartout::memory-object-get)
|
||||
(let ((obj (funcall 'passepartout::memory-object-get node-id)))
|
||||
(if obj
|
||||
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
|
||||
node-id
|
||||
(passepartout::memory-object-type obj)
|
||||
(passepartout::memory-object-scope obj)
|
||||
(passepartout::memory-object-version obj)))
|
||||
(add-msg :system (format nil "Node ~a not found" node-id))))
|
||||
(add-msg :system "Memory not available"))))
|
||||
;; /context dropped — pruned nodes
|
||||
((string-equal text "/context dropped")
|
||||
(add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)"))
|
||||
;; /search command — message search
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search "))
|
||||
(let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8))))
|
||||
@@ -247,6 +263,35 @@ Event handlers + daemon I/O + main loop.
|
||||
content)))
|
||||
(add-msg :system (format nil " #~d: ...~a..." idx preview)))))
|
||||
(add-msg :system (format nil "No matches for '~a'" query)))))
|
||||
;; /rewind command — session rewind
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind "))
|
||||
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
|
||||
(n (handler-case (parse-integer n-str) (error () nil))))
|
||||
(if n
|
||||
(if (fboundp 'passepartout::rollback-memory)
|
||||
(let* ((idx (1- n))
|
||||
(snaps passepartout::*memory-snapshots*)
|
||||
(ts (when (< idx (length snaps))
|
||||
(getf (nth idx snaps) :timestamp))))
|
||||
(funcall 'passepartout::rollback-memory idx)
|
||||
(add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts)))
|
||||
(add-msg :system "Memory rollback not available"))
|
||||
(add-msg :system "Usage: /rewind <number>"))))
|
||||
;; /sessions command — list snapshots
|
||||
((string-equal text "/sessions")
|
||||
(let ((snaps passepartout::*memory-snapshots*))
|
||||
(if snaps
|
||||
(let ((shown (subseq snaps 0 (min 10 (length snaps)))))
|
||||
(add-msg :system (format nil "~d snapshots (showing ~d):"
|
||||
(length snaps) (length shown)))
|
||||
(loop for s in shown
|
||||
for i from 0
|
||||
for ts = (getf s :timestamp)
|
||||
for data = (getf s :data)
|
||||
for size = (hash-table-size data)
|
||||
do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d"
|
||||
(1+ i) size ts))))
|
||||
(add-msg :system "No snapshots available"))))
|
||||
((string-equal text "/help")
|
||||
(add-msg :system
|
||||
"/focus <proj> Set project context")
|
||||
@@ -1067,6 +1112,36 @@ Event handlers + daemon I/O + main loop.
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs 3))) ;; "Found 2" is 4th message (after 3 chat msgs)
|
||||
(m (aref msgs 3)))
|
||||
(fiveam:is (search "Found 2" (getf m :content)))))
|
||||
|
||||
(fiveam:test test-rewind-command
|
||||
"Contract v0.7.2: /rewind shows usage when no snapshots."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/rewind 1" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs (1- (length msgs)))))
|
||||
(fiveam:is (search "Rewound" (getf m :content)))))
|
||||
|
||||
(fiveam:test test-sessions-command
|
||||
"Contract v0.7.2: /sessions shows snapshot count."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/sessions" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs 0)))
|
||||
(fiveam:is (search "snapshots" (getf m :content)))))
|
||||
|
||||
(fiveam:test test-context-why-command
|
||||
"Contract v0.7.2: /context why <id> shows node info or not-found."
|
||||
(init-state)
|
||||
(dolist (ch (coerce "/context why xyz-nonexistent" 'list))
|
||||
(on-key (char-code ch)))
|
||||
(on-key 13)
|
||||
(let* ((msgs (st :messages))
|
||||
(m (aref msgs 0)))
|
||||
(fiveam:is (search "not found" (getf m :content)))))
|
||||
#+end_src
|
||||
|
||||
@@ -250,6 +250,9 @@ each cascade call via ~cost-track-backend-call~. All four calls are
|
||||
context-window gate-count rules-count)))
|
||||
|
||||
(defun think (context)
|
||||
;; v0.7.2: auto-snapshot at turn boundaries
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory))
|
||||
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
|
||||
(active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
@@ -680,4 +683,18 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
#+end_src
|
||||
|
||||
Reference in New Issue
Block a user