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

v0.8.1: deduplication cleanup — remove duplicate defpackage/defvar blocks from programming-tools, duplicate plist-keywords-normalize from programming-lisp, duplicate *VAULT-MEMORY* from security-vault; TUI defensive fixes — add word-wrap function, wrap on-key in ignore-errors; daemon startup hardening — optional skill loads with handler-case

Browse Source
This commit is contained in:
Amr Gharbeia
2026-05-10 07:10:47 -04:00
parent 2ac87b626a
commit 27d203ad67
11 changed files with 78 additions and 271 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1181,7 +1181,7 @@
(recreate-windows (or (width scr) 80) (or (height scr) 24))
(redraw sw cw ch iw)
(refresh scr))
(t (on-key ch))))
(t (ignore-errors (on-key ch)))))
(redraw sw cw ch iw)
(when sidebar-w
(view-sidebar sidebar-w)

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

@@ -73,7 +73,7 @@
(search-highlight content (st :search-query))
content))
(line-text (format nil "~a [~a] ~a" prefix time content-show))
(wrapped (word-wrap line-text (- w 2)))
(wrapped (passepartout::word-wrap line-text (- w 2)))
(nlines (length wrapped)))
(if (<= nlines lines-remaining)
(progn (decf lines-remaining nlines) (incf msg-count))
@@ -95,7 +95,7 @@
(search-highlight content (st :search-query))
content))
(line-text (format nil "~a [~a] ~a" prefix time content-show))
(wrapped (word-wrap line-text (- w 2))))
(wrapped (passepartout::word-wrap line-text (- w 2))))
;; HITL panel: render with colored border
(when is-panel
(setf color (if is-resolved
@@ -160,6 +160,34 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
((<= #xFE00 code #xFE0F) 0)
(t 1))))
(defun word-wrap (text max-width)
"Split TEXT into lines that fit within MAX-WIDTH columns.
Word-breaks at spaces when possible; breaks mid-word if necessary.
Respects CJK/emoji char widths via char-width."
(let ((lines nil)
(start 0)
(end (length text)))
(loop while (< start end) do
(let* ((col 0)
(pos start)
(last-break start))
(loop while (< pos end)
for width = (char-width (char text pos)) do
(when (char= (char text pos) #\Space)
(setf last-break pos))
(when (> (+ col width) max-width)
(return))
(incf col width)
(incf pos)
(when (>= pos end) (return)))
(let ((line-end (if (> pos start) pos (1+ start))))
(when (>= line-end end) (setf line-end end))
(push (subseq text start line-end) lines)
(setf start (if (and (< line-end end) (char= (char text line-end) #\Space))
(1+ line-end)
line-end)))))
(nreverse lines)))
(in-package :passepartout)
(defun parse-markdown-spans (text)

14
lisp/programming-lisp.lisp
View File

@@ -149,20 +149,6 @@
:priority 400
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
(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)))
(defun plist-keywords-normalize (plist)
(when (listp plist)
(loop for (k v) on plist by #'cddr

197
lisp/programming-tools.lisp
View File

@@ -257,203 +257,6 @@
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
(defpackage :passepartout
(:use :cl)
(:export
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:log-message
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:ingest-ast
#:memory-object-get
#:*memory-store*
#:memory-object
#:make-memory-object
#:memory-object-id
#:memory-object-type
#:memory-object-attributes
#:memory-object-parent-id
#:memory-object-children
#:memory-object-version
#:memory-object-last-sync
#:memory-object-vector
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:snapshot-memory
#:rollback-memory
#:context-get-system-logs
#: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
#:loop-gate-perceive
#:act-gate
#:loop-gate-act
#:reason-gate
#:loop-gate-reason
#:cognitive-verify
#:backend-cascade-call
#:json-alist-to-plist
#:inject-stimulus
#:stimulus-inject
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-gate
#:wildcard-match
#:actuator-initialize
#:action-dispatch
#:register-actuator
#:load-skill-from-org
#:skill-initialize-all
#:lisp-syntax-validate
#:defskill
#:*skill-registry*
#:*scope-resolver*
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
#:skill
#:skill-name
#:skill-priority
#:skill-dependencies
#:skill-trigger-fn
#:skill-probabilistic-prompt
#:skill-deterministic-fn
#:def-cognitive-tool
#:*cognitive-tool-registry*
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:literate-tangle-sync-check
#:archivist-create-note
#:gateway-start
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
#:get-oc-config-dir
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:cognitive-tool
#:cognitive-tool-name
#:cognitive-tool-description
#:cognitive-tool-parameters
#:cognitive-tool-guard
#:cognitive-tool-body
#:register-probabilistic-backend
#:*probabilistic-backends*
#:*provider-cascade*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:memory-objects-by-attribute
#:channel-cli-input
#:repl-eval
#:repl-inspect
#:repl-list-vars
#:policy-compliance-check
#:validator-protocol-check
#:archivist-extract-headlines
#:archivist-headline-to-filename
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p))
(in-package :passepartout)
(defun plist-get (plist key)
"Robust plist accessor — checks both :KEY and :key variants."
(let* ((s (string key))
(up (intern (string-upcase s) :keyword))
(dn (intern (string-downcase s) :keyword)))
(or (getf plist up) (getf plist dn))))
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)
(defvar *skill-registry* (make-hash-table :test 'equal)
"Global registry of all loaded skills.")
(defvar *telemetry-table* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
(defun telemetry-track (skill-name duration status)
"Updates performance metrics for a skill. STATUS is :success or :rejected."
(when skill-name
(bordeaux-threads:with-lock-held (*telemetry-lock*)
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
(incf (getf entry :executions))
(incf (getf entry :total-time) duration)
(when (eq status :rejected) (incf (getf entry :failures)))
(setf (gethash skill-name *telemetry-table*) entry)))))
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
(defvar *modified-files-this-turn* nil
"List of plists recording file modifications in the current turn.")

2
lisp/security-vault.lisp
View File

@@ -34,8 +34,6 @@
:priority 600
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))

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

@@ -1300,7 +1300,7 @@ if the user reopens it within the same session. State is per-session only
(recreate-windows (or (width scr) 80) (or (height scr) 24))
(redraw sw cw ch iw)
(refresh scr))
(t (on-key ch))))
(t (ignore-errors (on-key ch)))))
(redraw sw cw ch iw)
(when sidebar-w
(view-sidebar sidebar-w)

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

@@ -218,7 +218,7 @@ that the TUI actuator attaches to the response plist before transmission.
(search-highlight content (st :search-query))
content))
(line-text (format nil "~a [~a] ~a" prefix time content-show))
(wrapped (word-wrap line-text (- w 2)))
(wrapped (passepartout::word-wrap line-text (- w 2)))
(nlines (length wrapped)))
(if (<= nlines lines-remaining)
(progn (decf lines-remaining nlines) (incf msg-count))
@@ -240,7 +240,7 @@ that the TUI actuator attaches to the response plist before transmission.
(search-highlight content (st :search-query))
content))
(line-text (format nil "~a [~a] ~a" prefix time content-show))
(wrapped (word-wrap line-text (- w 2))))
(wrapped (passepartout::word-wrap line-text (- w 2))))
;; HITL panel: render with colored border
(when is-panel
(setf color (if is-resolved
@@ -313,6 +313,34 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
((<= #x20D0 code #x20FF) 0)
((<= #xFE00 code #xFE0F) 0)
(t 1))))
(defun word-wrap (text max-width)
"Split TEXT into lines that fit within MAX-WIDTH columns.
Word-breaks at spaces when possible; breaks mid-word if necessary.
Respects CJK/emoji char widths via char-width."
(let ((lines nil)
(start 0)
(end (length text)))
(loop while (< start end) do
(let* ((col 0)
(pos start)
(last-break start))
(loop while (< pos end)
for width = (char-width (char text pos)) do
(when (char= (char text pos) #\Space)
(setf last-break pos))
(when (> (+ col width) max-width)
(return))
(incf col width)
(incf pos)
(when (>= pos end) (return)))
(let ((line-end (if (> pos start) pos (1+ start))))
(when (>= line-end end) (setf line-end end))
(push (subseq text start line-end) lines)
(setf start (if (and (< line-end end) (char= (char text line-end) #\Space))
(1+ line-end)
line-end)))))
(nreverse lines)))
#+end_src
* v0.7.1 — Markdown Rendering

27
org/programming-lisp.org
View File

@@ -236,33 +236,6 @@ The skill has four layers:
** Plist Keywords Normalize (relocated from core-reason)
Lisp keywords are case-sensitive. The LLM might produce ~:payload~ or ~:PAYLOAD~ depending on the model. This function normalizes keyword keys to uppercase.
#+begin_src lisp
(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)))
#+end_src
** Plist Keywords Normalize (relocated from core-reason)
Lisp keywords are case-sensitive. The LLM might produce :payload or :PAYLOAD depending on the model. This function normalizes keyword keys to uppercase.
#+begin_src lisp

12
org/programming-tools.org
View File

@@ -382,7 +382,7 @@ Surgical text replacement in an Org file — matches exact text and replaces it.
** Package Definition and Export List
The package definition. All public symbols are exported here.
#+begin_src lisp
#+begin_src lisp :tangle no
(defpackage :passepartout
(:use :cl)
(:export
@@ -555,7 +555,7 @@ The package implementation section defines the low-level utilities and global st
*** Robust plist access (plist-get)
Retrieves a value from a plist, checking both upper and lowercase keyword variants. This is needed because different components use different keyword conventions.
#+begin_src lisp
#+begin_src lisp :tangle no
(in-package :passepartout)
(defun plist-get (plist key)
@@ -568,7 +568,7 @@ Retrieves a value from a plist, checking both upper and lowercase keyword varian
*** Logging state
The harness maintains a bounded ring buffer of log messages for inclusion in LLM context. Access is thread-safe via a lock.
#+begin_src lisp
#+begin_src lisp :tangle no
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)
@@ -576,14 +576,14 @@ The harness maintains a bounded ring buffer of log messages for inclusion in LLM
*** Skill registry
The global registry of all loaded skills. This is the authoritative list that the deterministic engine iterates.
#+begin_src lisp
#+begin_src lisp :tangle no
(defvar *skill-registry* (make-hash-table :test 'equal)
"Global registry of all loaded skills.")
#+end_src
*** Skill telemetry
Tracks execution metrics per skill (count, duration, failures) for diagnostics and performance analysis.
#+begin_src lisp
#+begin_src lisp :tangle no
(defvar *telemetry-table* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
@@ -600,7 +600,7 @@ Tracks execution metrics per skill (count, duration, failures) for diagnostics a
*** Cognitive tool registry
Tools that the LLM can invoke are registered here. Each tool has a name, description, parameters, optional guard, and implementation body. The ~def-cognitive-tool~ macro handles registration. ~cognitive-tool-prompt~ serialises the registry into the LLM's system prompt.
#+begin_src lisp
#+begin_src lisp :tangle no
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
#+end_src

7
org/security-vault.org
View File

@@ -103,13 +103,6 @@ Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~.
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
#+end_src
** Vault Memory (relocated from core-skills)
#+begin_src lisp
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
#+end_src
* Test Suite
#+begin_src lisp

12
passepartout
View File

@@ -17,7 +17,7 @@ done
export SCRIPT_DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
export PASSEPARTOUT_CONFIG_DIR="$(realpath -m "${XDG_CONFIG_HOME:-$HOME/.config}/passepartout")"
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout")}"
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$(if [ -d "$HOME/memex/projects/passepartout/lisp" ]; then realpath -m "$HOME/memex/projects/passepartout"; else realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout"; fi)}"
export PASSEPARTOUT_STATE_DIR="$(realpath -m "${XDG_STATE_HOME:-$HOME/.local/state}/passepartout")"
export PASSEPARTOUT_BIN_DIR="$(realpath -m "${XDG_BIN_HOME:-$HOME/.local/bin}")"
export PASSEPARTOUT_MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
@@ -349,17 +349,15 @@ case "$COMMAND" in
;;
daemon)
check_dependencies
# Use the script's directory as the data dir (development mode)
# In production, set PASSEPARTOUT_DATA_DIR to your deployment path
export PASSEPARTOUT_DATA_DIR="${PASSEPARTOUT_DATA_DIR:-$SCRIPT_DIR}"
export MEMEX_DIR="${PASSEPARTOUT_MEMEX_DIR:-$HOME/memex}"
echo "Starting daemon (data dir: $PASSEPARTOUT_DATA_DIR)..."
nohup sbcl --non-interactive \
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
--eval "(ql:quickload :passepartout)" \
--eval "(load (format nil \"~alisp/neuro-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
--eval "(load (format nil \"~alisp/embedding-backends.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
--eval "(load (format nil \"~alisp/neuro-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\")))" \
--eval '(ql:quickload :passepartout)' \
--eval "(handler-case (load (format nil \"~alisp/neuro-router.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\"))) (error () nil))" \
--eval "(handler-case (load (format nil \"~alisp/embedding-backends.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\"))) (error () nil))" \
--eval "(handler-case (load (format nil \"~alisp/neuro-explorer.lisp\" (truename \"$PASSEPARTOUT_DATA_DIR/\"))) (error () nil))" \
--eval '(funcall (find-symbol "MAIN" :passepartout))' \
> "$PASSEPARTOUT_STATE_DIR/daemon.log" 2>&1 &
echo "Waiting for port 9105..."