diff options
| author | Craig Jennings <c@cjennings.net> | 2026-05-11 15:24:42 -0500 |
|---|---|---|
| committer | Craig Jennings <c@cjennings.net> | 2026-05-11 15:24:42 -0500 |
| commit | 571494b81e4608f8479bb8c761183b1d28798ca0 (patch) | |
| tree | 3f8cde8813b74d5c24631f0a3e1b114f842022d6 | |
| parent | 54845d38cc3ed8ca5b1093eb7a44d3db9db8f22d (diff) | |
| download | rulesets-571494b81e4608f8479bb8c761183b1d28798ca0.tar.gz rulesets-571494b81e4608f8479bb8c761183b1d28798ca0.zip | |
feat(todo-cleanup): add --archive-done mode with ERT test suite
--archive-done moves every level-2 subtree whose TODO state is DONE or CANCELLED out of the "Open Work" section into the "Resolved" section of the same org file, subtree intact. Sections match on a unique level-1 heading containing "Open Work" (case-insensitive) and one containing "Resolved"; a missing or ambiguous section skips the file with a message rather than crashing. Only direct level-2 children move. A DONE entry nested under an open parent stays put. Opt-in, never run by default, doesn't also run the hygiene passes; --check previews without writing.
The CLI dispatch moved into tc-main behind a guard so the new ERT suite can require the file without firing it. Hygiene mode is unchanged.
13 ERT cases (the repo's first elisp tests) cover the move and the stay-put cases, EOF with no final newline, missing or ambiguous sections, lowercase headings, idempotency, and --check. tests/fixtures/todo-sample.org is the synthetic sample, and the Makefile test target now runs the ERT suites alongside pytest.
| -rw-r--r-- | .ai/scripts/tests/fixtures/todo-sample.org | 37 | ||||
| -rw-r--r-- | .ai/scripts/tests/test-todo-cleanup.el | 319 | ||||
| -rw-r--r-- | .ai/scripts/todo-cleanup.el | 239 | ||||
| -rw-r--r-- | Makefile | 10 |
4 files changed, 575 insertions, 30 deletions
diff --git a/.ai/scripts/tests/fixtures/todo-sample.org b/.ai/scripts/tests/fixtures/todo-sample.org new file mode 100644 index 0000000..8b9e723 --- /dev/null +++ b/.ai/scripts/tests/fixtures/todo-sample.org @@ -0,0 +1,37 @@ +#+TITLE: Sample todo.org for todo-cleanup tests +#+AUTHOR: synthetic fixture + +# A deliberately varied (but synthetic) todo.org: umbrella "Open Work" / +# "Resolved" headings, mixed TODO/DOING/WAITING/DONE/CANCELLED states, +# priorities, tags, nested level-3 children, and a few structural (no-state) +# section headings. `--archive-done' should move only the direct level-2 +# DONE/CANCELLED subtrees from "Open Work" into "Resolved", intact, and leave +# everything else alone. + +* Sample Open Work +** TODO [#A] Write the README + This one stays — still open. +** DOING [#A] Refactor the parser + In progress; stays. +** DONE [#A] Bootstrap the test harness :tooling: + Finished. Should move to Resolved with this body intact. +** WAITING [#B] Vendor reply on the licensing question + Blocked, not done — stays. +** A grouping heading with no TODO state +*** TODO [#B] sub-task one +*** DONE [#C] sub-task two — done, but nested under an open parent, so stays +** CANCELLED [#B] Drop the legacy importer :chore: + Decided against it. Should move to Resolved. +** TODO [#B] Ship the migration :quick: +*** DONE [#C] write the up migration +*** TODO [#C] write the down migration +** DONE [#B] Tag the 1.0 release +*** DONE [#C] update the changelog +*** TODO [#C] announce on the list + Parent is DONE, so the whole subtree (open child included) moves. +** NEXT [#C] Pick the next milestone + +* Sample Resolved +** DONE [#A] Initial project skeleton + Pre-existing archived entry; new arrivals append after this one. +** CANCELLED [#C] Evaluate the other framework diff --git a/.ai/scripts/tests/test-todo-cleanup.el b/.ai/scripts/tests/test-todo-cleanup.el new file mode 100644 index 0000000..9d11b5c --- /dev/null +++ b/.ai/scripts/tests/test-todo-cleanup.el @@ -0,0 +1,319 @@ +;;; 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-issues nil + tc-check-only (and check t) tc-archive-done 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))))) + +(provide 'test-todo-cleanup) +;;; test-todo-cleanup.el ends here diff --git a/.ai/scripts/todo-cleanup.el b/.ai/scripts/todo-cleanup.el index c4231f4..4988db0 100644 --- a/.ai/scripts/todo-cleanup.el +++ b/.ai/scripts/todo-cleanup.el @@ -1,26 +1,36 @@ -;;; todo-cleanup.el --- Auto-fix and audit for todo.org hygiene +;;; 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 fixes in place -;; emacs --batch -q -l todo-cleanup.el --check todo.org # report-only +;; 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 ;; -;; What it does: +;; Two independent modes: ;; -;; 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. +;; * Default (hygiene). Designed for the wrap-it-up workflow: cheap, idempotent, +;; safe to run every session. ;; -;; 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). +;; 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. ;; -;; Designed for the wrap-it-up workflow: cheap (~0.4s on a 3700-line todo.org), -;; idempotent, and safe to run every session. Any fixes show up in the -;; wrap-up commit's diff for review. +;; 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. (require 'org) (require 'cl-lib) @@ -28,11 +38,19 @@ (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'.") + (defvar tc-fixes 0) +(defvar tc-archived 0) (defvar tc-issues nil) (defvar tc-check-only nil) +(defvar tc-archive-done 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 @@ -60,8 +78,8 @@ states are identical." tc-issues))))))) (defun tc-detect-orphan-planning-in-entry () - "Flag entries where DEADLINE/SCHEDULED is in the body but org-entry-get returns nil. -This means the planning line isn't in canonical position, so org-mode's + "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)) @@ -89,18 +107,158 @@ agenda + scheduling machinery won't see it." :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))))))))) + +;;; --------------------------------------------------------------------------- +;;; Driver + reporting + (defun tc-process-file (file) (setq tc-current-file (file-name-nondirectory file)) (with-current-buffer (find-file-noselect file) (org-mode) - ;; 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) + (if tc-archive-done + (tc-archive-done-in-file) + ;; 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-report () +(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)" ""))) @@ -129,15 +287,22 @@ agenda + scheduling machinery won't see it." (plist-get i :heading) (plist-get i :detail))))))) -(when noninteractive - ;; Mutate `command-line-args-left' so emacs's own arg parser doesn't see - ;; --check after our script returns. +(defun tc-emit-report () + (if tc-archive-done (tc--emit-archive-report) (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))) (if (null command-line-args-left) - (progn (princ "Usage: emacs --batch -q -l todo-cleanup.el [--check] FILE...\n") - (kill-emacs 1)) + (progn + (princ "Usage: emacs --batch -q -l todo-cleanup.el [--check] [--archive-done] FILE...\n") + (kill-emacs 1)) (let ((files command-line-args-left)) (setq command-line-args-left nil) (dolist (file files) @@ -145,5 +310,21 @@ agenda + scheduling machinery won't see it." (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")) 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 @@ -62,7 +62,7 @@ endef .PHONY: help install uninstall list install-hooks uninstall-hooks \ install-lang install-elisp install-python list-languages \ - install-mcp diff lint doctor deps + install-mcp diff lint doctor test deps ##@ General @@ -352,3 +352,11 @@ lint: ## Validate ruleset structure (headings, Applies-to, shebangs, exec bits) doctor: ## Verify ~/.claude/ live state matches repo + settings.json (drift detector) @bash scripts/doctor.sh + +test: ## Run the .ai/scripts/ test suites (pytest + ERT) + @cd .ai/scripts/tests && python3 -m pytest + @set -e; for f in .ai/scripts/tests/test-*.el; do \ + [ -e "$$f" ] || continue; \ + echo "ert: $$(basename "$$f")"; \ + emacs --batch -q -L .ai/scripts -l ert -l "$$f" -f ert-run-tests-batch-and-exit; \ + done |
