v0.8.0: TUI stabilization, command palette reverse-video highlight, hint bar redesign
- ROADMAP: consolidate all TUI work under v0.8.0 (removed premature v0.9.0/v0.10.x labels), restored original v0.9.0 eval harness plan - channel-tui-view.org: Emacs-style reverse-video cursor (swap fg/bg instead of drawing █), hint bar now shows F:focus/MCP:count on left and token gauge + keybindings on right, sidebar reorganized to show GATE TRACE, RULES + BLOCK COUNT, COST, FILES panels - channel-tui-main.org: command palette selection now uses reverse-video highlight (bg-input fg on input-fg bg, matching cursor style), fixed cond order so sel-p is checked before cat (all items had :category making sel-p unreachable), added session-cost extraction from daemon - passepartout: export COLORTERM=truecolor for modern backend detection
This commit is contained in:
368
lisp/core-skills.lisp
Normal file
368
lisp/core-skills.lisp
Normal file
@@ -0,0 +1,368 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
(defun vector-cosine-similarity (v1 v2)
|
||||
"Computes cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
|
||||
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"Tracks all discovered skill files and their loading state.")
|
||||
|
||||
(defvar *standing-mandates* nil
|
||||
"List of functions (context) → string-or-nil. Each is called on every think() cycle.
|
||||
When non-nil, the returned string is injected into the IDENTITY section of the system prompt.
|
||||
Unlike skills (which activate on triggers), standing mandates are always consulted.")
|
||||
|
||||
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
||||
|
||||
;; Alias: find-triggered-skill → skill-triggered-find
|
||||
(defun find-triggered-skill (context)
|
||||
(skill-triggered-find context))
|
||||
|
||||
(defun skill-triggered-find (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skill-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic)
|
||||
"Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skill-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
|
||||
(defun skill-dependencies-resolve (skill-name)
|
||||
"Resolves transitive dependencies. Returns list of skill names in dependency order."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skill-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
|
||||
(defun skill-metadata-parse (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
|
||||
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
|
||||
(unless (string= d "") (push d dependencies))))
|
||||
(setf pos end)))))
|
||||
(values id (reverse dependencies))))
|
||||
|
||||
(defun skill-topological-sort (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency."
|
||||
(let* ((org-files (uiop:directory-files skills-dir "*.org"))
|
||||
(lisp-files (uiop:directory-files skills-dir "*.lisp"))
|
||||
(all-files (append org-files lisp-files))
|
||||
(files (remove-if (lambda (f)
|
||||
(let ((n (pathname-name f)))
|
||||
(or (string= n "core-package")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-transport")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-perceive")
|
||||
(string= n "core-reason")
|
||||
(string= n "core-act")
|
||||
(string= n "core-pipeline")
|
||||
(string= n "core-manifest")
|
||||
(string= n "neuro-router")
|
||||
(string= n "neuro-explorer")
|
||||
(string= n "channel-tui"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(progn
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(unless (gethash (string-downcase filename) adj)
|
||||
(setf (gethash (string-downcase filename) adj) nil)))
|
||||
(multiple-value-bind (id deps) (skill-metadata-parse file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps)))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected")
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
|
||||
(defun lisp-syntax-validate (code-string)
|
||||
"Checks if a string contains valid Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun skill-package-forms-strip (code-string)
|
||||
"Removes (in-package :passepartout) forms only — preserves test-package
|
||||
declarations so embedded test code evaluates in the correct package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(if (uiop:string-prefix-p "(in-package :passepartout)" trimmed)
|
||||
(setf result (concatenate 'string result (string #\Newline)))
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun tangle-target-extract (line)
|
||||
"Extracts the value of the :tangle header."
|
||||
(let ((pos (search ":tangle" line)))
|
||||
(when pos
|
||||
(let ((rest (string-tirm '(#\Space #\Tab) (subseq line (+ pos 7)))))
|
||||
(let ((end (position #\Space rest)))
|
||||
(if end (subseq rest 0 end) rest))))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (collect-this-block nil) (lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" clean-line)
|
||||
(setf in-lisp-block t)
|
||||
(let ((target (tangle-target-extract clean-line)))
|
||||
(setf collect-this-block (or (null target)
|
||||
(and (not (search "no" target))
|
||||
(not (search "/tests" target)))))))
|
||||
((uiop:string-prefix-p "#+end_src" clean-line)
|
||||
(setf in-lisp-block nil) (setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":ID:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
(if (= (length lisp-code) 0)
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
|
||||
(unless valid-p (error err)))
|
||||
;; Pre-eval sandbox scan: block before any code executes
|
||||
(multiple-value-bind (blocked-p blocked-syms)
|
||||
(skill-source-scan lisp-code)
|
||||
(when blocked-p
|
||||
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
|
||||
skill-base-name blocked-syms)
|
||||
(setf (skill-entry-status entry) :sandbox-blocked)
|
||||
(return-from load-skill-from-org nil)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg)))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defvar *skill-restricted-symbols*
|
||||
'("uiop:run-program" "uiop:shell" "uiop:run-shell-command"
|
||||
"bt:make-thread" "bordeaux-threads:make-thread"
|
||||
"usocket:socket-connect" "usocket:socket-listen"
|
||||
"hunchentoot:start" "hunchentoot:accept-connections")
|
||||
"Symbol patterns blocked from skill source code at load time.")
|
||||
|
||||
(defun skill-source-scan (code-string)
|
||||
"Scans CODE-STRING for restricted symbol references.
|
||||
Returns (values blocked-p matched-symbols)."
|
||||
(let ((lower (string-downcase code-string))
|
||||
(matches nil))
|
||||
(dolist (pattern *skill-restricted-symbols*)
|
||||
(when (search pattern lower)
|
||||
(push pattern matches)))
|
||||
(values (and matches t) (nreverse matches))))
|
||||
|
||||
(defun load-skill-from-lisp (filepath)
|
||||
"Loads a .lisp skill file directly, filtering out in-package forms."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (skill-package-forms-strip (uiop:read-file-string filepath)))
|
||||
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
|
||||
(unless valid-p (error err)))
|
||||
;; Pre-eval sandbox scan: block before any code executes
|
||||
(multiple-value-bind (blocked-p blocked-syms)
|
||||
(skill-source-scan content)
|
||||
(when blocked-p
|
||||
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
|
||||
skill-base-name blocked-syms)
|
||||
(setf (skill-entry-status entry) :sandbox-blocked)
|
||||
(return-from load-skill-from-lisp nil)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(with-input-from-string (s content)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
(let* ((jailed-pkg (find-package pkg-name))
|
||||
(restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND"))
|
||||
(violation (loop for r in restricted
|
||||
for sym = (find-symbol r :uiop)
|
||||
when (and sym (fboundp sym)
|
||||
(loop for skill-sym being the symbols of jailed-pkg
|
||||
when (and (fboundp skill-sym)
|
||||
(eq (symbol-function skill-sym)
|
||||
(symbol-function sym)))
|
||||
return skill-sym))
|
||||
collect (format nil "~a" sym))))
|
||||
(when violation
|
||||
(log-message "LOADER SANDBOX: Skill '~a' blocked — references restricted symbol(s): ~{~a~^, ~}"
|
||||
skill-base-name violation)
|
||||
(setf (skill-entry-status entry) :sandbox-blocked)
|
||||
(return-from load-skill-from-lisp nil))
|
||||
(log-message "LOADER SANDBOX: Skill '~a' passed sandbox check" skill-base-name))
|
||||
(let ((target-pkg (find-package :passepartout))
|
||||
(exported 0)
|
||||
(seen (make-hash-table :test 'equal)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
||||
(or (fboundp sym) (boundp sym))
|
||||
(not (gethash (symbol-name sym) seen)))
|
||||
(setf (gethash (symbol-name sym) seen) t)
|
||||
(incf exported)
|
||||
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
||||
(when existing (unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(ignore-errors (export sym target-pkg))))
|
||||
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
||||
exported (package-name (find-package pkg-name))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defun skill-initialize-all ()
|
||||
"Initializes all skills from the XDG data directory."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "lisp/" (uiop:ensure-directory-pathname data-dir))))
|
||||
(unless (uiop:directory-exists-p skills-dir) (return-from skill-initialize-all nil))
|
||||
(let ((sorted-files (skill-topological-sort skills-dir)))
|
||||
(log-message "LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
(dolist (file sorted-files)
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(log-message "LOADER: Boot Complete."))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
Reference in New Issue
Block a user