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 --convert-subtasks todo.org       # dated-rewrite done level-3+ sub-tasks
;;   emacs --batch -q -l todo-cleanup.el --convert-subtasks --check todo.org  # preview the conversion
;;   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)
;;
;; Four 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.
;;
;; * --convert-subtasks (opt-in). Rewrites every level-3-and-deeper heading whose
;;   TODO state is DONE/CANCELLED/FAILED into a dated event-log entry
;;   (`<stars> YYYY-MM-DD Day @ HH:MM:SS -ZZZZ <text>'), dropping the keyword,
;;   priority cookie, and tags, and removing the now-redundant CLOSED line. The
;;   date and time come from that entry's own CLOSED cookie; a date-only close
;;   yields 00:00:00, and the UTC offset is computed DST-aware for that date.
;;   This enforces the todo-format depth rule that interactive closes
;;   (`org-log-done' → DONE + CLOSED) and `--archive-done' (level-2 only) leave
;;   unapplied. The heading text is preserved verbatim — a batch tool can't
;;   past-tense an imperative title reliably. Idempotent (an already-dated
;;   heading has no done keyword); a done sub-task with no parseable CLOSED date
;;   is flagged and left alone, never stamped with a fabricated date. Like
;;   --archive-done 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" "FAILED")))

(defconst tc-done-states '("DONE" "CANCELLED")
  "TODO keywords that mark an entry as completed for `--archive-done'.")

(defconst tc--convert-done-states '("DONE" "CANCELLED" "FAILED")
  "TODO keywords whose level-3-and-deeper entries `--convert-subtasks' rewrites
to dated event-log entries.  Broader than `tc-done-states' because a FAILED
sub-task is terminal too and belongs in the parent's dated history.")

(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-converted 0)
(defvar tc-issues nil)
(defvar tc-check-only nil)
(defvar tc-archive-done nil)
(defvar tc-sync-child-priority nil)
(defvar tc-convert-subtasks 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))

;;; ---------------------------------------------------------------------------
;;; --convert-subtasks mode
;;
;; A sub-task (a heading at level 3 or deeper, i.e. under a parent task) that is
;; marked DONE/CANCELLED/FAILED should become a dated event-log entry per the
;; todo-format depth rule: drop the keyword, priority cookie, and tags, and
;; rewrite the heading to `<stars> YYYY-MM-DD Day @ HH:MM:SS -ZZZZ <text>' so the
;; parent's subtree grows a chronological history instead of a long tail of
;; nested DONE lines.  Nothing enforced this before: `org-log-done' just flips an
;; interactive close to DONE + CLOSED, and `--archive-done' only touches level 2.
;; So level-3+ closes piled up as DONE keywords.  This mode converts them
;; mechanically, pulling the timestamp from each entry's own CLOSED cookie.  The
;; heading text is kept verbatim (a batch tool can't reliably past-tense an
;; imperative title, and guessing prose in the task file is worse than leaving it
;; as written).  Idempotent: an already-dated heading has no done keyword, so it
;; is skipped.  A done sub-task with no parseable CLOSED cookie can't be dated, so
;; it is flagged and left alone rather than stamped with a fabricated date.

(defun tc--closed-parts-in-entry ()
  "Return a plist (:year :month :day :dow :hour :minute) from the CLOSED cookie
of the entry at point, or nil when the entry has no parseable CLOSED line.
:hour and :minute are nil when the cookie carries only a date.  The CLOSED line
sits in canonical position directly under the heading, so the first match within
the entry is the task's own close."
  (save-excursion
    (org-back-to-heading t)
    (let ((end (save-excursion
                 (or (outline-next-heading) (goto-char (point-max)))
                 (point))))
      (when (re-search-forward
             (concat "CLOSED:[ \t]*\\[\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)"
                     "[ \t]+\\([A-Za-z]+\\)"
                     "\\(?:[ \t]+\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\]")
             end t)
        (list :year (match-string 1) :month (match-string 2) :day (match-string 3)
              :dow (match-string 4)
              :hour (match-string 5) :minute (match-string 6))))))

(defun tc--tz-offset-string (year month day hour minute)
  "Return the local UTC offset (e.g. \"-0500\") for the given wall-clock instant.
DST-aware: `encode-time' with an unknown-DST field lets the system pick the
correct offset for that date, so a summer close reads -0400 and a winter one
-0500 without hardcoding either."
  (format-time-string
   "%z" (encode-time (list 0 minute hour day month year nil -1 nil))))

(defun tc--dated-header-line (level parts title)
  "Build the dated event-log heading string from LEVEL, CLOSED PARTS, and TITLE.
Missing time in PARTS defaults to 00:00:00 (the close logged only a date)."
  (let* ((year (plist-get parts :year))
         (month (plist-get parts :month))
         (day (plist-get parts :day))
         (dow (plist-get parts :dow))
         (hh (or (plist-get parts :hour) "00"))
         (mm (or (plist-get parts :minute) "00"))
         (tz (tc--tz-offset-string (string-to-number year)
                                   (string-to-number month)
                                   (string-to-number day)
                                   (string-to-number hh)
                                   (string-to-number mm))))
    (format "%s %s-%s-%s %s @ %s:%s:00 %s %s"
            (make-string level ?*) year month day dow hh mm tz title)))

(defun tc--convert-collect-targets ()
  "Markers at every heading at level >= 3 whose TODO state is a done state.
Collected up front so the rewrite loop can edit the buffer without disturbing an
in-progress `org-map-entries' walk; markers track their headings across edits."
  (let (targets)
    (org-map-entries
     (lambda ()
       (when (and (>= (org-current-level) 3)
                  (member (org-get-todo-state) tc--convert-done-states))
         (push (copy-marker (point)) targets)))
     nil 'file)
    (nreverse targets)))

(defun tc--convert-one-subtask (marker)
  "Convert the done sub-task heading at MARKER to a dated event-log entry.
Under `tc-check-only' the conversion is reported but not performed."
  (goto-char marker)
  (org-back-to-heading t)
  (let* ((level (org-current-level))
         (title (org-get-heading t t t t))
         (line (line-number-at-pos))
         (parts (tc--closed-parts-in-entry)))
    (cond
     ((null parts)
      (push (list :kind 'convert-skip :file tc-current-file
                  :line line :heading title
                  :detail "no CLOSED date to derive the timestamp")
            tc-issues))
     (t
      (let ((new (tc--dated-header-line level parts title)))
        (cl-incf tc-converted)
        (if tc-check-only
            (push (list :kind 'convert-would :file tc-current-file
                        :line line :heading title :new new)
                  tc-issues)
          ;; Replace the heading line, then drop the now-redundant CLOSED
          ;; cookie from the entry (its date now lives in the header).  Only
          ;; the cookie goes: a planning line can also carry DEADLINE: or
          ;; SCHEDULED: beside it, and those survive on their line.  A line
          ;; left blank by the removal is deleted whole.
          (delete-region (line-beginning-position) (line-end-position))
          (insert new)
          (let ((end (save-excursion
                       (or (outline-next-heading) (goto-char (point-max)))
                       (point))))
            (save-excursion
              (when (re-search-forward "CLOSED:[ \t]*\\[[^]]*\\][ \t]*" end t)
                (replace-match "")
                (let ((bol (line-beginning-position))
                      (eol (line-end-position)))
                  (if (string-match-p "\\`[ \t]*\\'"
                                      (buffer-substring bol eol))
                      (delete-region bol (min (1+ eol) (point-max)))
                    (goto-char bol)
                    (when (looking-at "[ \t]+")
                      (replace-match "")))))))
          (push (list :kind 'convert-done :file tc-current-file
                      :line line :heading title :new new)
                tc-issues)))))))

(defun tc-convert-subtasks-in-file ()
  "Rewrite every level-3-and-deeper DONE/CANCELLED/FAILED heading to a dated
event-log entry, pulling the timestamp from its CLOSED cookie.  Honors
`tc-check-only'."
  (let ((targets (tc--convert-collect-targets)))
    (dolist (m targets)
      (tc--convert-one-subtask m)
      (set-marker m nil))))

;;; ---------------------------------------------------------------------------
;;; 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))
     (tc-convert-subtasks
      (tc-convert-subtasks-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-convert-report ()
  ;; Silent on a real-mode no-op (nothing to convert and nothing skipped), for
  ;; the same reason as the archive report: the wrap runs cleanup passes more
  ;; than once, and a vocal \"0 converted\" reads as noise. Check mode always
  ;; reports (the preview is what the caller asked for), and a skip always
  ;; reports (a done sub-task with no CLOSED date is a real condition to see).
  (let ((has-skip (cl-some (lambda (i) (eq (plist-get i :kind) 'convert-skip))
                           tc-issues)))
    (when (or tc-check-only (> tc-converted 0) has-skip)
      (princ (format "todo-cleanup --convert-subtasks: %d sub-task(s) %s%s\n"
                     tc-converted
                     (if tc-check-only "would convert" "converted")
                     (if tc-check-only " — CHECK MODE (no writes)" "")))
      (dolist (i (reverse tc-issues))
        (pcase (plist-get i :kind)
          ((or 'convert-done 'convert-would)
           (princ (format "    %s:%d: %s\n      → %s\n"
                          (plist-get i :file) (plist-get i :line)
                          (plist-get i :heading) (plist-get i :new))))
          ('convert-skip
           (princ (format "  skipped %s:%d: %s — %s\n"
                          (plist-get i :file) (plist-get i :line)
                          (plist-get i :heading) (plist-get i :detail)))))))))

(defun tc-emit-report ()
  (cond (tc-archive-done (tc--emit-archive-report))
        (tc-sync-child-priority (tc--emit-sync-report))
        (tc-convert-subtasks (tc--emit-convert-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)))
  (when (member "--convert-subtasks" command-line-args-left)
    (setq tc-convert-subtasks t)
    (setq command-line-args-left (delete "--convert-subtasks" 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 | --convert-subtasks | --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"
                                      "--convert-subtasks"
                                      "--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