diff options
| -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 |