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

;;; test-todo-cleanup.el --- ERT tests for todo-cleanup.el  -*- lexical-binding: t; -*-
;;
;; Run from the repo root:
;;   emacs --batch -q -L .ai/scripts -l ert \
;;         -l .ai/scripts/tests/test-todo-cleanup.el \
;;         -f ert-run-tests-batch-and-exit
;;
;; or from .ai/scripts/tests/:
;;   emacs --batch -q -L .. -l ert -l test-todo-cleanup.el \
;;         -f ert-run-tests-batch-and-exit
;;
;; Covers the `--archive-done' mode: moving level-2 DONE/CANCELLED subtrees
;; out of the "Open Work" section into the "Resolved" section.

(require 'ert)
(require 'cl-lib)

(defconst tc-test--dir
  (file-name-directory (or load-file-name buffer-file-name default-directory))
  "Directory of this test file, captured at load time.")

;; Make `todo-cleanup' loadable from the parent directory.  Loading it is
;; inert: its CLI dispatch only fires when the trailing command-line args look
;; like a real invocation (recognized flags / readable file paths), which they
;; don't during `ert-run-tests-batch-and-exit'.
(add-to-list 'load-path (expand-file-name ".." tc-test--dir))
(require 'todo-cleanup)

;;; ---------------------------------------------------------------------------
;;; Harness

(defun tc-test--reset (&optional check)
  (setq tc-fixes 0 tc-archived 0 tc-bumped 0 tc-issues nil
        tc-check-only (and check t)
        tc-archive-done t tc-sync-child-priority nil
        tc-current-file nil))

(defun tc-test--reset-sync (&optional check)
  (setq tc-fixes 0 tc-archived 0 tc-bumped 0 tc-issues nil
        tc-check-only (and check t)
        tc-archive-done nil tc-sync-child-priority t
        tc-current-file nil))

(defun tc-test--drop-buffer (file)
  (let ((buf (find-buffer-visiting file)))
    (when buf
      (with-current-buffer buf (set-buffer-modified-p nil))
      (kill-buffer buf))))

(defun tc-test--archive (content &optional runs check)
  "Write CONTENT to a temp .org file, run `--archive-done' RUNS times (default 1).
Return a plist: :result final file contents, :archived count from the last run,
:issues from the last run.  CHECK non-nil ⇒ --check (preview, no writes)."
  (let ((file (make-temp-file "tc-test-" nil ".org"))
        last-archived last-issues)
    (unwind-protect
        (progn
          (with-temp-file file (insert content))
          (dotimes (_ (or runs 1))
            (tc-test--reset check)
            (tc-process-file file)
            (setq last-archived tc-archived last-issues tc-issues)
            (tc-test--drop-buffer file))
          (list :result (with-temp-buffer (insert-file-contents file)
                                          (buffer-string))
                :archived last-archived
                :issues last-issues))
      (tc-test--drop-buffer file)
      (delete-file file))))

(defun tc-test--archive-report (content &optional runs check)
  "Like `tc-test--archive' but also returns :report — the captured stdout of
`tc--emit-archive-report' from the last run.  After the run loop the globals
still hold the last run's `tc-archived'/`tc-issues'/`tc-check-only', so the
captured report is the one that run would have printed."
  (let ((file (make-temp-file "tc-test-" nil ".org"))
        last-archived last-issues report)
    (unwind-protect
        (progn
          (with-temp-file file (insert content))
          (dotimes (_ (or runs 1))
            (tc-test--reset check)
            (tc-process-file file)
            (setq last-archived tc-archived last-issues tc-issues)
            (tc-test--drop-buffer file))
          (setq report (with-output-to-string (tc--emit-archive-report)))
          (list :report report
                :archived last-archived
                :issues last-issues))
      (tc-test--drop-buffer file)
      (delete-file file))))

(defun tc-test--section (content needle)
  "Text of the level-1 section in CONTENT whose heading line contains NEEDLE —
from the heading line through (not including) the next level-1 heading or EOF."
  (with-temp-buffer
    (insert content)
    (goto-char (point-min))
    (let (start)
      (while (and (not start) (re-search-forward "^\\* .*$" nil t))
        (when (string-match-p (regexp-quote needle) (match-string 0))
          (setq start (match-beginning 0))))
      (unless start (error "no level-1 heading containing %S" needle))
      (goto-char start)
      (forward-line 1)
      (buffer-substring-no-properties
       start
       (if (re-search-forward "^\\* " nil t) (match-beginning 0) (point-max))))))

(defun tc-test--has (string substring)
  (and (string-match-p (regexp-quote substring) string) t))

(defun tc-test--before-p (string a b)
  "Non-nil when SUBSTRING A occurs before SUBSTRING B in STRING."
  (let ((ia (string-match (regexp-quote a) string))
        (ib (string-match (regexp-quote b) string)))
    (and ia ib (< ia ib))))

(defun tc-test--skip-detail (issues)
  (let ((skip (cl-find-if (lambda (i) (eq (plist-get i :kind) 'archive-skip)) issues)))
    (and skip (plist-get skip :detail))))

(defun tc-test--moved-headings (issues)
  (mapcar (lambda (i) (plist-get i :heading))
          (cl-remove-if-not
           (lambda (i) (memq (plist-get i :kind) '(archive-moved archive-would)))
           (reverse issues))))

;;; ---------------------------------------------------------------------------
;;; Fixtures (synthetic — real project todo.org files are examples only)

(defconst tc-test--basic "\
* Demo Open Work
** TODO [#A] First open task
   first body
** DONE [#A] A finished task
   finished body
** TODO [#B] Another open task
* Demo Resolved
** DONE [#A] Previously archived
")

(defconst tc-test--mixed "\
* Proj Open Work
** TODO Keep me open
** DONE Done one
*** TODO leftover child of done one
** A structural heading with no state
** CANCELLED Cancelled two :quick:
** TODO Has a done child
*** DONE this nested done stays
** DONE Done three
* Proj Resolved
** DONE Old archived item
")

(defconst tc-test--nothing "\
* X Open Work
** TODO a
** WAITING b
** NEXT c
* X Resolved
** DONE old
")

(defconst tc-test--no-resolved "\
* Y Open Work
** DONE finished
** TODO ongoing
")

(defconst tc-test--no-open "\
* Z Resolved
** DONE old
* Some Other Section
** TODO whatever
")

(defconst tc-test--two-resolved "\
* P Open Work
** DONE done
* P Resolved
** DONE old1
* Q Resolved Notes
** DONE old2
")

;; No trailing newline — exercises the EOF / final-line case.  Open Work is the
;; last section, so a DONE level-2 here is also the last subtree in the file.
(defconst tc-test--eof "\
* W Resolved
** DONE pre-existing
* W Open Work
** TODO keep open
** DONE last thing
   body of last thing")

(defconst tc-test--lowercase "\
* winvm open work
** TODO test rebuilt vm
** DONE fix display resolution
* winvm resolved
** DONE fork linoffice as winvm
")

;;; ---------------------------------------------------------------------------
;;; Tests

(ert-deftest tc-archive-moves-one-done-level-2 ()
  (let* ((out (tc-test--archive tc-test--basic))
         (res (plist-get out :result))
         (open (tc-test--section res "Demo Open Work"))
         (resolved (tc-test--section res "Demo Resolved")))
    (should (= 1 (plist-get out :archived)))
    (should (tc-test--has resolved "A finished task"))
    (should (tc-test--has resolved "finished body"))
    (should-not (tc-test--has open "A finished task"))
    (should (tc-test--has open "First open task"))
    (should (tc-test--has open "Another open task"))
    ;; appended at the end of the Resolved section
    (should (tc-test--before-p resolved "Previously archived" "A finished task"))))

(ert-deftest tc-archive-moves-multiple-done-and-cancelled ()
  (let* ((out (tc-test--archive tc-test--mixed))
         (res (plist-get out :result))
         (open (tc-test--section res "Proj Open Work"))
         (resolved (tc-test--section res "Proj Resolved")))
    (should (= 3 (plist-get out :archived)))
    ;; stays in Open Work
    (should (tc-test--has open "Keep me open"))
    (should (tc-test--has open "A structural heading with no state"))
    (should (tc-test--has open "Has a done child"))
    (should (tc-test--has open "this nested done stays"))
    ;; moved to Resolved
    (should (tc-test--has resolved "Done one"))
    (should (tc-test--has resolved "Cancelled two"))
    (should (tc-test--has resolved "Done three"))
    ;; a level-2 DONE moves its (open) children along with it
    (should (tc-test--has resolved "leftover child of done one"))
    (should-not (tc-test--has open "leftover child of done one"))
    ;; gone from Open Work
    (should-not (tc-test--has open "Done one"))
    (should-not (tc-test--has open "Cancelled two"))
    (should-not (tc-test--has open "Done three"))
    ;; order: pre-existing first, then in document order
    (should (tc-test--before-p resolved "Old archived item" "Done one"))
    (should (tc-test--before-p resolved "Done one" "Cancelled two"))
    (should (tc-test--before-p resolved "Cancelled two" "Done three"))))

(ert-deftest tc-archive-structural-heading-does-not-move ()
  (let* ((out (tc-test--archive tc-test--mixed))
         (open (tc-test--section (plist-get out :result) "Proj Open Work")))
    (should (tc-test--has open "A structural heading with no state"))))

(ert-deftest tc-archive-nothing-to-do-is-noop ()
  (let ((out (tc-test--archive tc-test--nothing)))
    (should (= 0 (plist-get out :archived)))
    (should (equal tc-test--nothing (plist-get out :result)))))

(ert-deftest tc-archive-missing-resolved-section-skips ()
  (let ((out (tc-test--archive tc-test--no-resolved)))
    (should (= 0 (plist-get out :archived)))
    (should (equal tc-test--no-resolved (plist-get out :result)))
    (should (string-match-p "Resolved" (or (tc-test--skip-detail (plist-get out :issues)) "")))))

(ert-deftest tc-archive-missing-open-work-section-skips ()
  (let ((out (tc-test--archive tc-test--no-open)))
    (should (= 0 (plist-get out :archived)))
    (should (equal tc-test--no-open (plist-get out :result)))
    (should (string-match-p "Open Work" (or (tc-test--skip-detail (plist-get out :issues)) "")))))

(ert-deftest tc-archive-ambiguous-resolved-section-skips ()
  (let ((out (tc-test--archive tc-test--two-resolved)))
    (should (= 0 (plist-get out :archived)))
    (should (equal tc-test--two-resolved (plist-get out :result)))
    (should (string-match-p "Resolved" (or (tc-test--skip-detail (plist-get out :issues)) "")))))

(ert-deftest tc-archive-subtree-at-eof ()
  (let* ((out (tc-test--archive tc-test--eof))
         (res (plist-get out :result))
         (open (tc-test--section res "W Open Work"))
         (resolved (tc-test--section res "W Resolved")))
    (should (= 1 (plist-get out :archived)))
    (should (tc-test--has resolved "last thing"))
    (should (tc-test--has resolved "body of last thing"))
    (should (tc-test--has open "keep open"))
    (should-not (tc-test--has open "last thing"))
    ;; result stays well-formed: a newline separates the moved body from the
    ;; following section heading
    (should (string-match-p "body of last thing\n\\* W Open Work" res))))

(ert-deftest tc-archive-matches-lowercase-headings ()
  (let* ((out (tc-test--archive tc-test--lowercase))
         (res (plist-get out :result))
         (open (tc-test--section res "winvm open work"))
         (resolved (tc-test--section res "winvm resolved")))
    (should (= 1 (plist-get out :archived)))
    (should (tc-test--has resolved "fix display resolution"))
    (should-not (tc-test--has open "fix display resolution"))
    (should (tc-test--has open "test rebuilt vm"))))

(ert-deftest tc-archive-is-idempotent ()
  (dolist (fixture (list tc-test--basic tc-test--mixed tc-test--eof
                         tc-test--lowercase tc-test--nothing))
    (let ((once (plist-get (tc-test--archive fixture 1) :result))
          (twice (plist-get (tc-test--archive fixture 2) :result)))
      (should (equal once twice)))))

(ert-deftest tc-archive-check-mode-previews-without-writing ()
  (let ((out (tc-test--archive tc-test--basic 1 t)))
    (should (= 1 (plist-get out :archived)))
    (should (equal tc-test--basic (plist-get out :result)))
    (should (member "A finished task" (tc-test--moved-headings (plist-get out :issues))))))

(ert-deftest tc-archive-check-mode-is-idempotent ()
  (let ((once (tc-test--archive tc-test--mixed 1 t))
        (twice (tc-test--archive tc-test--mixed 2 t)))
    (should (equal tc-test--mixed (plist-get once :result)))
    (should (equal tc-test--mixed (plist-get twice :result)))
    (should (= 3 (plist-get once :archived)))
    (should (= 3 (plist-get twice :archived)))))

;;; ---------------------------------------------------------------------------
;;; Report suppression: a real-mode no-op stays silent so a double-run wrap
;;; (wrap-it-up then open-tasks.org Phase A) doesn't print an alarming
;;; "0 subtree(s) moved" next to the first run's diff.

(ert-deftest tc-archive-real-mode-zero-moves-is-silent ()
  (let ((out (tc-test--archive-report tc-test--nothing)))
    (should (= 0 (plist-get out :archived)))
    (should (equal "" (plist-get out :report)))))

(ert-deftest tc-archive-double-run-second-pass-is-silent ()
  ;; First run archives, second run finds nothing — the second prints nothing.
  (let ((out (tc-test--archive-report tc-test--basic 2)))
    (should (= 0 (plist-get out :archived)))
    (should (equal "" (plist-get out :report)))))

(ert-deftest tc-archive-check-mode-zero-moves-still-reports ()
  ;; A preview the caller explicitly asked for still says "0 would move".
  (let ((out (tc-test--archive-report tc-test--nothing nil t)))
    (should (= 0 (plist-get out :archived)))
    (should (tc-test--has (plist-get out :report) "0 subtree(s) would move"))))

(ert-deftest tc-archive-real-mode-moves-are-reported ()
  (let ((out (tc-test--archive-report tc-test--basic)))
    (should (= 1 (plist-get out :archived)))
    (should (tc-test--has (plist-get out :report) "1 subtree(s) moved"))))

(ert-deftest tc-archive-real-mode-skip-is-reported ()
  ;; 0 moved but a section is missing — the skip is a real condition and must
  ;; not be swallowed by the silence rule.
  (let ((out (tc-test--archive-report tc-test--no-resolved)))
    (should (= 0 (plist-get out :archived)))
    (should (tc-test--has (plist-get out :report) "skipped"))))

;;; ---------------------------------------------------------------------------
;;; Realistic synthetic sample (committed under fixtures/)

(defun tc-test--sample-file ()
  (expand-file-name "fixtures/todo-sample.org" tc-test--dir))

(ert-deftest tc-archive-realistic-sample ()
  (let* ((src (tc-test--sample-file)))
    (skip-unless (file-readable-p src))
    (let* ((content (with-temp-buffer (insert-file-contents src) (buffer-string)))
           (out (tc-test--archive content))
           (res (plist-get out :result))
           (out2 (tc-test--archive content 2)))
      ;; every DONE/CANCELLED level-2 entry under "Open Work" moved out
      (let ((open (tc-test--section res "Sample Open Work")))
        (should-not (string-match-p "^\\*\\* \\(DONE\\|CANCELLED\\) " open)))
      ;; structural and still-open level-2 entries stayed
      (let ((open (tc-test--section res "Sample Open Work")))
        (should (string-match-p "^\\*\\* TODO " open))
        (should (string-match-p "^\\*\\* DOING " open)))
      ;; idempotent
      (should (equal res (plist-get out2 :result)))
      ;; something actually moved
      (should (> (plist-get out :archived) 0)))))

;;; ---------------------------------------------------------------------------
;;; Sync-child-priority harness + fixtures

(defun tc-test--sync (content &optional runs check)
  "Write CONTENT to a temp .org file, run `--sync-child-priority' RUNS times
\(default 1\). Return a plist: :result final file contents, :bumped count from
the last run, :issues from the last run. CHECK non-nil ⇒ --check (preview)."
  (let ((file (make-temp-file "tc-test-sync-" nil ".org"))
        last-bumped last-issues)
    (unwind-protect
        (progn
          (with-temp-file file (insert content))
          (dotimes (_ (or runs 1))
            (tc-test--reset-sync check)
            (tc-process-file file)
            (setq last-bumped tc-bumped last-issues tc-issues)
            (tc-test--drop-buffer file))
          (list :result (with-temp-buffer (insert-file-contents file)
                                          (buffer-string))
                :bumped last-bumped
                :issues last-issues))
      (tc-test--drop-buffer file)
      (delete-file file))))

(defun tc-test--priority-of (content heading-substring)
  "Return the priority letter (a string like \"A\") on the first heading line
in CONTENT that contains HEADING-SUBSTRING, or nil if the heading has no
priority cookie."
  (with-temp-buffer
    (insert content)
    (goto-char (point-min))
    (let (found-line found-prio)
      (while (and (not found-line) (re-search-forward "^\\*+ .*$" nil t))
        (let ((line (match-string 0)))
          (when (string-match-p (regexp-quote heading-substring) line)
            (setq found-line line)
            (when (string-match "\\[#\\([A-Z]\\)\\]" line)
              (setq found-prio (match-string 1 line))))))
      (unless found-line
        (error "no heading containing %S" heading-substring))
      found-prio)))

(defun tc-test--sync-bumped-headings (issues)
  "Return the heading texts of every `:kind' sync-bumped or sync-would entry
in ISSUES, in document order."
  (mapcar (lambda (i) (plist-get i :child-heading))
          (cl-remove-if-not
           (lambda (i) (memq (plist-get i :kind) '(sync-bumped sync-would)))
           (reverse issues))))

(defconst tc-test--sync-basic "\
* Open Work
** TODO [#B] Parent
*** TODO [#D] Drifted child
*** TODO [#B] Already in sync
")

(defconst tc-test--sync-multi "\
* Open Work
** TODO [#B] Parent
*** TODO [#A] Higher-priority child stays
*** TODO [#B] Equal-priority child stays
*** TODO [#C] Lower-priority child bumps
*** TODO [#D] Way-lower-priority child bumps
*** TODO Priority-less child stays
")

(defconst tc-test--sync-no-sync-tag "\
* Open Work
** TODO [#B] Parent
*** TODO [#D] Regular drifted child
*** TODO [#D] Follow-up: opted-out :no-sync:
")

(defconst tc-test--sync-priority-less-parent "\
* Open Work
** TODO Parent with no priority
*** TODO [#D] Child with priority should not move
")

(defconst tc-test--sync-cascade "\
* Open Work
** TODO [#A] Top
*** TODO [#B] Middle
**** TODO [#D] Leaf
")

(defconst tc-test--sync-no-change "\
* Open Work
** TODO [#B] Parent
*** TODO [#A] Child higher
*** TODO [#B] Child equal
")

;; A dated-log heading inside a parent task whose title quotes other priorities
;; in =[#X]= verbatim. Those quoted cookies must NOT be read as the heading's
;; own priority — the cookie has to sit in canonical position to count.
(defconst tc-test--sync-cookie-in-title "\
* Open Work
** TODO [#B] Parent
*** 2026-05-14 Reprioritized children =[#D]= → =[#B]= to match parent
*** TODO [#D] Regular drifted child
")

;;; ---------------------------------------------------------------------------
;;; Sync-child-priority tests

(ert-deftest tc-sync-bumps-lower-priority-child ()
  (let* ((out (tc-test--sync tc-test--sync-basic))
         (res (plist-get out :result)))
    (should (= 1 (plist-get out :bumped)))
    (should (equal "B" (tc-test--priority-of res "Drifted child")))
    (should (equal "B" (tc-test--priority-of res "Already in sync")))
    (should (equal "B" (tc-test--priority-of res "Parent")))))

(ert-deftest tc-sync-leaves-higher-and-equal-children-alone ()
  (let* ((out (tc-test--sync tc-test--sync-multi))
         (res (plist-get out :result)))
    (should (= 2 (plist-get out :bumped)))
    (should (equal "A" (tc-test--priority-of res "Higher-priority child")))
    (should (equal "B" (tc-test--priority-of res "Equal-priority child")))
    (should (equal "B" (tc-test--priority-of res "Lower-priority child")))
    (should (equal "B" (tc-test--priority-of res "Way-lower-priority child")))
    (should-not (tc-test--priority-of res "Priority-less child"))))

(ert-deftest tc-sync-skips-no-sync-tagged-child ()
  (let* ((out (tc-test--sync tc-test--sync-no-sync-tag))
         (res (plist-get out :result)))
    (should (= 1 (plist-get out :bumped)))
    (should (equal "B" (tc-test--priority-of res "Regular drifted child")))
    (should (equal "D" (tc-test--priority-of res "Follow-up: opted-out")))))

(ert-deftest tc-sync-leaves-priority-less-parent-alone ()
  (let ((out (tc-test--sync tc-test--sync-priority-less-parent)))
    (should (= 0 (plist-get out :bumped)))
    (should (equal tc-test--sync-priority-less-parent (plist-get out :result)))))

(ert-deftest tc-sync-cascades-through-multiple-levels ()
  (let* ((out (tc-test--sync tc-test--sync-cascade))
         (res (plist-get out :result)))
    ;; one pass should collapse [#A] → [#B] → [#D] to all [#A] because
    ;; org-map-entries visits the parent first, bumps the middle, then visits
    ;; the (now bumped) middle and bumps its leaf
    (should (= 2 (plist-get out :bumped)))
    (should (equal "A" (tc-test--priority-of res "Top")))
    (should (equal "A" (tc-test--priority-of res "Middle")))
    (should (equal "A" (tc-test--priority-of res "Leaf")))))

(ert-deftest tc-sync-no-change-when-all-children-at-or-above-parent ()
  (let ((out (tc-test--sync tc-test--sync-no-change)))
    (should (= 0 (plist-get out :bumped)))
    (should (equal tc-test--sync-no-change (plist-get out :result)))))

(ert-deftest tc-sync-ignores-cookie-shaped-text-in-title ()
  (let* ((out (tc-test--sync tc-test--sync-cookie-in-title))
         (res (plist-get out :result)))
    ;; Only the real drifted child bumps; the dated-log heading with
    ;; =[#D]= / =[#B]= verbatim text in its title is untouched.
    (should (= 1 (plist-get out :bumped)))
    (should (equal "B" (tc-test--priority-of res "Regular drifted child")))
    ;; Substring still appears in the dated-log heading; the heading itself
    ;; was not rewritten.
    (should (string-match-p "Reprioritized children =\\[#D\\]= → =\\[#B\\]= to match parent" res))))

(ert-deftest tc-sync-is-idempotent ()
  (dolist (fixture (list tc-test--sync-basic
                         tc-test--sync-multi
                         tc-test--sync-no-sync-tag
                         tc-test--sync-priority-less-parent
                         tc-test--sync-cascade
                         tc-test--sync-no-change
                         tc-test--sync-cookie-in-title))
    (let ((once (plist-get (tc-test--sync fixture 1) :result))
          (twice (plist-get (tc-test--sync fixture 2) :result)))
      (should (equal once twice)))))

(ert-deftest tc-sync-check-mode-previews-without-writing ()
  (let ((out (tc-test--sync tc-test--sync-basic 1 t)))
    (should (= 1 (plist-get out :bumped)))
    (should (equal tc-test--sync-basic (plist-get out :result)))
    (should (member "Drifted child"
                    (tc-test--sync-bumped-headings (plist-get out :issues))))))

(ert-deftest tc-sync-check-mode-is-idempotent ()
  (let ((once (tc-test--sync tc-test--sync-cascade 1 t))
        (twice (tc-test--sync tc-test--sync-cascade 2 t)))
    (should (equal tc-test--sync-cascade (plist-get once :result)))
    (should (equal tc-test--sync-cascade (plist-get twice :result)))
    (should (= 2 (plist-get once :bumped)))
    (should (= 2 (plist-get twice :bumped)))))

(provide 'test-todo-cleanup)
;;; test-todo-cleanup.el ends here