path: root/.ai/scripts/lint-org.el

;;; lint-org.el --- org-lint sweeper for tracked org files  -*- lexical-binding: t; -*-
;;
;; Usage:
;;   emacs --batch -q -l lint-org.el FILE.org [FILE.org ...]
;;     apply mechanical fixes in place, emit judgment items on stdout for the
;;     command layer to walk
;;
;;   emacs --batch -q -l lint-org.el --check FILE.org [FILE.org ...]
;;     report only — categorize without modifying the file
;;
;;   emacs --batch -q -l lint-org.el --followups-file=PATH FILE.org
;;     apply mechanical fixes; if any judgment items remain, append them to
;;     PATH as an org section dated today.  Used by wrap-it-up to defer the
;;     judgment walk to the next morning's review without blocking the wrap.
;;
;; Mechanical categories (auto-fixed):
;;   item-number                       add [@N] directive to drifted bullets
;;   missing-language-in-src-block     convert bare #+begin_src to #+begin_example
;;   misplaced-planning-info           merge multi-line CLOSED:/DEADLINE:/SCHEDULED:
;;   misplaced-heading (markdown-bold) **X.** at start of line → *X.*
;;
;; Suppressed (false positives — neither fixed nor surfaced):
;;   misplaced-heading (verbatim-*)    =*** Foo= inside body prose — verbatim
;;                                     asterisks are never a real misplaced
;;                                     heading, so the item is dropped silently
;;   cj-comment src-block false flags  see `lo--cj-comment-block-opener-p'
;;
;; Judgment categories (emitted on stdout):
;;   link-to-local-file                broken file: links
;;   invalid-fuzzy-link                broken *Heading refs
;;   suspicious-language-in-src-block  unknown source-block language
;;   (anything else)                   surfaced as judgment with checker name
;;
;; Output format on stdout:
;;   first line:  ;; lint-org: file=<path> mechanical=<N>[ (would-fix)] judgment=<M>
;;   each issue:  (:kind mechanical-fixed|judgment :line <N> :checker <symbol> :msg "..." [:preview t])
;;
;; Before modifying a file, a backup is copied to
;;   /tmp/<basename>.before-lint-pass.<YYYYMMDD-HHMMSS>

(require 'org)
(require 'org-lint)
(require 'cl-lib)
(require 'subr-x)

(defvar lo-fixes 0
  "Count of mechanical fixes applied (or would-apply in --check) on the last file.")
(defvar lo-issues nil
  "Reverse-document-order list of plists describing each issue from the last file.
Each plist has :kind (mechanical-fixed | judgment), :line, :checker, :msg.
Mechanical entries from --check mode also carry :preview t.")
(defvar lo-check-only nil
  "Non-nil means run in report-only mode — no buffer writes.")
(defvar lo-current-file nil
  "Path of the file currently being processed.")
(defvar lo-followups-file nil
  "When non-nil, after a non-check run any judgment items are appended to this
path as an org section dated today.  The file is created if missing.")

(defconst lo-mechanical-checkers
  '(item-number missing-language-in-src-block misplaced-planning-info)
  "org-lint checker names that are always treated as mechanical.")

;; misplaced-heading is split case-by-case in `lo--handle-item': markdown-bold
;; is auto-fixed, verbatim-asterisk is suppressed as a false positive, anything
;; else is surfaced as judgment.

;;; ---------------------------------------------------------------------------
;;; org-lint result accessors

(defun lo--checker-name (item)
  "Return the checker symbol name for ITEM."
  (let* ((vec (cadr item))
         (checker (aref vec 3)))
    (org-lint-checker-name checker)))

(defun lo--line (item)
  "Return the 1-based line number for ITEM."
  (let* ((vec (cadr item))
         (marker-str (aref vec 0)))
    (string-to-number (substring-no-properties marker-str))))

(defun lo--message (item)
  "Return the human-readable message for ITEM."
  (let ((vec (cadr item))) (aref vec 2)))

;;; ---------------------------------------------------------------------------
;;; Mechanical fixers — each runs against the current buffer, returns
;;; non-nil on success, nil if its preconditions don't hold (already
;;; fixed, unexpected shape, etc.).

(defun lo--goto-line (line)
  (goto-char (point-min))
  (forward-line (1- line)))

(defun lo-fix-item-number (line)
  "Insert an [@N] counter on the bullet at LINE, derived from its leading number."
  (save-excursion
    (lo--goto-line line)
    (when (looking-at "^[ \t]*\\([0-9]+\\)[.)]\\([ \t]+\\)")
      (let ((num (match-string 1)))
        (goto-char (match-end 0))
        (unless (looking-at "\\[@")
          (insert (format "[@%s] " num))
          t)))))

(defun lo-fix-missing-language (line)
  "Convert a bare `#+begin_src` block starting at LINE to `#+begin_example`.
Locates the matching `#+end_src` directly below and rewrites it too."
  (save-excursion
    (lo--goto-line line)
    (when (looking-at "^\\([ \t]*\\)#\\+begin_src[ \t]*$")
      (let* ((indent (match-string 1))
             (begin-bol (line-beginning-position))
             (begin-eol (line-end-position))
             ;; case-fold the end keyword search to match org's tolerance
             (end-re (format "^%s#\\+end_src[ \t]*$" (regexp-quote indent))))
        (delete-region begin-bol begin-eol)
        (insert (format "%s#+begin_example" indent))
        (forward-line 1)
        (when (re-search-forward end-re nil t)
          (replace-match (format "%s#+end_example" indent) t t)
          t)))))

(defun lo-fix-misplaced-planning (line)
  "Collapse all planning lines under the heading containing LINE into a single
canonical line right after the heading, ordered CLOSED → DEADLINE → SCHEDULED.
LINE positions the search start — the fixer then rebuilds the whole entry's
planning block at once, so it does the right thing whether the misplaced line
is the first, last, or middle of the run."
  (save-excursion
    (lo--goto-line line)
    (when (re-search-backward "^\\*+ " nil t)
      (let* ((heading-bol (line-beginning-position))
             (body-start (progn (forward-line 1) (point)))
             (entry-end (save-excursion (outline-next-heading) (point)))
             (parts nil)
             (ranges nil))
        (goto-char body-start)
        (while (re-search-forward
                "^[ \t]*\\(CLOSED\\|DEADLINE\\|SCHEDULED\\):.*$"
                entry-end t)
          (let* ((line-bol (match-beginning 0))
                 (line-eol (match-end 0))
                 (content (buffer-substring-no-properties line-bol line-eol))
                 (pos 0))
            (while (string-match
                    "\\(CLOSED\\|DEADLINE\\|SCHEDULED\\):[ \t]*\\(\\[[^]]+\\]\\|<[^>]+>\\)"
                    content pos)
              (push (cons (match-string 1 content)
                          (match-string 2 content))
                    parts)
              (setq pos (match-end 0)))
            ;; Record line-bol .. line-eol+1 so the trailing newline goes too.
            (push (cons line-bol (min (1+ line-eol) (point-max))) ranges)))
        (when (> (length parts) 1)
          (let* ((order '("CLOSED" "DEADLINE" "SCHEDULED"))
                 (deduped (cl-remove-duplicates (nreverse parts) :test #'equal))
                 (sorted (sort deduped
                               (lambda (a b)
                                 (< (or (cl-position (car a) order :test #'string=) 99)
                                    (or (cl-position (car b) order :test #'string=) 99)))))
                 (merged (mapconcat (lambda (p) (format "%s: %s" (car p) (cdr p)))
                                    sorted " ")))
            (dolist (r (sort (copy-sequence ranges)
                             (lambda (a b) (> (car a) (car b)))))
              (delete-region (car r) (cdr r)))
            (goto-char heading-bol)
            (forward-line 1)
            (insert merged "\n")
            t))))))

(defun lo--find-markdown-bold-line (reported-line)
  "Return the actual line number containing a leading `**X**` near REPORTED-LINE.
org-lint's marker for misplaced-heading typically points at the blank line
following the offender, so check (REPORTED-LINE - 1) before REPORTED-LINE.
Returns nil if no nearby line matches the markdown-bold pattern."
  (save-excursion
    (cl-loop for candidate in (list (1- reported-line) reported-line)
             when (and (>= candidate 1)
                       (progn (lo--goto-line candidate)
                              (looking-at "^\\*\\*[^*\n]+\\*\\*")))
             return candidate)))

(defun lo--markdown-bold-at-line-p (line)
  "Non-nil if LINE (or LINE - 1) looks like a markdown-bold case of
misplaced-heading.  Pattern: `**X**` at the start of the line, X a short prose
run without asterisks."
  (and (lo--find-markdown-bold-line line) t))

(defun lo--verbatim-asterisk-at-line-p (line)
  "Non-nil if LINE (or LINE - 1) carries an =...=-wrapped run of heading
asterisks inside body prose, e.g. =** DONE= or =*** Foo=.  org-lint reads the
verbatim asterisks as a possible heading and flags the line, but verbatim
markup is never a real misplaced heading.  Like `lo--find-markdown-bold-line',
this checks LINE - 1 too, since org-lint often marks the blank line after the
offender.  The match is anywhere on the line (the span sits mid-sentence)."
  (save-excursion
    (cl-loop for candidate in (list (1- line) line)
             when (and (>= candidate 1)
                       (progn (lo--goto-line candidate)
                              (re-search-forward "=\\*+ [^=\n]*="
                                                 (line-end-position) t)))
             return candidate)))

(defun lo-fix-markdown-bold (line)
  "Convert a leading `**X**` near LINE to `*X*` (org single-asterisk bold).
Uses `lo--find-markdown-bold-line' to locate the actual offender, since
org-lint reports the blank line after the heading-like text."
  (let ((actual (lo--find-markdown-bold-line line)))
    (when actual
      (save-excursion
        (lo--goto-line actual)
        (when (looking-at "^\\(\\*\\*\\)\\([^*\n]+\\)\\(\\*\\*\\)")
          (let ((start (match-beginning 0))
                (end (match-end 0))
                (inner (match-string 2)))
            (delete-region start end)
            (goto-char start)
            (insert (format "*%s*" inner))
            t))))))

;;; ---------------------------------------------------------------------------
;;; Per-item dispatch

(defun lo--emit-judgment (name line msg)
  (push (list :kind 'judgment :line line :checker name :msg msg)
        lo-issues))

(defun lo--apply-or-preview (name line msg fixer)
  (cond
   (lo-check-only
    (cl-incf lo-fixes)
    (push (list :kind 'mechanical-fixed :line line :checker name :msg msg
                :preview t)
          lo-issues))
   ((funcall fixer line)
    (cl-incf lo-fixes)
    (push (list :kind 'mechanical-fixed :line line :checker name :msg msg)
          lo-issues))
   (t
    ;; Fixer declined — emit as judgment so nothing is silently swallowed.
    (lo--emit-judgment name line msg))))

(defun lo--cj-comment-block-opener-p (line)
  "Non-nil when LINE in the current buffer is a `#+begin_src cj: ...' opener.
The cj-comment annotation convention puts `cj:' as the src-block language and
`comment' as the apparent header arg.  org-lint reads that shape three ways
(unknown language, empty header-arg value, missing colon in header arg) and
flags each — all three are false positives, since cj-comment is a
Craig-specific annotation marker rather than Babel src-block syntax."
  (save-excursion
    (lo--goto-line line)
    (looking-at-p "^[ \t]*#\\+begin_src[ \t]+cj:")))

(defun lo--handle-item (item)
  (let ((name (lo--checker-name item))
        (line (lo--line item))
        (msg (lo--message item)))
    (cond
     ;; Silent suppression of cj-comment false positives — see
     ;; `lo--cj-comment-block-opener-p'.  No fix counted, no judgment emitted.
     ((and (memq name '(suspicious-language-in-src-block
                        empty-header-argument
                        wrong-header-argument))
           (lo--cj-comment-block-opener-p line))
      nil)
     ((eq name 'item-number)
      (lo--apply-or-preview name line msg #'lo-fix-item-number))
     ((eq name 'missing-language-in-src-block)
      (lo--apply-or-preview name line msg #'lo-fix-missing-language))
     ((eq name 'misplaced-planning-info)
      (lo--apply-or-preview name line msg #'lo-fix-misplaced-planning))
     ((eq name 'misplaced-heading)
      (cond
       ((lo--markdown-bold-at-line-p line)
        (lo--apply-or-preview name line msg #'lo-fix-markdown-bold))
       ;; Verbatim =** Foo= inside prose is never a real misplaced heading;
       ;; suppress silently like the cj-comment case — no fix, no judgment.
       ((lo--verbatim-asterisk-at-line-p line)
        nil)
       (t
        (lo--emit-judgment name line msg))))
     (t
      (lo--emit-judgment name line msg)))))

;;; ---------------------------------------------------------------------------
;;; File processing

(defun lo--backup (file)
  "Copy FILE to /tmp before any modification.  Skipped in --check mode."
  (let ((backup (format "/tmp/%s.before-lint-pass.%s"
                        (file-name-nondirectory file)
                        (format-time-string "%Y%m%d-%H%M%S"))))
    (copy-file file backup t)
    backup))

(defun lo-process-file (file)
  "Run org-lint against FILE, apply mechanical fixes, collect judgment items.
Resets `lo-fixes' and `lo-issues' for each call.  In --check mode the file is
left unmodified and mechanical entries are recorded with :preview t."
  (setq lo-current-file file lo-fixes 0 lo-issues nil)
  (unless lo-check-only
    (lo--backup file))
  (let ((buf (find-file-noselect file)))
    (unwind-protect
        (with-current-buffer buf
          (revert-buffer t t t)
          (let* ((report (org-lint))
                 ;; Descending line order: applying a fix that adds/removes
                 ;; lines doesn't perturb the line numbers of items at smaller
                 ;; line numbers that haven't been processed yet.
                 (sorted (sort (copy-sequence report)
                               (lambda (a b) (> (lo--line a) (lo--line b))))))
            (dolist (item sorted)
              (lo--handle-item item)))
          (when (and (not lo-check-only) (buffer-modified-p))
            (save-buffer)))
      (with-current-buffer buf (set-buffer-modified-p nil))
      (kill-buffer buf))))

;;; ---------------------------------------------------------------------------
;;; Reporting

(defun lo--followups-section (file judgments)
  "Org section text for FILE's JUDGMENTS, keyed by checker + message.
Empty string when there are no judgments.  The line number is a trailing
annotation, not the entry's identity, so a finding that shifts lines after an
edit is still recognized as the same finding."
  (if (null judgments)
      ""
    (concat
     (format "* lint-org follow-ups — %s (%s)\n"
             (file-name-nondirectory file)
             (format-time-string "%Y-%m-%d"))
     (mapconcat
      (lambda (i)
        (format "** TODO %s — %s (line %d)\n"
                (plist-get i :checker)
                (plist-get i :msg)
                (plist-get i :line)))
      judgments
      ""))))

(defun lo--strip-followups-section (content file)
  "Return CONTENT with FILE's existing follow-ups section(s) removed.
A section runs from its `* lint-org follow-ups — FILE ...' header to the next
top-level `* ' heading or end of buffer.  Matched on the file name, so it
survives line-number churn in the target file, and tolerates the older
`* DATE lint-org follow-ups — FILE' header shape so legacy runs migrate cleanly."
  (with-temp-buffer
    (insert content)
    (let ((header-re
           (format "^\\* \\(?:[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} \\)?lint-org follow-ups — %s "
                   (regexp-quote (file-name-nondirectory file)))))
      (while (progn (goto-char (point-min))
                    (re-search-forward header-re nil t))
        (let ((start (line-beginning-position))
              (end (if (re-search-forward "^\\* " nil t)
                       (line-beginning-position)
                     (point-max))))
          (delete-region start end))))
    (buffer-string)))

(defun lo--reconciled-followups (existing file judgments)
  "Reconcile EXISTING follow-ups content for FILE against the current JUDGMENTS.
FILE's prior section is replaced by the current findings (dropped entirely when
nothing reproduces); other files' sections are left intact.  This is what makes
re-runs dedupe and resolved findings disappear instead of piling up."
  (let ((stripped (string-trim (lo--strip-followups-section existing file)))
        (section (string-trim (lo--followups-section file judgments))))
    (cond
     ((and (string= stripped "") (string= section "")) "")
     ((string= section "") (concat stripped "\n"))
     ((string= stripped "") (concat section "\n"))
     (t (concat stripped "\n\n" section "\n")))))

(defun lo--append-followups ()
  "Reconcile the current run's judgment items into `lo-followups-file'.
Rewrites FILE's section from the current findings: entries are keyed by content
(checker + message) rather than line number, findings that no longer reproduce
are dropped, and re-runs dedupe instead of appending a fresh dated section.
No-op when the file path is unset, or when there are no judgments and no file to
reconcile."
  (when lo-followups-file
    (let ((judgments (cl-remove-if-not
                      (lambda (i) (eq (plist-get i :kind) 'judgment))
                      (reverse lo-issues))))
      (when (or judgments (file-exists-p lo-followups-file))
        (let ((existing (if (file-exists-p lo-followups-file)
                            (with-temp-buffer
                              (insert-file-contents lo-followups-file)
                              (buffer-string))
                          ""))
              (dir (file-name-directory (expand-file-name lo-followups-file))))
          (when dir (make-directory dir t))
          (with-temp-file lo-followups-file
            (insert (lo--reconciled-followups existing lo-current-file judgments))))))))

(defun lo-emit-report ()
  "Print the per-file summary line plus each issue as a readable plist.
After printing, also append judgments to `lo-followups-file' when set."
  (let ((mech (cl-count-if (lambda (i) (eq (plist-get i :kind) 'mechanical-fixed))
                           lo-issues))
        (judg (cl-count-if (lambda (i) (eq (plist-get i :kind) 'judgment))
                           lo-issues)))
    (princ (format ";; lint-org: file=%s mechanical=%d%s judgment=%d%s\n"
                   lo-current-file mech
                   (if lo-check-only " (would-fix)" "")
                   judg
                   (if (and lo-followups-file (> judg 0))
                       (format " followups=%s" lo-followups-file)
                     "")))
    (dolist (i (reverse lo-issues))
      (princ (format "%S\n" i)))
    (unless lo-check-only
      (lo--append-followups))))

;;; ---------------------------------------------------------------------------
;;; CLI

(defun lo-main ()
  (when (member "--check" command-line-args-left)
    (setq lo-check-only t)
    (setq command-line-args-left (delete "--check" command-line-args-left)))
  (let ((followups (cl-find-if
                    (lambda (a) (string-prefix-p "--followups-file=" a))
                    command-line-args-left)))
    (when followups
      (setq lo-followups-file (substring followups (length "--followups-file=")))
      (setq command-line-args-left (delete followups command-line-args-left))))
  (if (null command-line-args-left)
      (progn
        (princ "Usage: emacs --batch -q -l lint-org.el [--check] [--followups-file=PATH] FILE.org ...\n")
        (kill-emacs 1))
    (let ((files command-line-args-left))
      (setq command-line-args-left nil)
      (dolist (file files)
        (if (file-readable-p file)
            (progn
              (lo-process-file file)
              (lo-emit-report))
          (princ (format ";; lint-org: file=%s not readable — skipping\n"
                         file)))))))

(defun lo--cli-invocation-p ()
  "Non-nil when the trailing command-line arguments look like a real invocation:
only recognized flags and/or readable file paths.  Lets the ERT suite `require'
this file without firing the CLI dispatch — under `ert-run-tests-batch-and-exit'
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")) t)
                         ((string-prefix-p "--followups-file=" a) t)
                         ((string-prefix-p "-" a) nil)
                         (t (file-readable-p a))))
                 command-line-args-left)))

(when (and noninteractive (lo--cli-invocation-p))
  (lo-main))

(provide 'lint-org)
;;; lint-org.el ends here