;;; ste-lint.el --- Lint Org prose against ASD-STE100 -*- lexical-binding: t; -*-

;; Copyright (C) 2026

;; This file is NOT part of GNU Emacs.

;;; Commentary:

;; This file finds Simplified Technical English (ASD-STE100) smells in the
;; prose of Org files.  It has two entry points:
;;
;; - `ste-lint-batch' lints files from the command line:
;;
;;     emacs -Q --batch -l ste-lint.el -f ste-lint-batch FILE-OR-DIR...
;;
;;   Each finding goes to standard error as one line in the GNU format
;;   "FILE:LINE:COLUMN: SEVERITY [CATEGORY] MATCH -- SUGGESTION".  The exit
;;   status is 1 when there is at least one ERROR finding, and 0 otherwise.
;;   With no argument, the command lints every Org file below the current
;;   directory.
;;
;; - `ste-lint-flymake-setup' adds a Flymake backend to an Org buffer.
;;   Findings then show in the buffer while you type.  Agents can read them
;;   with the `get-diagnostics' MCP tool.
;;
;; The Org parser decides what is prose.  The linter checks headline titles
;; and paragraphs.  It does not check drawers, property drawers, planning
;; lines, keywords, tables, source blocks, example blocks, quote blocks, verse
;; blocks, or dynamic blocks.  Inside the prose, the linter masks inline code,
;; verbatim text, timestamps, link targets, and similar markup.  It keeps the
;; text positions, so that each finding points to its exact place.
;;
;; The rule tables below hold every rule.  Each rule traces to ASD-STE100.
;; They are a port of the rule tables of the ste-lint.pl script in the
;; EUSCDanubeWikiCDK package.
;;
;; Severity:
;;   ERROR -- an unambiguous STE100 violation.  It fails the batch run.
;;   WARN  -- a judgment call with more false positives.  It does not fail.

;;; Code:

(require 'cl-lib)
(require 'flymake)
(require 'org)
(require 'org-element)

(defgroup ste-lint nil
  "Lint Org prose against ASD-STE100."
  :group 'org)

(defcustom ste-lint-max-words-description 25
  "Maximum number of words in a descriptive sentence."
  :type 'integer)

(defcustom ste-lint-max-words-procedure 20
  "Maximum number of words in a sentence of a procedure step.
The linter treats each item of an ordered list as a procedure step."
  :type 'integer)

;;;; Rule tables

(defconst ste-lint-pattern-rules
  (list
   (list :category "contraction"
         :severity 'error
         ;; An apostrophe followed by "s" is not a rule: it is almost always
         ;; a possessive.
         :regexp (rx word-boundary
                     (group-n 1 (+ word)
                              (or (seq "n" (any "'’") "t")
                                  (seq (any "'’") (or "ll" "re" "ve" "d" "m"))))
                     word-boundary)
         :suggestion "Write the full form, for example \"do not\".")
   (list :category "latin-abbreviation"
         :severity 'error
         :regexp (rx word-boundary
                     (group-n 1 (or "e.g." "i.e." "etc." "vs." "viz."
                                    (seq "et" (+ blank) "al.") "cf." "n.b.")))
         :suggestion (concat "Write plain English, for example \"for example\""
                             " or \"that is\", or list the items."))
   (list :category "semicolon"
         :severity 'error
         :skip (rx word-boundary "TL;DR" word-boundary)
         :regexp (rx (group-n 1 ";"))
         :suggestion "Write two sentences.")
   (list :category "ampersand"
         :severity 'warn
         ;; Only an ampersand with white space on each side is the word "and".
         :regexp (rx blank (group-n 1 "&") blank)
         :suggestion "Write \"and\".")
   (list :category "slash-conjunction"
         :severity 'warn
         :regexp (rx word-boundary
                     (group-n 1 (or "and/or" "he/she" "his/her" "him/her"
                                    "she/he" "either/or"))
                     word-boundary)
         :suggestion "Name one term, or write \"x or y\".")
   (list :category "instruction-mood"
         :severity 'warn
         :regexp (rx word-boundary
                     (group-n 1 "you" (+ blank)
                              (or "should" "must" "can" "may" "will"
                                  (seq "need" (+ blank) "to")
                                  (seq "have" (+ blank) "to")))
                     word-boundary)
         :suggestion "Use the imperative, for example \"Run the script\".")
   (list :category "nominalization"
         :severity 'warn
         :regexp (rx word-boundary
                     (group-n 1
                       (or "do" "perform" (seq "carry" (+ blank) "out")
                           "conduct" "make" "provide")
                       (+ blank)
                       (? (or "a" "an" "the") (+ blank))
                       (+ word)
                       (or "tion" "ment" "ance" "ence" "al" "ing")
                       word-boundary
                       (? (+ blank) "of")))
         :suggestion "Use the verb, for example \"deploy\"."))
  "Rules that a regular expression triggers.
Each rule is a plist.  `:regexp' is the trigger, and its group 1 is the
reported match.  `:skip' is an optional regular expression for idioms that
the rule must ignore.")

(defconst ste-lint-substitution-rules
  '(("wordy-phrase" warn
     ("utilize" . "use") ("utilizes" . "uses") ("utilized" . "used")
     ("utilizing" . "using") ("in order to" . "to")
     ("it is necessary to" . "you must") ("prior to" . "before")
     ("subsequent to" . "after") ("terminate" . "stop")
     ("terminates" . "stops") ("terminated" . "stopped")
     ("initiate" . "start") ("initiates" . "starts")
     ("initiated" . "started") ("execute" . "do or run")
     ("executes" . "does or runs") ("executed" . "done or run")
     ("a number of" . "several") ("a large number of" . "many")
     ("the majority of" . "most") ("in the event that" . "if")
     ("due to the fact that" . "because")
     ("in the process of" . "(drop it, or name the step)")
     ("at this point in time" . "now") ("with regard to" . "about")
     ("in terms of" . "for or about") ("in the case of" . "for")
     ("is able to" . "can") ("are able to" . "can"))
    ("phrasal-verb" warn
     ("carry out" . "do or run") ("carries out" . "does or runs")
     ("carried out" . "did or ran") ("put out" . "extinguish")
     ("give off" . "release") ("gives off" . "releases")
     ("gave off" . "released")
     ("set up" . "configure or install (as a verb)")
     ("shut down" . "stop") ("turn off" . "disable")
     ("turn on" . "enable") ("spin up" . "start or launch")
     ("kick off" . "start") ("roll out" . "deploy or release")
     ("back up" . "save a copy of (as a verb)"))
    ("weak-wording" warn
     ("make sure" . "confirm that") ("a lot of" . "many or much")
     ("lots of" . "many or much")
     ("and so on" . "(list the items, or omit)") ("as well as" . "and"))
    ("gendered-language" warn
     ("he" . "they, or name the role") ("she" . "they, or name the role")
     ("his" . "their, or name the role")
     ("hers" . "theirs, or name the role")
     ("him" . "them, or name the role") ("manpower" . "staff or effort")
     ("man-hours" . "person-hours")))
  "Words and phrases with a preferred replacement.
Each entry is (CATEGORY SEVERITY (PHRASE . REPLACEMENT)...).  A phrase
matches on word boundaries and without regard to case.  The words of a
phrase can have any white space between them, which includes a line break.")

(defconst ste-lint-excluded-ancestors
  '(drawer property-drawer quote-block verse-block dynamic-block)
  "Element types whose paragraphs the linter does not check.
Drawers hold logbook history.  Quote and verse blocks hold quoted text.
Dynamic blocks hold generated text.")

(defconst ste-lint--word-like-objects
  '(code verbatim inline-src-block inline-babel-call timestamp entity
         latex-fragment macro export-snippet)
  "Object types that the linter replaces with one word.")

(defconst ste-lint--noise-objects
  '(statistics-cookie footnote-reference line-break target radio-target)
  "Object types that the linter replaces with white space.")

(defconst ste-lint--syntax-table
  (let ((table (make-syntax-table text-mode-syntax-table)))
    (modify-syntax-entry ?' "." table)
    (modify-syntax-entry ?’ "." table)
    table)
  "Syntax table for the rule matches.
An apostrophe is punctuation, so that the rules see the parts of a
contraction as separate words.")

;;;; Findings

(cl-defstruct (ste-lint-finding (:constructor ste-lint--make-finding)
                                (:copier nil))
  "One STE smell in a buffer."
  beg end severity category match suggestion)

(defun ste-lint--squeeze (string)
  "Return STRING with each run of white space changed to one space."
  (string-trim (replace-regexp-in-string "[[:space:]]+" " " string)))

;;;; Prose extraction

(defun ste-lint--fill (text from to char base)
  "Fill TEXT from buffer position FROM to TO with CHAR.
BASE is the buffer position of the first character of TEXT."
  (let ((start (max 0 (- from base)))
        (end (min (length text) (- to base))))
    (cl-loop for index from start below end
             do (aset text index char))))

(defun ste-lint--object-end (object)
  "Return the end of OBJECT, without its trailing white space."
  (- (org-element-property :end object)
     (or (org-element-property :post-blank object) 0)))

(defun ste-lint--masked-text (data beg end)
  "Return the prose of the buffer from BEG to END, masked.
DATA is the Org element or the secondary string that holds the prose.
The result has the same length as the buffer text.  Inline code and
similar markup become a run of the letter x, which counts as one word.
Link targets become white space.  Line breaks become spaces."
  (let ((text (buffer-substring-no-properties beg end)))
    (org-element-map data
        (append '(link) ste-lint--word-like-objects ste-lint--noise-objects)
      (lambda (object)
        (let ((type (org-element-type object))
              (object-beg (org-element-property :begin object))
              (object-end (ste-lint--object-end object))
              (contents-beg (org-element-property :contents-begin object))
              (contents-end (org-element-property :contents-end object)))
          (cond
           ((and (eq type 'link) contents-beg)
            (ste-lint--fill text object-beg contents-beg ?\s beg)
            (ste-lint--fill text contents-end object-end ?\s beg))
           ((or (eq type 'link) (memq type ste-lint--word-like-objects))
            (ste-lint--fill text object-beg object-end ?x beg))
           (t
            (ste-lint--fill text object-beg object-end ?\s beg))))))
    (subst-char-in-string ?\n ?\s text t)))

(defun ste-lint--title-region (headline)
  "Return the region of the title of HEADLINE as (BEG . END), or nil.
The region excludes the stars, the keyword, the priority, and the tags."
  (save-excursion
    (goto-char (org-element-property :begin headline))
    (let ((case-fold-search nil))
      (when (and (looking-at org-complex-heading-regexp)
                 (match-beginning 4))
        (cons (match-beginning 4) (match-end 4))))))

(defun ste-lint--procedure-p (paragraph)
  "Return non-nil if PARAGRAPH is in an item of an ordered list."
  (let ((item (org-element-lineage paragraph '(item))))
    (and item
         (eq (org-element-property
              :type (org-element-property :parent item))
             'ordered))))

;;;; Rule engine

(defun ste-lint--blank-matches (regexp text)
  "Return a copy of TEXT with each match of REGEXP filled with spaces."
  (replace-regexp-in-string
   regexp (lambda (match) (make-string (length match) ?\s)) text t t))

(defun ste-lint--phrase-regexp (phrase)
  "Return a regular expression for PHRASE on word boundaries.
Any white space can separate the words of PHRASE."
  (concat "\\b\\("
          (mapconcat #'regexp-quote (split-string phrase " ") "[[:space:]]+")
          "\\)\\b"))

(defun ste-lint--collect (regexp text offset severity category suggestion)
  "Return a finding for each match of group 1 of REGEXP in TEXT.
OFFSET is the buffer position of the first character of TEXT.  SEVERITY,
CATEGORY, and SUGGESTION go into each finding."
  (let ((start 0)
        findings)
    (while (string-match regexp text start)
      (push (ste-lint--make-finding
             :beg (+ offset (match-beginning 1))
             :end (+ offset (match-end 1))
             :severity severity
             :category category
             :match (ste-lint--squeeze (match-string 1 text))
             :suggestion suggestion)
            findings)
      (setq start (max (match-end 0) (1+ (match-beginning 0)))))
    (nreverse findings)))

(defun ste-lint--apply-pattern-rules (text offset)
  "Return the findings of `ste-lint-pattern-rules' in TEXT at OFFSET."
  (cl-loop
   for rule in ste-lint-pattern-rules
   for skip = (plist-get rule :skip)
   nconc (ste-lint--collect
          (plist-get rule :regexp)
          (if skip (ste-lint--blank-matches skip text) text)
          offset
          (plist-get rule :severity)
          (plist-get rule :category)
          (plist-get rule :suggestion))))

(defun ste-lint--apply-substitution-rules (text offset)
  "Return the findings of `ste-lint-substitution-rules' in TEXT at OFFSET."
  (cl-loop
   for (category severity . phrases) in ste-lint-substitution-rules
   nconc (cl-loop
          for (phrase . replacement) in phrases
          nconc (ste-lint--collect
                 (ste-lint--phrase-regexp phrase) text offset severity
                 category (format "Consider \"%s\" instead." replacement)))))

(defun ste-lint--check-sentences (text offset max-words)
  "Return a finding for each sentence of TEXT with more than MAX-WORDS words.
OFFSET is the buffer position of the first character of TEXT."
  (let ((start 0)
        (length (length text))
        findings)
    (while (and (< start length)
                (string-match "[^[:space:]]" text start))
      (let* ((sentence-beg (match-beginning 0))
             (sentence-end (if (string-match
                                "[.!?]+\\(?:[[:space:]]\\|\\'\\)"
                                text sentence-beg)
                               (match-end 0)
                             length))
             (words (cl-count-if
                     (lambda (word) (string-match-p "[[:word:]]" word))
                     (split-string
                      (substring text sentence-beg sentence-end)
                      "[[:space:]]+" t))))
        (when (> words max-words)
          (push (ste-lint--make-finding
                 :beg (+ offset sentence-beg)
                 :end (+ offset
                         (length (string-trim-right
                                  (substring text 0 sentence-end))))
                 :severity 'warn
                 :category "sentence-length"
                 :match (format "%d words" words)
                 :suggestion (format "Split the sentence (maximum %d words)."
                                     max-words))
                findings))
        (setq start sentence-end)))
    (nreverse findings)))

(defun ste-lint--check-unit (data beg end max-words)
  "Return the findings for the prose of DATA from BEG to END.
If MAX-WORDS is non-nil, also check the length of each sentence."
  (let ((text (ste-lint--masked-text data beg end))
        (case-fold-search t))
    (with-syntax-table ste-lint--syntax-table
      (append (ste-lint--apply-pattern-rules text beg)
              (ste-lint--apply-substitution-rules text beg)
              (and max-words
                   (ste-lint--check-sentences text beg max-words))))))

;;;; Buffer and file entry points

(defun ste-lint-buffer ()
  "Return the STE findings for the Org prose of the current buffer.
The findings are sorted by position."
  (let (findings)
    (org-element-map (org-element-parse-buffer) '(headline paragraph)
      (lambda (element)
        (pcase (org-element-type element)
          ('headline
           (let ((region (ste-lint--title-region element)))
             (when region
               (push (ste-lint--check-unit
                      (org-element-property :title element)
                      (car region) (cdr region) nil)
                     findings))))
          ('paragraph
           (unless (org-element-lineage element ste-lint-excluded-ancestors)
             (push (ste-lint--check-unit
                    element
                    (org-element-property :contents-begin element)
                    (org-element-property :contents-end element)
                    (if (ste-lint--procedure-p element)
                        ste-lint-max-words-procedure
                      ste-lint-max-words-description))
                   findings))))))
    (sort (apply #'append findings)
          (lambda (a b) (< (ste-lint-finding-beg a) (ste-lint-finding-beg b))))))

(defun ste-lint-file (file)
  "Return the STE findings of the Org FILE.
Each element is (LINE COLUMN FINDING).  COLUMN counts from 1."
  (with-temp-buffer
    (insert-file-contents file)
    (let ((org-inhibit-startup t)
          (org-mode-hook nil))
      (org-mode))
    (mapcar (lambda (finding)
              (save-excursion
                (goto-char (ste-lint-finding-beg finding))
                (list (line-number-at-pos) (1+ (current-column)) finding)))
            (ste-lint-buffer))))

(defun ste-lint--severity-label (severity)
  "Return the printed label of SEVERITY."
  (if (eq severity 'error) "ERROR" "WARN"))

(defun ste-lint--expand-files (paths)
  "Return the Org files that PATHS name.
A directory gives every Org file below it, without hidden directories."
  (cl-loop
   for path in paths
   nconc (if (file-directory-p path)
             (directory-files-recursively
              path "\\.org\\'" nil
              (lambda (dir)
                (not (string-prefix-p "." (file-name-nondirectory dir)))))
           (list path))))

(defun ste-lint-batch ()
  "Lint the files and directories on the command line, then exit.
With no argument, lint every Org file below `default-directory'.  Exit
with status 1 if there is at least one ERROR finding."
  (let ((files (ste-lint--expand-files
                (or command-line-args-left (list default-directory))))
        (errors 0)
        (warnings 0))
    (setq command-line-args-left nil)
    (dolist (file files)
      (if (not (file-readable-p file))
          (message "warning: cannot read %s" file)
        (pcase-dolist (`(,line ,column ,finding) (ste-lint-file file))
          (if (eq (ste-lint-finding-severity finding) 'error)
              (cl-incf errors)
            (cl-incf warnings))
          (message "%s:%d:%d: %s [%s] %s -- %s"
                   file line column
                   (ste-lint--severity-label
                    (ste-lint-finding-severity finding))
                   (ste-lint-finding-category finding)
                   (ste-lint-finding-match finding)
                   (ste-lint-finding-suggestion finding)))))
    (message "%d error(s), %d warning(s)." errors warnings)
    (kill-emacs (if (> errors 0) 1 0))))

;;;; Flymake

(defun ste-lint-flymake (report-fn &rest _args)
  "Report the STE findings of the current buffer to Flymake.
REPORT-FN is the Flymake callback."
  (funcall report-fn
           (mapcar (lambda (finding)
                     (flymake-make-diagnostic
                      (current-buffer)
                      (ste-lint-finding-beg finding)
                      (ste-lint-finding-end finding)
                      (if (eq (ste-lint-finding-severity finding) 'error)
                          :error
                        :warning)
                      (format "STE [%s] %s -- %s"
                              (ste-lint-finding-category finding)
                              (ste-lint-finding-match finding)
                              (ste-lint-finding-suggestion finding))))
                   (ste-lint-buffer))))

;;;###autoload
(defun ste-lint-flymake-setup ()
  "Turn on the STE checks of Flymake in the current Org buffer."
  (interactive)
  (add-hook 'flymake-diagnostic-functions #'ste-lint-flymake nil t)
  (flymake-mode 1))

(provide 'ste-lint)

;;; ste-lint.el ends here