passepartout/org/programming-org.org

SKILL: Utils Org (org-skill-utils-org.org)

• Overview
  • Contract
• Test Suite
• Implementation
  • Package Context
  • Reading Files (with Privacy Filter)
  • org-privacy-tag-p
  • org-privacy-strip
  • org-read-file
  • Writing Files
  • ID Generation
  • ID Formatting
  • Setting Properties (Recursive)
  • Setting TODO Status
  • Adding Headlines
  • Searching Headlines (by ID)
  • Searching Headlines (by Title)
  • org-id-get-create — Ensure a Headline Has an ID
  • Subtree Extraction (from Org text)
  • org-heading-list
  • Text Modification in Org Files
  • AST to Org text conversion
  • Skill Registration

Overview

Structural manipulation tools for Org-mode files. This skill handles reading, writing, and modifying Org files at the AST level: finding headlines by ID or title, setting properties and TODO states, adding new headlines, generating UUIDs, and converting ASTs back to Org text. It also implements the privacy filter — when reading an Org file, it strips headlines tagged with @personal (or any tag in the Dispatcher's privacy tags) and rejects files with matching #+FILETAGS:.

Contract

1. (org-id-generate): returns a new UUID string.
2. (org-id-format id): ensures the ID has an "id:" prefix.
3. (org-property-set ast target-id property value): recursively sets a property on a headline matching target-id. Returns T on success.
4. (org-todo-set ast target-id status): sets TODO status via org-property-set.
5. (org-headline-add ast parent-id title): adds a new child headline.
6. (org-headline-find-by-id ast id): returns the subtree for a matching headline ID.
7. (org-id-get-create ast target-id): ensures a headline has an :ID: property. If the headline already has one, returns it. If not, generates a new UUID, sets it, and returns it. Returns nil if the headline is not found.

Test Suite

Verification of the structural manipulation for Org-mode files and their AST representation.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ignore-errors (ql:quickload :fiveam :silent t)))

(defpackage :passepartout-utils-org-tests
  (:use :cl :fiveam :passepartout)
  (:export #:utils-org-suite))

(in-package :passepartout-utils-org-tests)

(def-suite utils-org-suite
  :description "Tests for Utils Org skill.")

(in-suite utils-org-suite)

(test id-generation
  "Contract 1: org-id-generate returns unique UUID strings."
  (let ((id1 (org-id-generate))
        (id2 (org-id-generate)))
    (is (plusp (length id1)))
    (is (not (string= id1 id2)))))

(test id-format
  "Contract 2: org-id-format ensures 'id:' prefix."
  (let ((formatted (org-id-format "abc12345")))
    (is (search "id:" formatted))))

(test property-setter
  "Contract 3: org-property-set modifies a property on a headline."
  (let ((ast (list :type :HEADLINE
                  :properties (list :ID "id:test123" :TITLE "Test")
                  :contents nil)))
    (org-property-set ast "id:test123" :STATUS "ACTIVE")
    (is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))

(test todo-setter
  "Contract 4: org-todo-set changes TODO state via org-property-set."
  (let ((ast (list :type :HEADLINE
                  :properties (list :ID "id:todo001" :TITLE "Task")
                  :contents nil)))
    (org-todo-set ast "id:todo001" "DONE")
    (is (string= (getf (getf ast :properties) :TODO) "DONE"))))

(test test-org-headline-add
  "Contract 5: org-headline-add inserts a child headline."
  (let* ((ast (list :type :HEADLINE
                   :properties (list :ID "root" :TITLE "Root")
                   :contents nil)))
    (is (eq t (org-headline-add ast "root" "New Child")))
    (is (= 1 (length (getf ast :contents))))
    (is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))

(test test-org-headline-find-by-id
  "Contract 6: org-headline-find-by-id finds a headline by ID."
  (let* ((ast (list :type :HEADLINE
                    :properties (list :ID "root" :TITLE "Root")
                    :contents
                    (list (list :type :HEADLINE
                                :properties (list :ID "child1" :TITLE "Child"))
                          (list :type :HEADLINE
                                :properties (list :ID "child2" :TITLE "Child 2"))))))
    (let ((found (org-headline-find-by-id ast "child2")))
      (is (not (null found)))
      (is (string= "Child 2" (getf (getf found :properties) :TITLE))))
    (let ((missing (org-headline-find-by-id ast "nonexistent")))
      (is (null missing) "Missing ID should return nil"))))

(test test-org-id-get-create
  "Contract 7: org-id-get-create returns existing ID or creates and sets a new one."
  ;; Case 1: headline already has an ID
  (let* ((ast (list :type :HEADLINE
                    :properties (list :ID "id:existing" :TITLE "Has ID")
                    :contents nil)))
    (is (string= "id:existing" (org-id-get-create ast "id:existing"))))
  ;; Case 2: headline exists by title but has no ID — one should be created
  (let* ((ast (list :type :HEADLINE
                    :properties (list :TITLE "No ID")
                    :contents nil)))
    (let ((new-id (org-id-get-create ast "No ID")))
      (is (stringp new-id))
      (is (uiop:string-prefix-p "id:" new-id))
      ;; Verify the ID was set on the headline
      (is (string= new-id (getf (getf ast :properties) :ID)))))
  ;; Case 3: idempotent — calling again returns same ID
  (let* ((ast (list :type :HEADLINE
                    :properties (list :TITLE "Idempotent")
                    :contents nil)))
    (let ((id1 (org-id-get-create ast "Idempotent"))
          (id2 (org-id-get-create ast "Idempotent")))
      (is (string= id1 id2))))
  ;; Case 4: headline not found returns nil
  (let* ((ast (list :type :HEADLINE
                    :properties (list :ID "root" :TITLE "Root")
                    :contents nil)))
    (is (null (org-id-get-create ast "nonexistent")))))

Implementation

Package Context

(in-package :passepartout)

Reading Files (with Privacy Filter)

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-filetags-extract (content)
  "Extracts the list of tags from a #+FILETAGS: line."
  (let ((lines (uiop:split-string content :separator '(#\Newline))))
    (dolist (line lines)
      (when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line))
        (let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10))))
          (return-from org-filetags-extract
            (mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag)))
                    (uiop:split-string tag-str :separator '(#\space #\tab))))))))
  nil)

org-privacy-tag-p

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-privacy-tag-p (tags-list)
  "Returns T if any tag in TAGS-LIST matches the Dispatcher's privacy tags."
  (let ((privacy-tags (symbol-value (find-symbol "*DISPATCHER-PRIVACY-TAGS*" :passepartout))))
    (when (and tags-list privacy-tags)
      (some (lambda (tag)
              (some (lambda (private-tag)
                      (string-equal (string-trim '(#\: #\space) tag)
                                    (string-trim '(#\: #\space) private-tag)))
                    privacy-tags))
            tags-list))))

org-privacy-strip

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-privacy-strip (content)
  "Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
Returns the filtered content as a string."
  (let* ((lines (uiop:split-string content :separator '(#\Newline)))
         (result-lines nil)
         (skip-depth nil)
         (current-tags nil)
         (in-properties nil))
    (dolist (line lines)
      (cond
        (skip-depth
         ;; We're inside a skipped subtree
         (when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line))
                    (<= (length (string-trim '(#\Space) line)) skip-depth))
           (setf skip-depth nil)))
        ((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line))
         (setf in-properties t)
         (push line result-lines))
        ((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line))
         (setf in-properties nil)
         (when current-tags
           (when (org-privacy-tag-p (reverse current-tags))
             (setf skip-depth
                   (length (car (last result-lines
                                      (1+ (position-if
                                           (lambda (l)
                                             (uiop:string-prefix-p "*" (string-trim '(#\Space) l)))
                                           (reverse result-lines))))))))
           (setf current-tags nil))
         (push line result-lines))
        ((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line)))
         (let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6))))
           (setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab))))
         (push line result-lines))
        (t
         (push line result-lines))))
    (format nil "~{~a~%~}" (nreverse result-lines))))

org-read-file

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-read-file (filepath)
  "Reads an Org file into a string, applying privacy filtering."
  (let* ((raw (uiop:read-file-string filepath))
         (filetags (org-filetags-extract raw)))
    (if (org-privacy-tag-p filetags)
        (progn
          (log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags)
          nil)
        (org-privacy-strip raw))))

#+end_src

Writing Files

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-write-file (filepath content)
  "Writes content to an Org file."
  (uiop:with-output-file (s filepath :if-exists :supersede)
    (format s "~a" content)))

ID Generation

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-id-generate ()
  "Generates a new UUID for an Org node."
  (string-downcase (format nil "~a" (uuid:make-v4-uuid))))

ID Formatting

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-id-format (id)
  "Ensures the ID has the 'id:' prefix."
  (if (uiop:string-prefix-p "id:" id)
      id
      (format nil "id:~a" id)))

Setting Properties (Recursive)

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-property-set (ast target-id property value)
  "Recursively sets a property on a headline with a matching ID in the AST."
  (let ((type (getf ast :type))
        (props (getf ast :properties))
        (contents (getf ast :contents)))
    (when (and (eq type :HEADLINE) (string= (getf props :ID) target-id))
      (setf (getf (getf ast :properties) property) value)
      (return-from org-property-set t))
    (dolist (child contents)
      (when (listp child)
        (when (org-property-set child target-id property value)
          (return-from org-property-set t)))))
  nil)

Setting TODO Status

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-todo-set (ast target-id status)
  "Sets the TODO status of a headline in the AST."
  (org-property-set ast target-id :TODO status))

Adding Headlines

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-headline-add (ast parent-id title)
  "Adds a new headline as a child of the parent-id in the AST."
  (let* ((type (getf ast :type))
         (props (getf ast :properties))
         (id (getf props :ID))
         (contents (getf ast :contents)))
    (when (and (eq type :HEADLINE) (string= id parent-id))
      (let ((new-node (list :type :HEADLINE
                           :properties (list :ID (org-id-format (org-id-generate))
                                            :TITLE title)
                           :contents nil)))
        (setf (getf ast :contents) (append contents (list new-node)))
        (return-from org-headline-add t)))
    (dolist (child contents)
      (when (listp child)
        (when (org-headline-add child parent-id title)
          (return-from org-headline-add t)))))
  nil)

Searching Headlines (by ID)

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-headline-find-by-id (ast id)
  "Finds a headline by its ID in the AST."
  (let ((props (getf ast :properties)))
    (when (string= (getf props :ID) id)
      (return-from org-headline-find-by-id ast))
    (dolist (child (getf ast :contents))
      (when (listp child)
        (let ((found (org-headline-find-by-id child id)))
          (when found (return-from org-headline-find-by-id found)))))
    nil))

Searching Headlines (by Title)

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-headline-find-by-title (ast title)
  "Finds a headline by its title in the AST."
  (let ((props (getf ast :properties)))
     (when (string-equal (getf props :TITLE) title)
      (return-from org-headline-find-by-title ast))
    (dolist (child (getf ast :contents))
      (when (listp child)
        (let ((found (org-headline-find-by-title child title)))
          (when found (return-from org-headline-find-by-title found)))))
     nil))

org-id-get-create — Ensure a Headline Has an ID

;; REPL-VERIFIED: 2026-05-07T19:00:00

(defun org-id-get-create (ast target-id)
  "If the headline at TARGET-ID has an :ID property, return it.
If not, generate a new UUID, set it as the :ID property, and return it.
TARGET-ID can be a headline's :ID or :TITLE in the AST.
Returns nil if the headline is not found."
  (let ((headline (or (org-headline-find-by-id ast target-id)
                      (org-headline-find-by-title ast target-id))))
    (when headline
      (let* ((props (getf headline :properties))
             (id (getf props :ID)))
        (if id
            id
            (let ((new-id (org-id-format (org-id-generate))))
              (setf (getf props :ID) new-id)
              new-id))))))

Subtree Extraction (from Org text)

Extracts a specific headline subtree from raw Org text by heading name. Used by context-skill-subtree for targeted skill source loading.

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-subtree-extract (org-content heading-name)
  "Extracts a subtree by heading name from Org text. Returns the subtree
content as a string (headline + body + children), or nil if not found."
  (let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
         (target-depth nil)
         (in-target nil)
         (result nil))
    (loop for line in lines
          for trimmed = (string-trim '(#\Space) line)
          do (let ((depth (when (uiop:string-prefix-p "*" trimmed)
                            (length (subseq trimmed 0
                                            (position-if (lambda (c) (not (char= c #\*)))
                                                         trimmed)))))
                   (headline-title (when (uiop:string-prefix-p "*" trimmed)
                                     (string-trim '(#\* #\Space) trimmed))))
               (when depth
                 (when (string-equal headline-title heading-name)
                   (setf target-depth depth in-target t))
                 (when (and in-target target-depth
                            (<= depth target-depth)
                            (not (string-equal headline-title heading-name)))
                   (return-from org-subtree-extract
                     (format nil "~{~a~^~%~}" (nreverse result)))))
               (when in-target (push line result))))
    (when result
      (format nil "~{~a~^~%~}" (nreverse result)))))

org-heading-list

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-heading-list (org-content)
  "Returns a list of all top-level heading names in Org text."
  (let* ((lines (uiop:split-string org-content :separator '(#\Newline)))
         (headings nil))
    (dolist (line lines)
      (let ((trimmed (string-trim '(#\Space) line)))
        (when (uiop:string-prefix-p "* " trimmed)
          (let ((title (string-trim '(#\* #\Space) trimmed)))
            (unless (find title headings :test #'string-equal)
              (push title headings))))))
    (nreverse headings)))

#+end_src

Text Modification in Org Files

Replaces text in Org files with verification. Used by system-self-improve for surgical edits.

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-modify (filepath old-text new-text)
  "Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath.
Returns T if OLD-TEXT was found and replaced, nil if not found."
  (when (not (uiop:file-exists-p filepath))
    (log-message "UTILS-ORG: org-modify: file not found: ~a" filepath)
    (return-from org-modify nil))
  (let* ((content (uiop:read-file-string filepath))
         (pos (search old-text content :test #'string=)))
    (unless pos
      (log-message "UTILS-ORG: org-modify: text not found in ~a" filepath)
      (return-from org-modify nil))
    (let ((modified (cl-ppcre:regex-replace-all
                      (cl-ppcre:quote-meta-chars old-text)
                      content new-text)))
      (org-write-file filepath modified)
      (log-message "UTILS-ORG: Modified ~a (~d chars replaced)" filepath (length old-text))
      t)))

AST to Org text conversion

;; REPL-VERIFIED: 2026-05-03T13:00:00

(defun org-ast-render (ast &key (depth 1))
  "Converts a plist AST node back to Org text.
AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
              :contents (child-ast ...))"
  (let* ((type (getf ast :TYPE))
         (props (getf ast :properties))
         (title (or (getf props :TITLE) "Untitled"))
         (tags (getf props :TAGS))
         (todo (getf props :TODO-STATE))
         (children (getf ast :contents))
         (raw-content (getf ast :raw-content))
         (stars (make-string depth :initial-element #\*))
         (output ""))
    (unless (eq type :HEADLINE)
      (return-from org-ast-render (or raw-content "")))
    ;; Headline
    (setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
    (when tags
      (let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (tag) (string-trim '(#\:) tag)) tags))))
        (setf output (concatenate 'string output (format nil " :~a::~%" tag-str))))
      (setf output (concatenate 'string output (string #\Newline))))
    (unless tags
      (setf output (concatenate 'string output (string #\Newline))))
    ;; Property drawer
    (setf output (concatenate 'string output ":PROPERTIES:" (string #\Newline)))
    (loop for (k v) on props by #'cddr
          do (unless (or (eq k :TITLE) (eq k :TAGS))
               (setf output (concatenate 'string output
                                         (format nil ":~a: ~a~%" k v)))))
    (setf output (concatenate 'string output ":END:" (string #\Newline)))
    ;; Content
    (when raw-content
      (setf output (concatenate 'string output raw-content (string #\Newline))))
    ;; Children
    (dolist (child children)
      (when (listp child)
        (setf output (concatenate 'string output
                                  (org-ast-render child :depth (1+ depth))))))
    output))

Skill Registration

(defskill :passepartout-programming-org
  :priority 100
  :trigger (lambda (ctx) (declare (ignore ctx)) nil))