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

1 files changed, 518 insertions, 0 deletions

diff --git a/claude-templates/.ai/scripts/tests/test-todo-cleanup.el b/claude-templates/.ai/scripts/tests/test-todo-cleanup.el
new file mode 100644
index 0000000..5d43f97
--- /dev/null
+++ b/claude-templates/.ai/scripts/tests/test-todo-cleanup.el
@@ -0,0 +1,518 @@
+;;; test-todo-cleanup.el --- ERT tests for todo-cleanup.el  -*- lexical-binding: t; -*-
+;;
+;; Run from the repo root:
+;;   emacs --batch -q -L .ai/scripts -l ert \
+;;         -l .ai/scripts/tests/test-todo-cleanup.el \
+;;         -f ert-run-tests-batch-and-exit
+;;
+;; or from .ai/scripts/tests/:
+;;   emacs --batch -q -L .. -l ert -l test-todo-cleanup.el \
+;;         -f ert-run-tests-batch-and-exit
+;;
+;; Covers the `--archive-done' mode: moving level-2 DONE/CANCELLED subtrees
+;; out of the "Open Work" section into the "Resolved" section.
+
+(require 'ert)
+(require 'cl-lib)
+
+(defconst tc-test--dir
+  (file-name-directory (or load-file-name buffer-file-name default-directory))
+  "Directory of this test file, captured at load time.")
+
+;; Make `todo-cleanup' loadable from the parent directory.  Loading it is
+;; inert: its CLI dispatch only fires when the trailing command-line args look
+;; like a real invocation (recognized flags / readable file paths), which they
+;; don't during `ert-run-tests-batch-and-exit'.
+(add-to-list 'load-path (expand-file-name ".." tc-test--dir))
+(require 'todo-cleanup)
+
+;;; ---------------------------------------------------------------------------
+;;; Harness
+
+(defun tc-test--reset (&optional check)
+  (setq tc-fixes 0 tc-archived 0 tc-bumped 0 tc-issues nil
+        tc-check-only (and check t)
+        tc-archive-done t tc-sync-child-priority nil
+        tc-current-file nil))
+
+(defun tc-test--reset-sync (&optional check)
+  (setq tc-fixes 0 tc-archived 0 tc-bumped 0 tc-issues nil
+        tc-check-only (and check t)
+        tc-archive-done nil tc-sync-child-priority t
+        tc-current-file nil))
+
+(defun tc-test--drop-buffer (file)
+  (let ((buf (find-buffer-visiting file)))
+    (when buf
+      (with-current-buffer buf (set-buffer-modified-p nil))
+      (kill-buffer buf))))
+
+(defun tc-test--archive (content &optional runs check)
+  "Write CONTENT to a temp .org file, run `--archive-done' RUNS times (default 1).
+Return a plist: :result final file contents, :archived count from the last run,
+:issues from the last run.  CHECK non-nil ⇒ --check (preview, no writes)."
+  (let ((file (make-temp-file "tc-test-" nil ".org"))
+        last-archived last-issues)
+    (unwind-protect
+        (progn
+          (with-temp-file file (insert content))
+          (dotimes (_ (or runs 1))
+            (tc-test--reset check)
+            (tc-process-file file)
+            (setq last-archived tc-archived last-issues tc-issues)
+            (tc-test--drop-buffer file))
+          (list :result (with-temp-buffer (insert-file-contents file)
+                                          (buffer-string))
+                :archived last-archived
+                :issues last-issues))
+      (tc-test--drop-buffer file)
+      (delete-file file))))
+
+(defun tc-test--section (content needle)
+  "Text of the level-1 section in CONTENT whose heading line contains NEEDLE —
+from the heading line through (not including) the next level-1 heading or EOF."
+  (with-temp-buffer
+    (insert content)
+    (goto-char (point-min))
+    (let (start)
+      (while (and (not start) (re-search-forward "^\\* .*$" nil t))
+        (when (string-match-p (regexp-quote needle) (match-string 0))
+          (setq start (match-beginning 0))))
+      (unless start (error "no level-1 heading containing %S" needle))
+      (goto-char start)
+      (forward-line 1)
+      (buffer-substring-no-properties
+       start
+       (if (re-search-forward "^\\* " nil t) (match-beginning 0) (point-max))))))
+
+(defun tc-test--has (string substring)
+  (and (string-match-p (regexp-quote substring) string) t))
+
+(defun tc-test--before-p (string a b)
+  "Non-nil when SUBSTRING A occurs before SUBSTRING B in STRING."
+  (let ((ia (string-match (regexp-quote a) string))
+        (ib (string-match (regexp-quote b) string)))
+    (and ia ib (< ia ib))))
+
+(defun tc-test--skip-detail (issues)
+  (let ((skip (cl-find-if (lambda (i) (eq (plist-get i :kind) 'archive-skip)) issues)))
+    (and skip (plist-get skip :detail))))
+
+(defun tc-test--moved-headings (issues)
+  (mapcar (lambda (i) (plist-get i :heading))
+          (cl-remove-if-not
+           (lambda (i) (memq (plist-get i :kind) '(archive-moved archive-would)))
+           (reverse issues))))
+
+;;; ---------------------------------------------------------------------------
+;;; Fixtures (synthetic — real project todo.org files are examples only)
+
+(defconst tc-test--basic "\
+* Demo Open Work
+** TODO [#A] First open task
+   first body
+** DONE [#A] A finished task
+   finished body
+** TODO [#B] Another open task
+* Demo Resolved
+** DONE [#A] Previously archived
+")
+
+(defconst tc-test--mixed "\
+* Proj Open Work
+** TODO Keep me open
+** DONE Done one
+*** TODO leftover child of done one
+** A structural heading with no state
+** CANCELLED Cancelled two :quick:
+** TODO Has a done child
+*** DONE this nested done stays
+** DONE Done three
+* Proj Resolved
+** DONE Old archived item
+")
+
+(defconst tc-test--nothing "\
+* X Open Work
+** TODO a
+** WAITING b
+** NEXT c
+* X Resolved
+** DONE old
+")
+
+(defconst tc-test--no-resolved "\
+* Y Open Work
+** DONE finished
+** TODO ongoing
+")
+
+(defconst tc-test--no-open "\
+* Z Resolved
+** DONE old
+* Some Other Section
+** TODO whatever
+")
+
+(defconst tc-test--two-resolved "\
+* P Open Work
+** DONE done
+* P Resolved
+** DONE old1
+* Q Resolved Notes
+** DONE old2
+")
+
+;; No trailing newline — exercises the EOF / final-line case.  Open Work is the
+;; last section, so a DONE level-2 here is also the last subtree in the file.
+(defconst tc-test--eof "\
+* W Resolved
+** DONE pre-existing
+* W Open Work
+** TODO keep open
+** DONE last thing
+   body of last thing")
+
+(defconst tc-test--lowercase "\
+* winvm open work
+** TODO test rebuilt vm
+** DONE fix display resolution
+* winvm resolved
+** DONE fork linoffice as winvm
+")
+
+;;; ---------------------------------------------------------------------------
+;;; Tests
+
+(ert-deftest tc-archive-moves-one-done-level-2 ()
+  (let* ((out (tc-test--archive tc-test--basic))
+         (res (plist-get out :result))
+         (open (tc-test--section res "Demo Open Work"))
+         (resolved (tc-test--section res "Demo Resolved")))
+    (should (= 1 (plist-get out :archived)))
+    (should (tc-test--has resolved "A finished task"))
+    (should (tc-test--has resolved "finished body"))
+    (should-not (tc-test--has open "A finished task"))
+    (should (tc-test--has open "First open task"))
+    (should (tc-test--has open "Another open task"))
+    ;; appended at the end of the Resolved section
+    (should (tc-test--before-p resolved "Previously archived" "A finished task"))))
+
+(ert-deftest tc-archive-moves-multiple-done-and-cancelled ()
+  (let* ((out (tc-test--archive tc-test--mixed))
+         (res (plist-get out :result))
+         (open (tc-test--section res "Proj Open Work"))
+         (resolved (tc-test--section res "Proj Resolved")))
+    (should (= 3 (plist-get out :archived)))
+    ;; stays in Open Work
+    (should (tc-test--has open "Keep me open"))
+    (should (tc-test--has open "A structural heading with no state"))
+    (should (tc-test--has open "Has a done child"))
+    (should (tc-test--has open "this nested done stays"))
+    ;; moved to Resolved
+    (should (tc-test--has resolved "Done one"))
+    (should (tc-test--has resolved "Cancelled two"))
+    (should (tc-test--has resolved "Done three"))
+    ;; a level-2 DONE moves its (open) children along with it
+    (should (tc-test--has resolved "leftover child of done one"))
+    (should-not (tc-test--has open "leftover child of done one"))
+    ;; gone from Open Work
+    (should-not (tc-test--has open "Done one"))
+    (should-not (tc-test--has open "Cancelled two"))
+    (should-not (tc-test--has open "Done three"))
+    ;; order: pre-existing first, then in document order
+    (should (tc-test--before-p resolved "Old archived item" "Done one"))
+    (should (tc-test--before-p resolved "Done one" "Cancelled two"))
+    (should (tc-test--before-p resolved "Cancelled two" "Done three"))))
+
+(ert-deftest tc-archive-structural-heading-does-not-move ()
+  (let* ((out (tc-test--archive tc-test--mixed))
+         (open (tc-test--section (plist-get out :result) "Proj Open Work")))
+    (should (tc-test--has open "A structural heading with no state"))))
+
+(ert-deftest tc-archive-nothing-to-do-is-noop ()
+  (let ((out (tc-test--archive tc-test--nothing)))
+    (should (= 0 (plist-get out :archived)))
+    (should (equal tc-test--nothing (plist-get out :result)))))
+
+(ert-deftest tc-archive-missing-resolved-section-skips ()
+  (let ((out (tc-test--archive tc-test--no-resolved)))
+    (should (= 0 (plist-get out :archived)))
+    (should (equal tc-test--no-resolved (plist-get out :result)))
+    (should (string-match-p "Resolved" (or (tc-test--skip-detail (plist-get out :issues)) "")))))
+
+(ert-deftest tc-archive-missing-open-work-section-skips ()
+  (let ((out (tc-test--archive tc-test--no-open)))
+    (should (= 0 (plist-get out :archived)))
+    (should (equal tc-test--no-open (plist-get out :result)))
+    (should (string-match-p "Open Work" (or (tc-test--skip-detail (plist-get out :issues)) "")))))
+
+(ert-deftest tc-archive-ambiguous-resolved-section-skips ()
+  (let ((out (tc-test--archive tc-test--two-resolved)))
+    (should (= 0 (plist-get out :archived)))
+    (should (equal tc-test--two-resolved (plist-get out :result)))
+    (should (string-match-p "Resolved" (or (tc-test--skip-detail (plist-get out :issues)) "")))))
+
+(ert-deftest tc-archive-subtree-at-eof ()
+  (let* ((out (tc-test--archive tc-test--eof))
+         (res (plist-get out :result))
+         (open (tc-test--section res "W Open Work"))
+         (resolved (tc-test--section res "W Resolved")))
+    (should (= 1 (plist-get out :archived)))
+    (should (tc-test--has resolved "last thing"))
+    (should (tc-test--has resolved "body of last thing"))
+    (should (tc-test--has open "keep open"))
+    (should-not (tc-test--has open "last thing"))
+    ;; result stays well-formed: a newline separates the moved body from the
+    ;; following section heading
+    (should (string-match-p "body of last thing\n\\* W Open Work" res))))
+
+(ert-deftest tc-archive-matches-lowercase-headings ()
+  (let* ((out (tc-test--archive tc-test--lowercase))
+         (res (plist-get out :result))
+         (open (tc-test--section res "winvm open work"))
+         (resolved (tc-test--section res "winvm resolved")))
+    (should (= 1 (plist-get out :archived)))
+    (should (tc-test--has resolved "fix display resolution"))
+    (should-not (tc-test--has open "fix display resolution"))
+    (should (tc-test--has open "test rebuilt vm"))))
+
+(ert-deftest tc-archive-is-idempotent ()
+  (dolist (fixture (list tc-test--basic tc-test--mixed tc-test--eof
+                         tc-test--lowercase tc-test--nothing))
+    (let ((once (plist-get (tc-test--archive fixture 1) :result))
+          (twice (plist-get (tc-test--archive fixture 2) :result)))
+      (should (equal once twice)))))
+
+(ert-deftest tc-archive-check-mode-previews-without-writing ()
+  (let ((out (tc-test--archive tc-test--basic 1 t)))
+    (should (= 1 (plist-get out :archived)))
+    (should (equal tc-test--basic (plist-get out :result)))
+    (should (member "A finished task" (tc-test--moved-headings (plist-get out :issues))))))
+
+(ert-deftest tc-archive-check-mode-is-idempotent ()
+  (let ((once (tc-test--archive tc-test--mixed 1 t))
+        (twice (tc-test--archive tc-test--mixed 2 t)))
+    (should (equal tc-test--mixed (plist-get once :result)))
+    (should (equal tc-test--mixed (plist-get twice :result)))
+    (should (= 3 (plist-get once :archived)))
+    (should (= 3 (plist-get twice :archived)))))
+
+;;; ---------------------------------------------------------------------------
+;;; Realistic synthetic sample (committed under fixtures/)
+
+(defun tc-test--sample-file ()
+  (expand-file-name "fixtures/todo-sample.org" tc-test--dir))
+
+(ert-deftest tc-archive-realistic-sample ()
+  (let* ((src (tc-test--sample-file)))
+    (skip-unless (file-readable-p src))
+    (let* ((content (with-temp-buffer (insert-file-contents src) (buffer-string)))
+           (out (tc-test--archive content))
+           (res (plist-get out :result))
+           (out2 (tc-test--archive content 2)))
+      ;; every DONE/CANCELLED level-2 entry under "Open Work" moved out
+      (let ((open (tc-test--section res "Sample Open Work")))
+        (should-not (string-match-p "^\\*\\* \\(DONE\\|CANCELLED\\) " open)))
+      ;; structural and still-open level-2 entries stayed
+      (let ((open (tc-test--section res "Sample Open Work")))
+        (should (string-match-p "^\\*\\* TODO " open))
+        (should (string-match-p "^\\*\\* DOING " open)))
+      ;; idempotent
+      (should (equal res (plist-get out2 :result)))
+      ;; something actually moved
+      (should (> (plist-get out :archived) 0)))))
+
+;;; ---------------------------------------------------------------------------
+;;; Sync-child-priority harness + fixtures
+
+(defun tc-test--sync (content &optional runs check)
+  "Write CONTENT to a temp .org file, run `--sync-child-priority' RUNS times
+\(default 1\). Return a plist: :result final file contents, :bumped count from
+the last run, :issues from the last run. CHECK non-nil ⇒ --check (preview)."
+  (let ((file (make-temp-file "tc-test-sync-" nil ".org"))
+        last-bumped last-issues)
+    (unwind-protect
+        (progn
+          (with-temp-file file (insert content))
+          (dotimes (_ (or runs 1))
+            (tc-test--reset-sync check)
+            (tc-process-file file)
+            (setq last-bumped tc-bumped last-issues tc-issues)
+            (tc-test--drop-buffer file))
+          (list :result (with-temp-buffer (insert-file-contents file)
+                                          (buffer-string))
+                :bumped last-bumped
+                :issues last-issues))
+      (tc-test--drop-buffer file)
+      (delete-file file))))
+
+(defun tc-test--priority-of (content heading-substring)
+  "Return the priority letter (a string like \"A\") on the first heading line
+in CONTENT that contains HEADING-SUBSTRING, or nil if the heading has no
+priority cookie."
+  (with-temp-buffer
+    (insert content)
+    (goto-char (point-min))
+    (let (found-line found-prio)
+      (while (and (not found-line) (re-search-forward "^\\*+ .*$" nil t))
+        (let ((line (match-string 0)))
+          (when (string-match-p (regexp-quote heading-substring) line)
+            (setq found-line line)
+            (when (string-match "\\[#\\([A-Z]\\)\\]" line)
+              (setq found-prio (match-string 1 line))))))
+      (unless found-line
+        (error "no heading containing %S" heading-substring))
+      found-prio)))
+
+(defun tc-test--sync-bumped-headings (issues)
+  "Return the heading texts of every `:kind' sync-bumped or sync-would entry
+in ISSUES, in document order."
+  (mapcar (lambda (i) (plist-get i :child-heading))
+          (cl-remove-if-not
+           (lambda (i) (memq (plist-get i :kind) '(sync-bumped sync-would)))
+           (reverse issues))))
+
+(defconst tc-test--sync-basic "\
+* Open Work
+** TODO [#B] Parent
+*** TODO [#D] Drifted child
+*** TODO [#B] Already in sync
+")
+
+(defconst tc-test--sync-multi "\
+* Open Work
+** TODO [#B] Parent
+*** TODO [#A] Higher-priority child stays
+*** TODO [#B] Equal-priority child stays
+*** TODO [#C] Lower-priority child bumps
+*** TODO [#D] Way-lower-priority child bumps
+*** TODO Priority-less child stays
+")
+
+(defconst tc-test--sync-no-sync-tag "\
+* Open Work
+** TODO [#B] Parent
+*** TODO [#D] Regular drifted child
+*** TODO [#D] Follow-up: opted-out :no-sync:
+")
+
+(defconst tc-test--sync-priority-less-parent "\
+* Open Work
+** TODO Parent with no priority
+*** TODO [#D] Child with priority should not move
+")
+
+(defconst tc-test--sync-cascade "\
+* Open Work
+** TODO [#A] Top
+*** TODO [#B] Middle
+**** TODO [#D] Leaf
+")
+
+(defconst tc-test--sync-no-change "\
+* Open Work
+** TODO [#B] Parent
+*** TODO [#A] Child higher
+*** TODO [#B] Child equal
+")
+
+;; A dated-log heading inside a parent task whose title quotes other priorities
+;; in =[#X]= verbatim. Those quoted cookies must NOT be read as the heading's
+;; own priority — the cookie has to sit in canonical position to count.
+(defconst tc-test--sync-cookie-in-title "\
+* Open Work
+** TODO [#B] Parent
+*** 2026-05-14 Reprioritized children =[#D]= → =[#B]= to match parent
+*** TODO [#D] Regular drifted child
+")
+
+;;; ---------------------------------------------------------------------------
+;;; Sync-child-priority tests
+
+(ert-deftest tc-sync-bumps-lower-priority-child ()
+  (let* ((out (tc-test--sync tc-test--sync-basic))
+         (res (plist-get out :result)))
+    (should (= 1 (plist-get out :bumped)))
+    (should (equal "B" (tc-test--priority-of res "Drifted child")))
+    (should (equal "B" (tc-test--priority-of res "Already in sync")))
+    (should (equal "B" (tc-test--priority-of res "Parent")))))
+
+(ert-deftest tc-sync-leaves-higher-and-equal-children-alone ()
+  (let* ((out (tc-test--sync tc-test--sync-multi))
+         (res (plist-get out :result)))
+    (should (= 2 (plist-get out :bumped)))
+    (should (equal "A" (tc-test--priority-of res "Higher-priority child")))
+    (should (equal "B" (tc-test--priority-of res "Equal-priority child")))
+    (should (equal "B" (tc-test--priority-of res "Lower-priority child")))
+    (should (equal "B" (tc-test--priority-of res "Way-lower-priority child")))
+    (should-not (tc-test--priority-of res "Priority-less child"))))
+
+(ert-deftest tc-sync-skips-no-sync-tagged-child ()
+  (let* ((out (tc-test--sync tc-test--sync-no-sync-tag))
+         (res (plist-get out :result)))
+    (should (= 1 (plist-get out :bumped)))
+    (should (equal "B" (tc-test--priority-of res "Regular drifted child")))
+    (should (equal "D" (tc-test--priority-of res "Follow-up: opted-out")))))
+
+(ert-deftest tc-sync-leaves-priority-less-parent-alone ()
+  (let ((out (tc-test--sync tc-test--sync-priority-less-parent)))
+    (should (= 0 (plist-get out :bumped)))
+    (should (equal tc-test--sync-priority-less-parent (plist-get out :result)))))
+
+(ert-deftest tc-sync-cascades-through-multiple-levels ()
+  (let* ((out (tc-test--sync tc-test--sync-cascade))
+         (res (plist-get out :result)))
+    ;; one pass should collapse [#A] → [#B] → [#D] to all [#A] because
+    ;; org-map-entries visits the parent first, bumps the middle, then visits
+    ;; the (now bumped) middle and bumps its leaf
+    (should (= 2 (plist-get out :bumped)))
+    (should (equal "A" (tc-test--priority-of res "Top")))
+    (should (equal "A" (tc-test--priority-of res "Middle")))
+    (should (equal "A" (tc-test--priority-of res "Leaf")))))
+
+(ert-deftest tc-sync-no-change-when-all-children-at-or-above-parent ()
+  (let ((out (tc-test--sync tc-test--sync-no-change)))
+    (should (= 0 (plist-get out :bumped)))
+    (should (equal tc-test--sync-no-change (plist-get out :result)))))
+
+(ert-deftest tc-sync-ignores-cookie-shaped-text-in-title ()
+  (let* ((out (tc-test--sync tc-test--sync-cookie-in-title))
+         (res (plist-get out :result)))
+    ;; Only the real drifted child bumps; the dated-log heading with
+    ;; =[#D]= / =[#B]= verbatim text in its title is untouched.
+    (should (= 1 (plist-get out :bumped)))
+    (should (equal "B" (tc-test--priority-of res "Regular drifted child")))
+    ;; Substring still appears in the dated-log heading; the heading itself
+    ;; was not rewritten.
+    (should (string-match-p "Reprioritized children =\\[#D\\]= → =\\[#B\\]= to match parent" res))))
+
+(ert-deftest tc-sync-is-idempotent ()
+  (dolist (fixture (list tc-test--sync-basic
+                         tc-test--sync-multi
+                         tc-test--sync-no-sync-tag
+                         tc-test--sync-priority-less-parent
+                         tc-test--sync-cascade
+                         tc-test--sync-no-change
+                         tc-test--sync-cookie-in-title))
+    (let ((once (plist-get (tc-test--sync fixture 1) :result))
+          (twice (plist-get (tc-test--sync fixture 2) :result)))
+      (should (equal once twice)))))
+
+(ert-deftest tc-sync-check-mode-previews-without-writing ()
+  (let ((out (tc-test--sync tc-test--sync-basic 1 t)))
+    (should (= 1 (plist-get out :bumped)))
+    (should (equal tc-test--sync-basic (plist-get out :result)))
+    (should (member "Drifted child"
+                    (tc-test--sync-bumped-headings (plist-get out :issues))))))
+
+(ert-deftest tc-sync-check-mode-is-idempotent ()
+  (let ((once (tc-test--sync tc-test--sync-cascade 1 t))
+        (twice (tc-test--sync tc-test--sync-cascade 2 t)))
+    (should (equal tc-test--sync-cascade (plist-get once :result)))
+    (should (equal tc-test--sync-cascade (plist-get twice :result)))
+    (should (= 2 (plist-get once :bumped)))
+    (should (= 2 (plist-get twice :bumped)))))
+
+(provide 'test-todo-cleanup)
+;;; test-todo-cleanup.el ends here