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-issues nil
        tc-check-only (and check t) tc-archive-done 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--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)))))

;;; ---------------------------------------------------------------------------
;;; 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)))))

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