;;; 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
;;
;; Two 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.

(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'.")

(defvar tc-fixes 0)
(defvar tc-archived 0)
(defvar tc-issues nil)
(defvar tc-check-only nil)
(defvar tc-archive-done nil)
(defvar tc-current-file nil)

;;; ---------------------------------------------------------------------------
;;; Hygiene mode

(defun tc-fix-bogus-state-log-in-entry ()
  "Delete bogus state-log lines within the entry at point.
A bogus log line matches `- State \"X\" from \"X\" [date]' where the two
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)))))))))

;;; ---------------------------------------------------------------------------
;;; Driver + reporting

(defun tc-process-file (file)
  (setq tc-current-file (file-name-nondirectory file))
  (with-current-buffer (find-file-noselect file)
    (org-mode)
    (if tc-archive-done
        (tc-archive-done-in-file)
      ;; Pass 1: auto-fix bogus state logs (or report under --check).
      (org-map-entries #'tc-fix-bogus-state-log-in-entry nil 'file)
      ;; Pass 2: detect orphan planning lines (always report-only).
      (org-map-entries #'tc-detect-orphan-planning-in-entry nil 'file))
    (when (and (not tc-check-only) (buffer-modified-p))
      (save-buffer))))

(defun tc--emit-archive-report ()
  (princ (format "todo-cleanup --archive-done: %d subtree(s) %s%s\n"
                 tc-archived
                 (if tc-check-only "would move" "moved")
                 (if tc-check-only " — CHECK MODE (no writes)" "")))
  (dolist (i (reverse tc-issues))
    (pcase (plist-get i :kind)
      ('archive-skip
       (princ (format "  skipped %s: %s\n" (plist-get i :file) (plist-get i :detail))))
      ((or 'archive-moved 'archive-would)
       (princ (format "    %s:%d: %s %s\n"
                      (plist-get i :file)
                      (plist-get i :line)
                      (if tc-check-only "would move" "moved")
                      (plist-get i :heading)))))))

(defun tc--emit-hygiene-report ()
  (princ (format "todo-cleanup: %d fix(es) applied%s\n"
                 tc-fixes
                 (if tc-check-only " — CHECK MODE (no writes)" "")))
  (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-report ()
  (if tc-archive-done (tc--emit-archive-report) (tc--emit-hygiene-report)))

(defun tc-main ()
  ;; Strip our flags from `command-line-args-left' so emacs's own arg parser
  ;; doesn't see them after this returns.
  (when (member "--check" command-line-args-left)
    (setq tc-check-only t)
    (setq command-line-args-left (delete "--check" command-line-args-left)))
  (when (member "--archive-done" command-line-args-left)
    (setq tc-archive-done t)
    (setq command-line-args-left (delete "--archive-done" command-line-args-left)))
  (if (null command-line-args-left)
      (progn
        (princ "Usage: emacs --batch -q -l todo-cleanup.el [--check] [--archive-done] 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")) 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