Merge commit '69c5e4ace81586c05dea6a9a3afd54dafa61a73b' as 'claude-templates'

1 files changed, 514 insertions, 0 deletions

diff --git a/claude-templates/.ai/scripts/todo-cleanup.el b/claude-templates/.ai/scripts/todo-cleanup.el
new file mode 100644
index 0000000..569e7c7
--- /dev/null
+++ b/claude-templates/.ai/scripts/todo-cleanup.el
@@ -0,0 +1,514 @@
+;;; todo-cleanup.el --- Auto-fix and audit for todo.org hygiene  -*- lexical-binding: t; -*-
+;;
+;; Usage:
+;;   emacs --batch -q -l todo-cleanup.el todo.org                          # apply hygiene fixes in place
+;;   emacs --batch -q -l todo-cleanup.el --check todo.org                  # hygiene report only
+;;   emacs --batch -q -l todo-cleanup.el --archive-done todo.org           # archive completed subtrees
+;;   emacs --batch -q -l todo-cleanup.el --archive-done --check todo.org   # preview the archive
+;;   emacs --batch -q -l todo-cleanup.el --sync-child-priority todo.org    # bump children whose priority drifted below the parent's
+;;   emacs --batch -q -l todo-cleanup.el --check-child-priority todo.org   # preview the sync (same as --sync-child-priority --check)
+;;
+;; Three independent modes:
+;;
+;; * Default (hygiene). Designed for the wrap-it-up workflow: cheap, idempotent,
+;;   safe to run every session.
+;;
+;;   1. Auto-deletes "bogus state-log" lines of the form
+;;        - State "X"       from "X"       [date]
+;;      where the state didn't actually change. Org sometimes logs these when
+;;      `org-log-into-drawer' is unset and a state-change toggle lands on the
+;;      same state. They carry no information and they break org's planning-line
+;;      parser by sitting between the heading and DEADLINE/SCHEDULED.
+;;
+;;   2. Detects "orphan planning lines" — entries whose body contains
+;;      `^DEADLINE:' or `^SCHEDULED:' that org-entry-get can't read because the
+;;      line isn't in canonical position. Reports these for manual fix; doesn't
+;;      auto-rewrite (preserving real state-log history is judgement work).
+;;
+;; * --archive-done (opt-in). Moves every level-2 subtree whose TODO state is
+;;   DONE or CANCELLED out of the "Open Work" section and into the "Resolved"
+;;   section of the same file, subtree intact. The sections are matched by a
+;;   unique level-1 heading containing "Open Work" (case-insensitive) and one
+;;   containing "Resolved"; if either is missing or ambiguous, the file is
+;;   skipped with a message. Only direct level-2 children move — a DONE entry
+;;   nested under an open parent stays put. Archiving is consequential, so it's
+;;   never run by default; it does *not* also run the hygiene passes.
+;;
+;; * --sync-child-priority (opt-in). Walks every heading with a priority cookie
+;;   ([#A]-[#D]) and, for each of its direct child headings whose own priority
+;;   is lower (later in the alphabet — D is lower than A), bumps the child's
+;;   cookie to match the parent's. Down-only: parents are never adjusted to
+;;   match a child. Children with no priority cookie at all are left alone, as
+;;   are parents with no priority cookie. A child can opt out of being bumped
+;;   by carrying the `:no-sync:' tag — useful for `Follow-up:'/`Spike:' children
+;;   that are deliberately deprioritized. The opt-out inherits down the tree:
+;;   if any ancestor heading carries `:no-sync:', every descendant under it is
+;;   skipped, so tagging a top-level PROJECT once is enough to keep its whole
+;;   subtree from cascading. Because the walk visits parents
+;;   before their descendants in document order, a multi-level chain
+;;   ([#A] → [#B] → [#D]) collapses to the top priority in a single pass.
+;;   --check-child-priority is the report-only alias for --sync-child-priority
+;;   --check.
+
+(require 'org)
+(require 'cl-lib)
+
+(setq org-todo-keywords
+      '((sequence "TODO" "DOING" "WAITING" "NEXT" "|" "DONE" "CANCELLED")))
+
+(defconst tc-done-states '("DONE" "CANCELLED")
+  "TODO keywords that mark an entry as completed for `--archive-done'.")
+
+(defconst tc--priority-cookie-regexp "\\[#\\([A-Z]\\)\\]"
+  "Regexp matching an org priority cookie. Match group 1 is the letter.")
+
+(defconst tc-no-sync-tag "no-sync"
+  "Org tag that opts a heading and all its descendants out of
+`--sync-child-priority'. Inherits down: a tag on an ancestor counts for
+every heading below it.")
+
+(defvar tc-fixes 0)
+(defvar tc-archived 0)
+(defvar tc-bumped 0)
+(defvar tc-issues nil)
+(defvar tc-check-only nil)
+(defvar tc-archive-done nil)
+(defvar tc-sync-child-priority nil)
+(defvar tc-current-file nil)
+
+;;; ---------------------------------------------------------------------------
+;;; Hygiene mode
+
+(defun tc-fix-bogus-state-log-in-entry ()
+  "Delete bogus state-log lines within the entry at point.
+A bogus log line matches `- State \"X\" from \"X\" [date]' where the two
+states are identical."
+  (save-excursion
+    (let ((end (save-excursion
+                 (or (outline-next-heading) (goto-char (point-max)))
+                 (point))))
+      (while (re-search-forward
+              "^[[:space:]]*- State \"\\([^\"]+\\)\"[[:space:]]+from \"\\1\"[[:space:]]+\\[[^]]+\\][[:space:]]*\n"
+              end t)
+        (let ((line (line-number-at-pos (match-beginning 0))))
+          (if tc-check-only
+              (push (list :kind 'bogus-log
+                          :file tc-current-file
+                          :line line
+                          :detail (string-trim (match-string 0)))
+                    tc-issues)
+            (delete-region (match-beginning 0) (match-end 0))
+            (cl-incf tc-fixes)
+            (push (list :kind 'bogus-log-fixed
+                        :file tc-current-file
+                        :line line
+                        :detail (string-trim (match-string 0)))
+                  tc-issues)))))))
+
+(defun tc-detect-orphan-planning-in-entry ()
+  "Flag entries with a body DEADLINE/SCHEDULED that org-entry-get can't read.
+That means the planning line isn't in canonical position, so org-mode's
+agenda + scheduling machinery won't see it."
+  (let* ((line (line-number-at-pos))
+         (heading (org-get-heading t t t t))
+         (dl-canonical (org-entry-get (point) "DEADLINE"))
+         (sc-canonical (org-entry-get (point) "SCHEDULED"))
+         (start (save-excursion (org-end-of-meta-data t) (point)))
+         (end (save-excursion
+                (or (outline-next-heading) (goto-char (point-max)))
+                (point)))
+         (body (buffer-substring-no-properties start end)))
+    (when (and (not dl-canonical)
+               (string-match "^[[:space:]]*DEADLINE:[[:space:]]*\\(<[^>]+>\\)" body))
+      (push (list :kind 'orphan-deadline
+                  :file tc-current-file
+                  :line line
+                  :heading heading
+                  :detail (match-string 1 body))
+            tc-issues))
+    (when (and (not sc-canonical)
+               (string-match "^[[:space:]]*SCHEDULED:[[:space:]]*\\(<[^>]+>\\)" body))
+      (push (list :kind 'orphan-scheduled
+                  :file tc-current-file
+                  :line line
+                  :heading heading
+                  :detail (match-string 1 body))
+            tc-issues))))
+
+;;; ---------------------------------------------------------------------------
+;;; --archive-done mode
+
+(defun tc--find-section (substring)
+  "Buffer position (beginning of line) of the unique level-1 heading whose
+stripped text contains SUBSTRING, case-insensitively.
+Return nil if there is no such heading, or the symbol `multiple' if there is
+more than one."
+  (let ((needle (regexp-quote (downcase substring)))
+        (matches nil))
+    (save-excursion
+      (goto-char (point-min))
+      (while (re-search-forward "^\\* " nil t)
+        (let* ((pos (match-beginning 0))
+               (text (downcase (or (save-excursion (goto-char pos)
+                                                   (org-get-heading t t t t))
+                                   ""))))
+          (when (string-match-p needle text)
+            (push pos matches)))))
+    (cond ((null matches) nil)
+          ((cdr matches) 'multiple)
+          (t (car matches)))))
+
+(defun tc--subtree-end (heading-bol level)
+  "Beginning of the first heading at level <= LEVEL after HEADING-BOL,
+or `point-max' if there is none."
+  (save-excursion
+    (goto-char heading-bol)
+    (forward-line 1)
+    (let (found)
+      (while (and (not found) (re-search-forward "^\\(\\*+\\)[ \t]" nil t))
+        (when (<= (length (match-string 1)) level)
+          (setq found (match-beginning 0))))
+      (or found (point-max)))))
+
+(defun tc--subtree-region ()
+  "Return (BEG . END) for the subtree whose heading the point is on.
+BEG is the beginning of the heading line; END is the beginning of the next
+heading at the same or a shallower level, or `point-max'."
+  (org-back-to-heading t)
+  (let ((beg (line-beginning-position))
+        (level (org-current-level)))
+    (cons beg (tc--subtree-end beg level))))
+
+(defun tc--done-level-2-children (section-bol)
+  "List of heading positions (beginning of line) for the direct level-2
+children of the level-1 section heading at SECTION-BOL whose TODO state is in
+`tc-done-states', in document order."
+  (save-excursion
+    (goto-char section-bol)
+    (forward-line 1)
+    (let ((positions nil)
+          (stop nil))
+      (while (and (not stop) (re-search-forward "^\\(\\*+\\)[ \t]" nil t))
+        (let ((lvl (length (match-string 1)))
+              (hpos (match-beginning 0)))
+          (cond
+           ((<= lvl 1) (setq stop t))   ; reached the next level-1 section
+           ((= lvl 2)
+            (when (member (save-excursion (goto-char hpos) (org-get-todo-state))
+                          tc-done-states)
+              (push hpos positions)))
+           ;; lvl > 2: a deeper descendant — leave it alone
+           )))
+      (nreverse positions))))
+
+(defun tc--archive-skip (detail)
+  (push (list :kind 'archive-skip :file tc-current-file :detail detail) tc-issues))
+
+(defun tc-archive-done-in-file ()
+  "Move level-2 DONE/CANCELLED subtrees from the \"Open Work\" section into the
+\"Resolved\" section of the current buffer.  Under `tc-check-only' the moves
+are reported but not performed."
+  (let ((open (tc--find-section "open work"))
+        (res (tc--find-section "resolved")))
+    (cond
+     ((null open) (tc--archive-skip "no level-1 heading containing \"Open Work\""))
+     ((eq open 'multiple) (tc--archive-skip "more than one level-1 heading contains \"Open Work\""))
+     ((null res) (tc--archive-skip "no level-1 heading containing \"Resolved\""))
+     ((eq res 'multiple) (tc--archive-skip "more than one level-1 heading contains \"Resolved\""))
+     ((= open res) (tc--archive-skip "the same heading matches both \"Open Work\" and \"Resolved\""))
+     (tc-check-only
+      (save-excursion
+        (dolist (pos (tc--done-level-2-children open))
+          (goto-char pos)
+          (push (list :kind 'archive-would :file tc-current-file
+                      :line (line-number-at-pos)
+                      :heading (org-get-heading t t t t))
+                tc-issues)
+          (cl-incf tc-archived))))
+     (t
+      (catch 'done
+        (while t
+          (let* ((open* (tc--find-section "open work"))
+                 (targets (and (integerp open*) (tc--done-level-2-children open*))))
+            (unless targets (throw 'done nil))
+            (goto-char (car targets))
+            (let* ((region (tc--subtree-region))
+                   (beg (car region))
+                   (end (cdr region))
+                   (heading (save-excursion (goto-char beg) (org-get-heading t t t t)))
+                   (line (line-number-at-pos beg))
+                   ;; Normalize the trailing separator to a single newline so
+                   ;; moved subtrees don't drag blank lines into "Resolved".
+                   (text (concat (string-trim-right (buffer-substring-no-properties beg end)
+                                                    "[ \t\n]+")
+                                 "\n")))
+              (delete-region beg end)
+              (let* ((res* (tc--find-section "resolved"))
+                     (ins (tc--subtree-end res* 1)))
+                (goto-char ins)
+                (unless (bolp) (insert "\n"))
+                (insert text)
+                (unless (bolp) (insert "\n")))
+              (cl-incf tc-archived)
+              (push (list :kind 'archive-moved :file tc-current-file
+                          :line line :heading heading)
+                    tc-issues)))))))))
+
+;;; ---------------------------------------------------------------------------
+;;; --sync-child-priority mode
+
+(defun tc--heading-priority-letter ()
+  "Return the priority letter (a character) on the heading at point, or nil
+if the heading has no priority cookie in canonical position.
+
+Uses `org-heading-components' rather than regexing the whole line, because
+the cookie must sit right after the stars or the optional TODO keyword —
+otherwise `[#X]'-shaped text inside the title (a dated log entry like
+\"... reprioritized =[#D]= → =[#B]= to match parent\") gets misread as a
+real cookie."
+  (save-excursion
+    (org-back-to-heading t)
+    (nth 3 (org-heading-components))))
+
+(defun tc--priority-lower-p (child parent)
+  "Non-nil when CHILD priority letter ranks lower than PARENT — i.e. later in
+the alphabet, since A is highest in org's default priority scheme."
+  (and child parent (> child parent)))
+
+(defun tc--heading-has-no-sync-tag-p ()
+  "Non-nil when the heading line at point carries the literal substring
+`:no-sync:'. Uses a literal regex match rather than `org-get-tags' because
+org's default tag character class (`org-tag-re') excludes hyphens —
+`no-sync' isn't recognized as a real org tag in batch mode unless the user
+has extended that regex. The literal `:no-sync:' is what wrap-up sessions
+actually type, so match it directly anywhere on the heading line; the
+heading line is scoped narrowly enough that a false-positive match in title
+text is unlikely, and the cost would only be skipping a bump."
+  (save-excursion
+    (org-back-to-heading t)
+    (let ((line (buffer-substring-no-properties
+                 (line-beginning-position) (line-end-position))))
+      (string-match-p (format ":%s:" (regexp-quote tc-no-sync-tag))
+                      line))))
+
+(defun tc--ancestor-or-self-has-no-sync-tag-p ()
+  "Non-nil when the heading at point, or any strict ancestor, carries the
+literal `:no-sync:' tag on its own heading line. Walks up the outline
+chain via `org-up-heading-safe', which returns nil at the top level
+instead of erroring."
+  (save-excursion
+    (org-back-to-heading t)
+    (catch 'found
+      (when (tc--heading-has-no-sync-tag-p)
+        (throw 'found t))
+      (while (org-up-heading-safe)
+        (when (tc--heading-has-no-sync-tag-p)
+          (throw 'found t)))
+      nil)))
+
+(defun tc--set-heading-priority (letter)
+  "Rewrite the priority cookie on the heading at point to LETTER (a character)."
+  (save-excursion
+    (org-back-to-heading t)
+    (let ((eol (line-end-position)))
+      (when (re-search-forward tc--priority-cookie-regexp eol t)
+        (replace-match (format "[#%c]" letter) t t)))))
+
+(defun tc--direct-children-of-current-heading ()
+  "Return heading positions (beginning of line) of the direct children of the
+heading at point, in document order. Direct children = headings exactly one
+level deeper than the parent."
+  (save-excursion
+    (org-back-to-heading t)
+    (let* ((parent-level (org-current-level))
+           (child-level (1+ parent-level))
+           (subtree-end (save-excursion (org-end-of-subtree t t) (point)))
+           (positions nil))
+      (forward-line 1)
+      (while (re-search-forward "^\\(\\*+\\)[ \t]" subtree-end t)
+        (let ((lvl (length (match-string 1)))
+              (pos (match-beginning 0)))
+          (when (= lvl child-level)
+            (push pos positions))))
+      (nreverse positions))))
+
+(defun tc-sync-child-priority-at-heading ()
+  "If the heading at point carries a priority cookie, bump any direct child
+heading whose own priority is lower, skipping children whose own heading
+or any ancestor carries `tc-no-sync-tag'. A priority-less parent is a
+no-op; priority-less children are left untouched (down-only does not
+invent priorities)."
+  (let ((parent (tc--heading-priority-letter)))
+    (when parent
+      (let ((parent-heading (org-get-heading t t t t)))
+        (dolist (child-pos (tc--direct-children-of-current-heading))
+          (save-excursion
+            (goto-char child-pos)
+            (let ((child (tc--heading-priority-letter)))
+              (when (and child
+                         (tc--priority-lower-p child parent)
+                         (not (tc--ancestor-or-self-has-no-sync-tag-p)))
+                (let ((child-heading (org-get-heading t t t t))
+                      (child-line (line-number-at-pos)))
+                  (cl-incf tc-bumped)
+                  (if tc-check-only
+                      (push (list :kind 'sync-would
+                                  :file tc-current-file
+                                  :line child-line
+                                  :child-heading child-heading
+                                  :parent-heading parent-heading
+                                  :from (char-to-string child)
+                                  :to (char-to-string parent))
+                            tc-issues)
+                    (tc--set-heading-priority parent)
+                    (push (list :kind 'sync-bumped
+                                :file tc-current-file
+                                :line child-line
+                                :child-heading child-heading
+                                :parent-heading parent-heading
+                                :from (char-to-string child)
+                                :to (char-to-string parent))
+                          tc-issues)))))))))))
+
+(defun tc-sync-child-priority-in-file ()
+  "Walk every heading in the buffer and run `tc-sync-child-priority-at-heading'.
+`org-map-entries' visits headings in document order, so parents are bumped
+before their descendants — a [#A] → [#B] → [#D] chain collapses in one pass."
+  (org-map-entries #'tc-sync-child-priority-at-heading nil 'file))
+
+;;; ---------------------------------------------------------------------------
+;;; Driver + reporting
+
+(defun tc-process-file (file)
+  (setq tc-current-file (file-name-nondirectory file))
+  (with-current-buffer (find-file-noselect file)
+    (org-mode)
+    (cond
+     (tc-archive-done
+      (tc-archive-done-in-file))
+     (tc-sync-child-priority
+      (tc-sync-child-priority-in-file))
+     (t
+      ;; Pass 1: auto-fix bogus state logs (or report under --check).
+      (org-map-entries #'tc-fix-bogus-state-log-in-entry nil 'file)
+      ;; Pass 2: detect orphan planning lines (always report-only).
+      (org-map-entries #'tc-detect-orphan-planning-in-entry nil 'file)))
+    (when (and (not tc-check-only) (buffer-modified-p))
+      (save-buffer))))
+
+(defun tc--emit-archive-report ()
+  (princ (format "todo-cleanup --archive-done: %d subtree(s) %s%s\n"
+                 tc-archived
+                 (if tc-check-only "would move" "moved")
+                 (if tc-check-only " — CHECK MODE (no writes)" "")))
+  (dolist (i (reverse tc-issues))
+    (pcase (plist-get i :kind)
+      ('archive-skip
+       (princ (format "  skipped %s: %s\n" (plist-get i :file) (plist-get i :detail))))
+      ((or 'archive-moved 'archive-would)
+       (princ (format "    %s:%d: %s %s\n"
+                      (plist-get i :file)
+                      (plist-get i :line)
+                      (if tc-check-only "would move" "moved")
+                      (plist-get i :heading)))))))
+
+(defun tc--emit-hygiene-report ()
+  (princ (format "todo-cleanup: %d fix(es) applied%s\n"
+                 tc-fixes
+                 (if tc-check-only " — CHECK MODE (no writes)" "")))
+  (let ((orphans (cl-remove-if-not (lambda (i) (memq (plist-get i :kind)
+                                                     '(orphan-deadline
+                                                       orphan-scheduled)))
+                                   tc-issues))
+        (logs (cl-remove-if-not (lambda (i) (memq (plist-get i :kind)
+                                                  '(bogus-log
+                                                    bogus-log-fixed)))
+                                tc-issues)))
+    (when logs
+      (princ (format "  Bogus state-log lines (%s):\n"
+                     (if tc-check-only "would delete" "deleted")))
+      (dolist (i (nreverse logs))
+        (princ (format "    %s:%d: %s\n"
+                       (plist-get i :file)
+                       (plist-get i :line)
+                       (plist-get i :detail)))))
+    (when orphans
+      (princ (format "  Orphan planning lines needing manual fix (%d):\n" (length orphans)))
+      (dolist (i (nreverse orphans))
+        (princ (format "    %s:%d: %s — %s in body\n"
+                       (plist-get i :file)
+                       (plist-get i :line)
+                       (plist-get i :heading)
+                       (plist-get i :detail)))))))
+
+(defun tc--emit-sync-report ()
+  (princ (format "todo-cleanup --sync-child-priority: %d child priority cookie(s) %s%s\n"
+                 tc-bumped
+                 (if tc-check-only "would bump" "bumped")
+                 (if tc-check-only " — CHECK MODE (no writes)" "")))
+  (dolist (i (reverse tc-issues))
+    (pcase (plist-get i :kind)
+      ((or 'sync-bumped 'sync-would)
+       (princ (format "    %s:%d: [#%s] → [#%s]  %s  (under: %s)\n"
+                      (plist-get i :file)
+                      (plist-get i :line)
+                      (plist-get i :from)
+                      (plist-get i :to)
+                      (plist-get i :child-heading)
+                      (plist-get i :parent-heading)))))))
+
+(defun tc-emit-report ()
+  (cond (tc-archive-done (tc--emit-archive-report))
+        (tc-sync-child-priority (tc--emit-sync-report))
+        (t (tc--emit-hygiene-report))))
+
+(defun tc-main ()
+  ;; Strip our flags from `command-line-args-left' so emacs's own arg parser
+  ;; doesn't see them after this returns.
+  (when (member "--check" command-line-args-left)
+    (setq tc-check-only t)
+    (setq command-line-args-left (delete "--check" command-line-args-left)))
+  (when (member "--archive-done" command-line-args-left)
+    (setq tc-archive-done t)
+    (setq command-line-args-left (delete "--archive-done" command-line-args-left)))
+  (when (member "--sync-child-priority" command-line-args-left)
+    (setq tc-sync-child-priority t)
+    (setq command-line-args-left (delete "--sync-child-priority" command-line-args-left)))
+  ;; --check-child-priority is the report-only alias for
+  ;; `--sync-child-priority --check'.
+  (when (member "--check-child-priority" command-line-args-left)
+    (setq tc-sync-child-priority t tc-check-only t)
+    (setq command-line-args-left (delete "--check-child-priority" command-line-args-left)))
+  (if (null command-line-args-left)
+      (progn
+        (princ "Usage: emacs --batch -q -l todo-cleanup.el [--check] [--archive-done | --sync-child-priority | --check-child-priority] FILE...\n")
+        (kill-emacs 1))
+    (let ((files command-line-args-left))
+      (setq command-line-args-left nil)
+      (dolist (file files)
+        (when (file-readable-p file)
+          (tc-process-file file)))
+      (tc-emit-report))))
+
+(defun tc--cli-invocation-p ()
+  "Non-nil when the trailing command-line arguments look like a real
+todo-cleanup invocation: only recognized flags and/or readable file paths.
+Lets the ERT suite `require' this file without triggering the CLI dispatch —
+during a test run the trailing args are things like `-f
+ert-run-tests-batch-and-exit'."
+  (and command-line-args-left
+       (cl-every (lambda (a)
+                   (cond ((member a '("--check"
+                                      "--archive-done"
+                                      "--sync-child-priority"
+                                      "--check-child-priority"))
+                          t)
+                         ((string-prefix-p "-" a) nil)
+                         (t (file-readable-p a))))
+                 command-line-args-left)))
+
+(when (and noninteractive (tc--cli-invocation-p))
+  (tc-main))
+
+(provide 'todo-cleanup)
+;;; todo-cleanup.el ends here