;;; 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). Two steps, in order:
;;
;;   1. 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.
;;
;;   2. Ages the "Resolved" section: a level-2 DONE/CANCELLED subtree whose
;;      CLOSED date is older than `tc-archive-retain-days' (default 7) is moved
;;      out to `tc-archive-file' (default `archive/task-archive.org' beside the
;;      todo file), keeping only the last week of closed tasks in the file
;;      itself. Only subtrees closed within the window stay; older ones, and
;;      those with no parseable CLOSED date, are moved out. Set
;;      `tc-archive-retain-days' to nil to disable this step (legacy in-file-only
;;      behavior). The aging date is `tc-archive-reference-date' when set
;;      (tests), otherwise the real current date. The archive inherits the todo
;;      file's gitignore status: when the todo file is gitignored, the archive
;;      path is added to .gitignore before the first write, so private task
;;      history never lands in a tracked path (see
;;      `tc--ensure-archive-gitignored').
;;
;;   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)
(require 'calendar)

(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)
(defvar tc-current-dir nil)
(defvar tc-archived-to-file 0)

(defvar tc-archive-retain-days 7
  "Retention window for the `--archive-done' file-aging step. A closed Resolved
subtree whose CLOSED date is within this many days of the reference date stays
in the in-file Resolved section; an older one is moved out to `tc-archive-file'.
A subtree with no parseable CLOSED date stays. nil disables the aging step
entirely, leaving the legacy in-file-only behavior.")

(defvar tc-archive-reference-date nil
  "(YEAR MONTH DAY) treated as \"today\" when aging Resolved subtrees out to a
file; nil means the real current date. Set in tests for determinism.")

(defvar tc-archive-file nil
  "Destination file for aged-out Resolved subtrees; nil means
`archive/task-archive.org' beside the todo file being processed.")

;;; ---------------------------------------------------------------------------
;;; 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)))
      (tc-archive-old-resolved-to-file))
     (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)))))
      (tc-archive-old-resolved-to-file)))))

;;; ---------------------------------------------------------------------------
;;; --archive-done: age old Resolved subtrees out to a file

(defconst tc-archive-file-scaffold
  "#+TITLE: Task Archive\n#+FILETAGS: :archive:\n\n* Resolved (archived)\n"
  "Initial content written to a fresh `tc-archive-file'. Aged subtrees are
appended as level-2 children under the level-1 heading.")

(defun tc--reference-absolute ()
  "Absolute (Gregorian serial) day number of the aging reference date —
`tc-archive-reference-date' when set, otherwise the real current date."
  (if tc-archive-reference-date
      (pcase-let ((`(,y ,m ,d) tc-archive-reference-date))
        (calendar-absolute-from-gregorian (list m d y)))
    (pcase-let ((`(,m ,d ,y) (calendar-current-date)))
      (calendar-absolute-from-gregorian (list m d y)))))

(defun tc--closed-absolute-in-region (beg end)
  "Absolute day number of the first CLOSED: [YYYY-MM-DD ...] line in BEG..END,
or nil when the region carries no parseable CLOSED date. The task's own CLOSED
line sits in canonical position directly under the heading, so the first match
in the subtree is the task's close."
  (save-excursion
    (goto-char beg)
    (when (re-search-forward
           "CLOSED:[ \t]*\\[\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)"
           end t)
      (calendar-absolute-from-gregorian
       (list (string-to-number (match-string 2))
             (string-to-number (match-string 3))
             (string-to-number (match-string 1)))))))

(defun tc--archive-file-path ()
  "Resolve the destination file for aged-out subtrees: `tc-archive-file' if set,
else `archive/task-archive.org' beside the todo file being processed."
  (or tc-archive-file
      (and tc-current-dir
           (expand-file-name "archive/task-archive.org" tc-current-dir))))

(defun tc--git-ignored-p (path)
  "Non-nil when PATH is gitignored (git check-ignore exits 0). nil on any git
error or when git is unavailable."
  (let ((default-directory (or tc-current-dir default-directory)))
    (eq 0 (ignore-errors
            (call-process "git" nil nil nil "check-ignore" "-q"
                          (expand-file-name path))))))

(defun tc--ensure-archive-gitignored (archive-path)
  "Keep the aged-out archive as private as the todo file it derives from. When the
todo file being processed is gitignored but ARCHIVE-PATH is not, append a
root-relative ignore entry for ARCHIVE-PATH to the project's .gitignore. No-op
when the todo file is tracked, the archive is already ignored, or there is no git
work tree — so track-mode projects (todo file tracked) leave the archive tracked
too. This is what makes the aging step safe to ship to gitignore-mode projects,
where todo.org is private: the archive inherits that privacy instead of leaking
previously-ignored task history into a tracked path."
  (when (and tc-current-file tc-current-dir)
    (let* ((todo (expand-file-name tc-current-file tc-current-dir))
           (default-directory tc-current-dir)
           (root (with-temp-buffer
                   (when (eq 0 (ignore-errors
                                 (call-process "git" nil (current-buffer) nil
                                               "rev-parse" "--show-toplevel")))
                     (string-trim (buffer-string))))))
      (when (and root (> (length root) 0) (file-directory-p root)
                 (tc--git-ignored-p todo)
                 (not (tc--git-ignored-p archive-path)))
        (let ((entry (concat "/" (file-relative-name
                                  (expand-file-name archive-path) root)))
              (gi (expand-file-name ".gitignore" root)))
          (with-temp-buffer
            (when (file-readable-p gi) (insert-file-contents gi))
            (unless (save-excursion
                      (goto-char (point-min))
                      (re-search-forward (concat "^" (regexp-quote entry) "$") nil t))
              (goto-char (point-max))
              (unless (bolp) (insert "\n"))
              (insert "\n# Claude Code: task archive (follows todo file privacy)\n"
                      entry "\n")
              (write-region (point-min) (point-max) gi nil 'silent))))))))

(defun tc--append-subtrees-to-archive-file (path texts)
  "Append TEXTS (subtree strings) under the level-1 heading in PATH, creating the
file with `tc-archive-file-scaffold' and the parent directory when absent.
Ensures the archive inherits the todo file's gitignore status first."
  (when (and path texts)
    (tc--ensure-archive-gitignored path)
    (let ((dir (file-name-directory path)))
      (when (and dir (not (file-directory-p dir)))
        (make-directory dir t)))
    (with-temp-buffer
      (when (file-readable-p path)
        (insert-file-contents path))
      (when (= (point-min) (point-max))
        (insert tc-archive-file-scaffold))
      ;; Guarantee a level-1 heading to append under (older files might lack one).
      (goto-char (point-min))
      (unless (re-search-forward "^\\* " nil t)
        (goto-char (point-max))
        (unless (bolp) (insert "\n"))
        (insert "* Resolved (archived)\n"))
      (goto-char (point-max))
      (unless (bolp) (insert "\n"))
      (dolist (text texts)
        (insert text)
        (unless (bolp) (insert "\n")))
      (write-region (point-min) (point-max) path nil 'silent))))

(defun tc-archive-old-resolved-to-file ()
  "Move level-2 DONE/CANCELLED subtrees in the \"Resolved\" section whose CLOSED
date predates the `tc-archive-retain-days' window out to `tc--archive-file-path'.
Only subtrees closed within the window stay; older ones, and those with no
parseable CLOSED date, are moved out. A nil `tc-archive-retain-days' disables the
step. Honors `tc-check-only' (report only)."
  (when tc-archive-retain-days
    (let ((res (tc--find-section "resolved")))
      (when (integerp res)
        (let* ((cutoff (- (tc--reference-absolute) tc-archive-retain-days))
               (moves nil))
          (dolist (pos (tc--done-level-2-children res))
            (save-excursion
              (goto-char pos)
              (let* ((region (tc--subtree-region))
                     (beg (car region))
                     (end (cdr region))
                     (closed (tc--closed-absolute-in-region beg end)))
                ;; Archive anything not provably within the window: closed
                ;; before the cutoff, or with no parseable CLOSED date at all.
                (when (or (null closed) (< closed cutoff))
                  (push (list :beg beg :end end
                              :heading (org-get-heading t t t t)
                              :line (line-number-at-pos beg))
                        moves)))))
          (setq moves (nreverse moves))   ; document order
          (cond
           ((null moves) nil)
           (tc-check-only
            (dolist (m moves)
              (cl-incf tc-archived-to-file)
              (push (list :kind 'archive-file-would :file tc-current-file
                          :line (plist-get m :line) :heading (plist-get m :heading))
                    tc-issues)))
           (t
            ;; Capture text before any deletion (positions are still valid), then
            ;; delete bottom-up so earlier subtree positions stay correct.
            (let ((texts (mapcar
                          (lambda (m)
                            (concat (string-trim-right
                                     (buffer-substring-no-properties
                                      (plist-get m :beg) (plist-get m :end))
                                     "[ \t\n]+")
                                    "\n"))
                          moves)))
              (dolist (m (sort (copy-sequence moves)
                               (lambda (a b) (> (plist-get a :beg) (plist-get b :beg)))))
                (delete-region (plist-get m :beg) (plist-get m :end)))
              (tc--append-subtrees-to-archive-file (tc--archive-file-path) texts)
              (dolist (m moves)
                (cl-incf tc-archived-to-file)
                (push (list :kind 'archive-file-moved :file tc-current-file
                            :line (plist-get m :line) :heading (plist-get m :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))
  (setq tc-current-dir (file-name-directory (expand-file-name 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)))))))
    ;; Aged-out subtrees: only reported when some moved (or would). Additive to
    ;; the in-file report above, and absent when the aging step is disabled.
    (when (> tc-archived-to-file 0)
      (princ (format "todo-cleanup --archive-done: %d aged subtree(s) %s task-archive.org%s\n"
                     tc-archived-to-file
                     (if tc-check-only "would move to" "moved to")
                     (if tc-check-only " — CHECK MODE (no writes)" "")))
      (dolist (i (reverse tc-issues))
        (pcase (plist-get i :kind)
          ((or 'archive-file-moved 'archive-file-would)
           (princ (format "    %s:%d: %s %s\n"
                          (plist-get i :file)
                          (plist-get i :line)
                          (if tc-check-only "would archive" "archived")
                          (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