path: root/.ai/scripts/todo-cleanup.el

;;; 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 ()
  ;; A real-mode no-op stays silent. When nothing moved and nothing was
  ;; skipped, there's nothing to report — and the wrap runs this twice
  ;; (wrap-it-up, then open-tasks.org Phase A), so a vocal "0 subtree(s) moved"
  ;; on the second pass reads as alarming next to the first pass's diff. Check
  ;; mode always reports (a "0 would move" preview is information the caller
  ;; asked for), and a skip always reports (a missing section is a real
  ;; condition, not a no-op).
  (let ((has-skip (cl-some (lambda (i) (eq (plist-get i :kind) 'archive-skip))
                           tc-issues)))
    (when (or tc-check-only (> tc-archived 0) has-skip)
      (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