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:
279
lisp/symbolic-archivist.lisp
Normal file
279
lisp/symbolic-archivist.lisp
Normal file
@@ -0,0 +1,279 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *archivist-last-scribe* 0
|
||||
"Universal time of the last Scribe distillation run.")
|
||||
|
||||
(defvar *archivist-last-gardener* 0
|
||||
"Universal time of the last Gardener scan run.")
|
||||
|
||||
(defvar *archivist-gardener-interval* 86400
|
||||
"Seconds between Gardener scans. Default: 24 hours.")
|
||||
|
||||
(defun archivist-scribe-distill ()
|
||||
"Distills daily log entries into atomic notes. Reads the Memex daily/
|
||||
directory for log files modified since the last run, extracts headlines
|
||||
as potential note seeds, and creates atomic note files in notes/ with
|
||||
backlinks to the source daily entry."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(daily-dir (merge-pathnames "daily/" memex-dir))
|
||||
(notes-dir (merge-pathnames "notes/" memex-dir))
|
||||
(now (get-universal-time))
|
||||
(notes-created 0))
|
||||
(unless (uiop:directory-exists-p daily-dir)
|
||||
(log-message "ARCHIVIST: Daily directory not found: ~a" daily-dir)
|
||||
(return-from archivist-scribe-distill nil))
|
||||
(ensure-directories-exist notes-dir)
|
||||
(handler-case
|
||||
(let ((daily-files (uiop:directory-files daily-dir "*.org")))
|
||||
(dolist (file daily-files)
|
||||
(let* ((filepath (namestring file))
|
||||
(file-mtime (ignore-errors (file-write-date filepath))))
|
||||
(when (and file-mtime (> file-mtime *archivist-last-scribe*))
|
||||
;; Extract headlines from daily log
|
||||
(let* ((content (handler-case (uiop:read-file-string filepath)
|
||||
(error () nil)))
|
||||
(headlines (when content
|
||||
(archivist-extract-headlines content))))
|
||||
(dolist (hl headlines)
|
||||
(when (archivist-create-note hl notes-dir filepath)
|
||||
(incf notes-created))))))))
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Scribe error: ~a" c)))
|
||||
(setf *archivist-last-scribe* now)
|
||||
(when (> notes-created 0)
|
||||
(log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created))
|
||||
notes-created))
|
||||
|
||||
(defun archivist-extract-headlines (content)
|
||||
"Extracts first-level headlines and their content from Org text.
|
||||
Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(results nil)
|
||||
(current-title nil)
|
||||
(current-lines nil)
|
||||
(current-tags nil)
|
||||
(in-properties nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (string= trimmed ":PROPERTIES:")
|
||||
(setf in-properties t))
|
||||
(when (string= trimmed ":END:")
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (tag) (string-trim '(#\Space) tag))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
;; First-level headline
|
||||
((and (uiop:string-prefix-p "* " trimmed)
|
||||
(not (uiop:string-prefix-p "**" trimmed)))
|
||||
;; Save previous
|
||||
(when current-title
|
||||
(push (list :title current-title
|
||||
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
||||
:tags current-tags)
|
||||
results))
|
||||
(setf current-title (string-trim '(#\* #\Space) trimmed)
|
||||
current-lines nil
|
||||
current-tags nil
|
||||
in-properties nil))
|
||||
;; Content lines under current headline
|
||||
(current-title
|
||||
(unless (or (uiop:string-prefix-p "*" trimmed)
|
||||
(string= trimmed ":PROPERTIES:")
|
||||
(string= trimmed ":END:"))
|
||||
(push line current-lines))))))
|
||||
;; Save last headline
|
||||
(when current-title
|
||||
(push (list :title current-title
|
||||
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
||||
:tags current-tags)
|
||||
results))
|
||||
(nreverse results)))
|
||||
|
||||
(defun archivist-headline-to-filename (title)
|
||||
"Converts a headline title to a valid atomic note filename.
|
||||
Replaces spaces and special chars with underscores, downcases."
|
||||
(let* ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]" title ""))
|
||||
(underscored (cl-ppcre:regex-replace-all "\\s+" clean "_"))
|
||||
(lowered (string-downcase underscored)))
|
||||
(if (> (length lowered) 100)
|
||||
(subseq lowered 0 100)
|
||||
lowered)))
|
||||
|
||||
(defun archivist-create-note (headline notes-dir source-filepath)
|
||||
"Creates an atomic note from a headline plist in the notes/ directory.
|
||||
Headline is a plist (:title <str> :content <str> :tags <list>).
|
||||
Returns T if note was created, nil if it already exists."
|
||||
(let* ((title (getf headline :title))
|
||||
(content (or (getf headline :content) ""))
|
||||
(tags (getf headline :tags))
|
||||
(filename (archivist-headline-to-filename title))
|
||||
(filepath (merge-pathnames (format nil "~a.org" filename) notes-dir))
|
||||
(source-basename (enough-namestring source-filepath
|
||||
(merge-pathnames "" notes-dir))))
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(progn
|
||||
(uiop:with-output-file (s filepath :if-exists nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil))))
|
||||
|
||||
(defun archivist-gardener-scan ()
|
||||
"Scans the Memex for broken file links and orphaned memory objects.
|
||||
Broken links are =[[file:...]]= references whose target file does not exist.
|
||||
Orphaned objects are =memory-object= entries whose =:parent-id= references
|
||||
a deleted object. Returns a plist (:broken-links <count> :orphans <count>)."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(org-files (archivist-find-org-files memex-dir))
|
||||
(broken-links 0)
|
||||
(orphans 0))
|
||||
;; Scan for broken links
|
||||
(dolist (file org-files)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string file))
|
||||
(links (archivist-extract-file-links content)))
|
||||
(dolist (link links)
|
||||
(let ((target (merge-pathnames link (make-pathname :directory
|
||||
(pathname-directory file)))))
|
||||
(unless (uiop:file-exists-p target)
|
||||
(log-message "ARCHIVIST: Broken link in ~a -> ~a"
|
||||
(enough-namestring file memex-dir) link)
|
||||
(incf broken-links)))))
|
||||
(error ()
|
||||
(log-message "ARCHIVIST: Could not read ~a" file))))
|
||||
;; Scan for orphaned memory objects
|
||||
(handler-case
|
||||
(let ((deleted-ids (make-hash-table :test 'equal)))
|
||||
;; In practice, we check if parent-id points to a non-existent object
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore obj))
|
||||
(setf (gethash id deleted-ids) t))
|
||||
(if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(make-hash-table :test 'equal)))
|
||||
(let ((store (if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(make-hash-table :test 'equal))))
|
||||
(maphash (lambda (id obj)
|
||||
(let ((parent (memory-object-parent-id obj)))
|
||||
(when (and parent (not (gethash parent store)))
|
||||
(log-message "ARCHIVIST: Orphaned object ~a (parent ~a not found)"
|
||||
id parent)
|
||||
(incf orphans))))
|
||||
store)))
|
||||
(error ()
|
||||
(log-message "ARCHIVIST: Memory store not available for orphan scan")))
|
||||
(setf *archivist-last-gardener* (get-universal-time))
|
||||
(list :broken-links broken-links :orphans orphans)))
|
||||
|
||||
(defun archivist-find-org-files (memex-dir)
|
||||
"Recursively finds all .org files under memex-dir, up to 3 levels deep."
|
||||
(let ((files nil))
|
||||
(labels ((walk (dir depth)
|
||||
(when (and (uiop:directory-exists-p dir) (< depth 3))
|
||||
(handler-case
|
||||
(dolist (entry (uiop:subdirectories dir))
|
||||
(walk entry (1+ depth)))
|
||||
(error ()))
|
||||
(handler-case
|
||||
(dolist (file (uiop:directory-files dir "*.org"))
|
||||
(push (namestring file) files))
|
||||
(error ())))))
|
||||
(walk memex-dir 0))
|
||||
files))
|
||||
|
||||
(defun archivist-extract-file-links (content)
|
||||
"Extracts all =[[file:...]]= link targets from Org content.
|
||||
Returns a list of link target strings."
|
||||
(let ((links nil))
|
||||
(cl-ppcre:do-register-groups (target)
|
||||
("\\[\\[file:([^\\]]+)\\]\\[" content)
|
||||
(unless (search "::" target) ;; skip internal anchors
|
||||
(pushnew target links :test #'string=)))
|
||||
;; Also handle bare [[file:target]] links
|
||||
(cl-ppcre:do-register-groups (target)
|
||||
("\\[\\[file:([^\\]]+)\\]\\]" content)
|
||||
(unless (search "::" target)
|
||||
(pushnew target links :test #'string=)))
|
||||
links))
|
||||
|
||||
(defun archivist-run (action context)
|
||||
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
|
||||
and dispatches as needed. Called by the deterministic gate."
|
||||
(declare (ignore action context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
(ignore-errors (archivist-scribe-distill)))
|
||||
;; Gardener runs every 24 hours
|
||||
(when (>= (- now *archivist-last-gardener*) *archivist-gardener-interval*)
|
||||
(ignore-errors
|
||||
(let ((result (archivist-gardener-scan)))
|
||||
(when (> (getf result :broken-links) 0)
|
||||
(log-message "ARCHIVIST: Gardener found ~d broken links, ~d orphans"
|
||||
(getf result :broken-links) (getf result :orphans)))))))
|
||||
nil)
|
||||
|
||||
(defskill :passepartout-symbolic-archivist
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic #'archivist-run)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-symbolic-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-symbolic-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
Reference in New Issue
Block a user