Amr Gharbeia
029a32ef64
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)
490 lines
25 KiB
Common Lisp
490 lines
25 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
|
"Maps provider keyword → handler function (prompt system-prompt &key model).")
|
|
|
|
(defun register-probabilistic-backend (name fn)
|
|
"Register FN as the handler for provider NAME."
|
|
(setf (gethash name *probabilistic-backends*) fn))
|
|
|
|
(defvar *backend-registry* (make-hash-table :test 'equal))
|
|
|
|
(defvar *provider-cascade* nil)
|
|
|
|
(defvar *model-selector* nil)
|
|
|
|
(defvar *consensus-enabled* nil)
|
|
|
|
(defun backend-register (name fn)
|
|
(setf (gethash name *backend-registry*) fn))
|
|
|
|
(defun backend-cascade-call (prompt &key
|
|
(system-prompt "You are the Probabilistic engine.")
|
|
(cascade nil)
|
|
(context nil)
|
|
tools)
|
|
(let ((backends (or cascade *provider-cascade*))
|
|
(result nil))
|
|
(dolist (backend backends (or result
|
|
(list :type :LOG
|
|
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
|
|
(let ((backend-fn (or (gethash backend *backend-registry*)
|
|
(gethash backend *probabilistic-backends*))))
|
|
(when backend-fn
|
|
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
|
(let* ((model (and *model-selector*
|
|
(funcall *model-selector* backend context)))
|
|
(skip (eq model :skip))
|
|
(r (unless skip
|
|
(apply backend-fn
|
|
(append (list prompt system-prompt :model model)
|
|
(when tools (list :tools tools)))))))
|
|
(when skip
|
|
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
|
|
(cond ((and (listp r) (eq (getf r :status) :success))
|
|
(let ((tool-calls (getf r :tool-calls)))
|
|
(if tool-calls
|
|
(return (list :status :success :tool-calls tool-calls))
|
|
(progn
|
|
(setf result (getf r :content))
|
|
(return result)))))
|
|
((stringp r)
|
|
(setf result r)
|
|
(return result))
|
|
(t
|
|
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
|
backend (getf r :message))))))))))
|
|
|
|
(defun markdown-strip (text)
|
|
(if (and text (stringp text))
|
|
(let ((cleaned text))
|
|
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
|
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
|
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
|
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
|
text))
|
|
|
|
(defun plist-keywords-normalize (plist)
|
|
(when (listp plist)
|
|
(loop for (k v) on plist by #'cddr
|
|
collect (if (and (symbolp k) (not (keywordp k)))
|
|
(intern (string k) :keyword)
|
|
k)
|
|
collect v)))
|
|
|
|
;; v0.7.2: live config section for system prompt
|
|
(defun assemble-config-section ()
|
|
"Build the CONFIG section of the system prompt from live state."
|
|
(let ((provider-names "")
|
|
(context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit))
|
|
(tokenizer-context-limit (symbol-value '*tokenizer-provider*))
|
|
8192))
|
|
(gate-count 10)
|
|
(rules-count 0))
|
|
(when (boundp '*provider-cascade*)
|
|
(setf provider-names
|
|
(format nil "~{~a~^, ~}"
|
|
(mapcar (lambda (p)
|
|
(handler-case (or (getf p :model) (getf p :provider) "")
|
|
(error () (princ-to-string p))))
|
|
(symbol-value '*provider-cascade*)))))
|
|
(when (boundp '*hitl-pending*)
|
|
(setf rules-count (hash-table-count (symbol-value '*hitl-pending*))))
|
|
(format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org."
|
|
(if (string= provider-names "") "default" provider-names)
|
|
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))
|
|
(reply-stream (proto-get context :reply-stream)) ; v0.7.1: streaming
|
|
(global-context (if (fboundp 'context-assemble-cached)
|
|
(context-assemble-cached context sensor)
|
|
(if (fboundp 'context-assemble-global-awareness)
|
|
(context-assemble-global-awareness)
|
|
"[Awareness skill not loaded]")))
|
|
(system-logs (if (fboundp 'context-get-system-logs)
|
|
(context-get-system-logs)
|
|
"[No system logs available]"))
|
|
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
|
|
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
|
|
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
|
(raw-prompt (if prompt-generator
|
|
(funcall prompt-generator context)
|
|
(let ((p (proto-get (proto-get context :payload) :text)))
|
|
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
|
(reflection-feedback (if rejection-trace
|
|
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
|
|
""))
|
|
(standing-mandates-text (let ((out ""))
|
|
(dolist (fn *standing-mandates*)
|
|
(let ((text (ignore-errors (funcall fn context))))
|
|
(when (and text (stringp text) (> (length text) 0))
|
|
(setf out (concatenate 'string out text (string #\Newline))))))
|
|
(when (> (length out) 0) out)))
|
|
(identity-content (if (fboundp 'agent-identity) ; v0.7.2: symbolic identity
|
|
(agent-identity)
|
|
""))
|
|
(config-section (if (fboundp 'assemble-config-section) ; v0.7.2: live config
|
|
(assemble-config-section)
|
|
""))
|
|
(time-section (if (fboundp 'sensor-time-duration) ; v0.6.0: temporal awareness
|
|
(format-time-for-llm
|
|
:session-duration-seconds (funcall (symbol-function 'session-duration)))
|
|
(if (fboundp 'format-time-for-llm)
|
|
(format-time-for-llm)
|
|
"")))
|
|
(system-prompt (if (fboundp 'prompt-prefix-cached)
|
|
;; v0.5.0: cached prefix with optional budget enforcement
|
|
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
|
|
reflection-feedback
|
|
standing-mandates-text tool-belt)))
|
|
(if (fboundp 'enforce-token-budget)
|
|
(multiple-value-bind (pfx ctxt logs _ mandates)
|
|
(enforce-token-budget prefix global-context system-logs
|
|
raw-prompt standing-mandates-text)
|
|
(declare (ignore _))
|
|
(setf standing-mandates-text mandates)
|
|
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
|
time-section config-section pfx (or ctxt "") logs))
|
|
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
|
time-section config-section prefix (or global-context "") system-logs)))
|
|
;; Fallback when token-economics not loaded
|
|
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
|
|
time-section config-section
|
|
assistant-name identity-content reflection-feedback
|
|
(if standing-mandates-text
|
|
(concatenate 'string (string #\Newline) standing-mandates-text)
|
|
"")
|
|
tool-belt (or global-context "") system-logs))))
|
|
(let* ((thought (if (and reply-stream (fboundp 'cascade-stream)) ; v0.7.1: streaming
|
|
(let ((acc (make-string-output-stream)))
|
|
(funcall 'cascade-stream raw-prompt system-prompt
|
|
(lambda (delta)
|
|
(when reply-stream
|
|
(format reply-stream "~a"
|
|
(frame-message (list :type :stream-chunk
|
|
:payload (list :text delta))))
|
|
(finish-output reply-stream))
|
|
(write-string delta acc)))
|
|
(get-output-stream-string acc))
|
|
(backend-cascade-call raw-prompt
|
|
:system-prompt system-prompt
|
|
:context context)))
|
|
(tool-calls (and (listp thought) (getf thought :tool-calls))))
|
|
;; v0.5.0: cost tracking after successful cascade
|
|
(when (and (fboundp 'cost-track-backend-call)
|
|
(stringp thought)
|
|
(or (null tool-calls)))
|
|
(ignore-errors
|
|
(cost-track-backend-call (first *provider-cascade*)
|
|
(format nil "~a~%~a" system-prompt raw-prompt)
|
|
thought)))
|
|
(if tool-calls
|
|
(let* ((first-call (car tool-calls))
|
|
(tool-name (getf first-call :name))
|
|
(args (getf first-call :arguments))
|
|
(args-plist (json-alist-to-plist args)))
|
|
(list :TYPE :REQUEST
|
|
:PAYLOAD (list* :TOOL tool-name
|
|
:ARGS args-plist
|
|
:EXPLANATION "Generated by function-calling engine.")))
|
|
(let* ((cleaned (if (and (listp thought) (getf thought :type))
|
|
(format nil "~a" (getf (getf thought :payload) :text))
|
|
(markdown-strip thought))))
|
|
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
|
(handler-case
|
|
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
|
|
(if (listp parsed)
|
|
(let ((normalized (plist-keywords-normalize parsed)))
|
|
;; Ensure explanation is present in the payload for policy gate
|
|
(let ((payload (proto-get normalized :payload)))
|
|
(if (and payload (proto-get payload :explanation))
|
|
normalized
|
|
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
|
|
(if (listp payload) payload nil))))
|
|
(list* :PAYLOAD new-payload
|
|
(loop for (k v) on normalized by #'cddr
|
|
unless (eq k :PAYLOAD)
|
|
collect k collect v))))))
|
|
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
|
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
|
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))))
|
|
|
|
(defun json-alist-to-plist (alist)
|
|
"Convert a JSON alist to a keyword-prefixed plist."
|
|
(when (listp alist)
|
|
(loop for (key . value) in alist
|
|
append (list (intern (string-upcase (string key)) :keyword)
|
|
(if (listp value)
|
|
(if (consp (car value))
|
|
(json-alist-to-plist value)
|
|
value)
|
|
value)))))
|
|
|
|
(defun cognitive-verify (proposed-action context)
|
|
"Runs all registered deterministic gates against the proposed action,
|
|
sorted by priority (highest first). Returns a rejection plist or the action."
|
|
(let ((current-action (copy-tree proposed-action))
|
|
(approval-needed nil)
|
|
(approval-action nil)
|
|
(gates nil)
|
|
(gate-trace nil))
|
|
;; Collect gates sorted by priority (highest first)
|
|
(maphash (lambda (name skill)
|
|
(declare (ignore name))
|
|
(when (skill-deterministic-fn skill)
|
|
(push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
|
|
*skill-registry*)
|
|
(setf gates (sort gates #'> :key #'car))
|
|
(dolist (gate-entry gates)
|
|
(let* ((gate-name (cadr gate-entry))
|
|
(result (funcall (cddr gate-entry) current-action context)))
|
|
(cond
|
|
((eq (getf result :level) :approval-required)
|
|
(push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
|
|
(setf approval-needed t
|
|
approval-action (getf (getf result :payload) :action)))
|
|
((member (getf result :type) '(:LOG :EVENT))
|
|
(push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
|
|
(let ((blocked-result (copy-list result)))
|
|
(setf (getf blocked-result :gate-trace) (nreverse gate-trace))
|
|
(return-from cognitive-verify blocked-result)))
|
|
((and (listp result) result)
|
|
(push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
|
|
(setf current-action result)))))
|
|
(if approval-needed
|
|
(list :type :EVENT :level :approval-required
|
|
:gate-trace (nreverse gate-trace)
|
|
:payload (list :sensor :approval-required
|
|
:action approval-action))
|
|
(let ((passed-result (copy-tree current-action)))
|
|
(setf (getf passed-result :gate-trace) (nreverse gate-trace))
|
|
passed-result))))
|
|
|
|
(defun loop-gate-reason (signal)
|
|
(let* ((type (proto-get signal :type))
|
|
(payload (proto-get signal :payload))
|
|
(sensor (proto-get payload :sensor)))
|
|
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
|
(return-from loop-gate-reason signal))
|
|
(let ((retries 3)
|
|
(current-signal (copy-tree signal))
|
|
(last-rejection nil))
|
|
(loop
|
|
(when (<= retries 0)
|
|
(setf (getf signal :approved-action) last-rejection)
|
|
(setf (getf signal :status) :reasoned)
|
|
(return signal))
|
|
(when last-rejection
|
|
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
|
(let ((candidate (think current-signal)))
|
|
(if (and candidate (listp candidate))
|
|
(let ((verified (cognitive-verify candidate current-signal)))
|
|
;; Approval-required is not a rejection — pass to act for Flight Plan
|
|
(if (eq (getf verified :level) :approval-required)
|
|
(progn
|
|
(setf (getf signal :approved-action) verified)
|
|
(setf (getf signal :status) :requires-approval)
|
|
(return signal))
|
|
;; Hard rejection: retry with feedback
|
|
(if (member (getf verified :type) '(:LOG :EVENT))
|
|
(progn (decf retries) (setf last-rejection verified))
|
|
(progn
|
|
(setf (getf signal :approved-action) verified)
|
|
(setf (getf signal :status) :reasoned)
|
|
(return signal)))))
|
|
(progn
|
|
(setf (getf signal :approved-action) nil)
|
|
(setf (getf signal :status) :reasoned)
|
|
(return signal))))))))
|
|
|
|
(defun reason-gate (signal)
|
|
(loop-gate-reason signal))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-pipeline-reason-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:pipeline-reason-suite))
|
|
|
|
(in-package :passepartout-pipeline-reason-tests)
|
|
|
|
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
|
(in-suite pipeline-reason-suite)
|
|
|
|
(test test-decide-gate-safety
|
|
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
|
(clrhash passepartout::*skill-registry*)
|
|
(passepartout::defskill :mock-safety
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
|
:deterministic (lambda (action ctx)
|
|
(declare (ignore ctx))
|
|
(if (search "rm -rf" (format nil "~s" action))
|
|
(list :type :LOG :payload (list :text "Rejected"))
|
|
action)))
|
|
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
|
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
|
(result (cognitive-verify candidate signal)))
|
|
(is (eq :LOG (getf result :type)))))
|
|
|
|
(test test-cognitive-verify-pass-through
|
|
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
|
(clrhash passepartout::*skill-registry*)
|
|
(passepartout::defskill :mock-passthrough
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
|
:deterministic (lambda (action ctx)
|
|
(declare (ignore ctx))
|
|
action))
|
|
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
|
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
|
(result (cognitive-verify candidate signal)))
|
|
(is (eq :REQUEST (getf result :type)))
|
|
(is (equal (getf candidate :payload) (getf result :payload)))
|
|
(is (getf result :gate-trace))))
|
|
|
|
(test test-cognitive-verify-empty-registry
|
|
"Contract 1: with no gates registered, action passes through unchanged."
|
|
(clrhash passepartout::*skill-registry*)
|
|
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
|
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
|
(result (cognitive-verify candidate signal)))
|
|
(is (eq :REQUEST (getf result :type)))
|
|
(is (equal (getf candidate :payload) (getf result :payload)))))
|
|
|
|
(test test-cognitive-verify-approval-required
|
|
"Contract 1: gate returning :approval-required produces an approval event."
|
|
(clrhash passepartout::*skill-registry*)
|
|
(passepartout::defskill :mock-approval
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
|
:deterministic (lambda (action ctx)
|
|
(declare (ignore ctx))
|
|
(list :type :EVENT :level :approval-required
|
|
:payload (list :action action))))
|
|
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
|
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
|
(result (cognitive-verify candidate signal)))
|
|
(is (eq :approval-required (getf result :level)))
|
|
(is (eq :EVENT (getf result :type)))))
|
|
|
|
(test test-loop-gate-reason-passthrough
|
|
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
|
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
|
(result (loop-gate-reason signal)))
|
|
(is (not (null result)))))
|
|
|
|
(test test-loop-gate-reason-sets-status
|
|
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
|
(clrhash passepartout::*skill-registry*)
|
|
(let* ((passepartout::*provider-cascade* nil)
|
|
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
|
(result (loop-gate-reason signal)))
|
|
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
|
|
|
(test test-backend-cascade-no-backends
|
|
"Contract 4: empty cascade returns :LOG failure."
|
|
(let* ((passepartout::*provider-cascade* nil)
|
|
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
|
(result (backend-cascade-call "test" :cascade '())))
|
|
(is (eq :LOG (getf result :type)))
|
|
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
|
|
|
(test test-backend-cascade-with-mock
|
|
"Contract 4: backend-cascade-call returns content from first successful backend."
|
|
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
|
|
(setf (gethash :mock-backend passepartout::*backend-registry*)
|
|
(lambda (prompt sp &key model)
|
|
(declare (ignore prompt sp model))
|
|
(list :status :success :content "mock-response")))
|
|
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
|
(is (string= "mock-response" result)))))
|
|
|
|
(test test-read-eval-rce-blocked
|
|
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
|
|
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
|
|
(passepartout::*provider-cascade* '(:mock-evil)))
|
|
(setf (gethash :mock-evil passepartout::*backend-registry*)
|
|
(lambda (prompt sp &key model)
|
|
(declare (ignore prompt sp model))
|
|
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
|
|
(setf passepartout::*v031-rce-test* nil)
|
|
(setf *read-eval* t)
|
|
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
|
|
(result (passepartout::think ctx)))
|
|
(is (not (eq passepartout::*v031-rce-test* :PWNED)))
|
|
(is (eq :REQUEST (getf result :TYPE)))
|
|
(setf *read-eval* nil))))
|
|
|
|
(test test-json-alist-to-plist-simple
|
|
"Contract 5: converts simple alist to keyword plist."
|
|
(let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello"))))
|
|
(let ((result (json-alist-to-plist alist)))
|
|
(is (eq :ACTION (first result)))
|
|
(is (string= "shell" (second result)))
|
|
(is (eq :CMD (third result)))
|
|
(is (string= "echo hello" (fourth result))))))
|
|
|
|
(test test-json-alist-to-plist-nested
|
|
"Contract 5: nested alists recurse into nested plists."
|
|
(let ((alist (list (cons "tool" "write-file")
|
|
(cons "args" (list (cons "filepath" "/tmp/x")
|
|
(cons "content" "hi"))))))
|
|
(let ((result (json-alist-to-plist alist)))
|
|
(is (eq :TOOL (first result)))
|
|
(is (eq :ARGS (third result)))
|
|
(let ((inner (fourth result)))
|
|
(is (eq :FILEPATH (first inner)))
|
|
(is (string= "/tmp/x" (second inner)))
|
|
(is (eq :CONTENT (third inner)))))))
|
|
|
|
(test test-json-alist-to-plist-array-passthrough
|
|
"Contract 5: JSON arrays pass through unchanged."
|
|
(let ((alist (list (cons "names" (list "alice" "bob")))))
|
|
(let ((result (json-alist-to-plist alist)))
|
|
(is (eq :NAMES (first result)))
|
|
(is (equal (list "alice" "bob") (second result))))))
|
|
|
|
(test test-json-alist-to-plist-null
|
|
"Contract 5: nil passes through unchanged."
|
|
(let ((result (json-alist-to-plist nil)))
|
|
(is (null result))))
|
|
|
|
(test test-json-alist-to-plist-scalar
|
|
"Contract 5: scalar values pass through."
|
|
(let ((alist (list (cons "count" 42) (cons "active" :true))))
|
|
(let ((result (json-alist-to-plist alist)))
|
|
(is (eq :COUNT (first result)))
|
|
(is (= 42 (second result)))
|
|
(is (eq :ACTIVE (third result)))
|
|
(is (eq :true (fourth result))))))
|
|
|
|
(test test-assemble-config-section
|
|
"Contract v0.7.2: config section contains Passepartout and version."
|
|
(let ((section (passepartout::assemble-config-section)))
|
|
(is (stringp section))
|
|
(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)))))
|