;;; org-lint.el --- Linting for Org documents        -*- lexical-binding: t; -*-

;; Copyright (C) 2015  Free Software Foundation

;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
;; Keywords: outlines, hypermedia, calendar, wp

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This library implements linting for Org syntax.  The sole public
;; function is `org-lint', which see.

;; Internally, the library defines a new structure:
;; `org-lint-checker', with the following slots:

;;   - NAME: Unique check identifier, as a symbol.  The check is done
;;     calling the function `org-lint-NAME' with one mandatory
;;     argument, the parse tree describing the current Org buffer.
;;     Such function calls are wrapped within a `save-excursion' and
;;     point is always at `point-min'.  Its return value has to be an
;;     alist (POSITION MESSAGE) when POSITION refer to the buffer
;;     position of the error, as an integer, and MESSAGE is a strings
;;     describing the error.

;;   - DESCRIPTION: Summary about the check, as a string.

;;   - CATEGORIES: Categories relative to the check, as a list of
;;     symbol.  They are used for filtering when calling `org-lint'.
;;     Checkers not explicitly associated to a category are collected
;;     in the `default' one.

;;   - TRUST: The trust level one can have in the check.  It is either
;;     `low' or `high', depending on the heuristics implemented and
;;     the nature of the check.  This has an indicative value only and
;;     is displayed along reports.

;; All checks have to be listed in `org-lint--checkers'.

;; Results are displayed in a special "*Org Lint*" buffer with
;; a dedicated major mode, derived from `tabulated-list-mode'.  In
;; addition to the usual key-bindings inherited from it, "C-j"
;; displays problematic line reported under point and "RET" jumps to
;; it.

;; Checks currently implemented are:

;;   - duplicates CUSTOM_ID properties
;;   - duplicate NAME values
;;   - duplicate targets
;;   - duplicate footnote definitions
;;   - orphaned affiliated keywords
;;   - obsolete affiliated keywords
;;   - missing language in src blocks
;;   - NAME values with a colon
;;   - wrong header arguments in src blocks
;;   - misuse of CATEGORY keyword
;;   - "coderef" links with unknown destination
;;   - "custom-id" links with unknown destination
;;   - "fuzzy" links with unknown destination
;;   - "id" links with unknown destination
;;   - links to non-existent local files
;;   - special properties in properties drawer
;;   - obsolete syntax for PROPERTIES drawers
;;   - missing definition for footnote references
;;   - missing reference for footnote definitions
;;   - non-footnote definitions in footnote section
;;   - probable invalid keywords
;;   - invalid blocks
;;   - probable incomplete drawers
;;   - obsolete QUOTE section

\f
;;; Code:

(require 'cl-lib)
(require 'org-element)
(require 'ox)
(require 'ob)

\f
;;; Checkers

(cl-defstruct (org-lint-checker (:copier nil))
  (name 'missing-checker-name)
  (description "")
  (categories '(default))
  (trust 'high))			; `low' or `high'

(defun org-lint-missing-checker-name (_)
  (error
   "`A checker has no `:name' property.  Please verify `org-lint--checkers'"))

(defconst org-lint--checkers
  (list
   (make-org-lint-checker
    :name 'duplicate-custom-id
    :description "Report duplicates CUSTOM_ID properties"
    :categories '(link))
   (make-org-lint-checker
    :name 'duplicate-name
    :description "Report duplicate NAME values"
    :categories '(babel link))
   (make-org-lint-checker
    :name 'duplicate-target
    :description "Report duplicate targets"
    :categories '(link))
   (make-org-lint-checker
    :name 'duplicate-footnote-definition
    :description "Report duplicate footnote definitions"
    :categories '(footnote))
   (make-org-lint-checker
    :name 'orphaned-affiliated-keywords
    :description "Report orphaned affiliated keywords"
    :trust 'low)
   (make-org-lint-checker
    :name 'obsolete-affiliated-keywords
    :description "Report obsolete affiliated keywords"
    :categories '(obsolete))
   (make-org-lint-checker
    :name 'missing-language-in-src-block
    :description "Report missing language in src blocks"
    :categories '(babel))
   (make-org-lint-checker
    :name 'colon-in-name
    :description "Report NAME values with a colon"
    :categories '(babel))
   (make-org-lint-checker
    :name 'wrong-header-argument
    :description "Report wrong header arguments in src blocks"
    :categories '(babel))
   (make-org-lint-checker
    :name 'deprecated-category-setup
    :description "Report misuse of CATEGORY keyword"
    :categories '(obsolete))
   (make-org-lint-checker
    :name 'invalid-coderef-link
    :description "Report \"coderef\" links with unknown destination"
    :categories '(link))
   (make-org-lint-checker
    :name 'invalid-custom-id-link
    :description "Report \"custom-id\" links with unknown destination"
    :categories '(link))
   (make-org-lint-checker
    :name 'invalid-fuzzy-link
    :description "Report \"fuzzy\" links with unknown destination"
    :categories '(link))
   (make-org-lint-checker
    :name 'invalid-id-link
    :description "Report \"id\" links with unknown destination"
    :categories '(link))
   (make-org-lint-checker
    :name 'link-to-local-file
    :description "Report links to non-existent local files"
    :categories '(link)
    :trust 'low)
   (make-org-lint-checker
    :name 'special-property-in-properties-drawer
    :description "Report special properties in properties drawers"
    :categories '(properties))
   (make-org-lint-checker
    :name 'obsolete-properties-drawer
    :description "Report obsolete syntax for properties drawers"
    :categories '(obsolete properties)
    :trust 'low)
   (make-org-lint-checker
    :name 'undefined-footnote-reference
    :description "Report missing definition for footnote references"
    :categories '(footnote))
   (make-org-lint-checker
    :name 'unreferenced-footnote-definition
    :description "Report missing reference for footnote definitions"
    :categories '(footnote))
   (make-org-lint-checker
    :name 'extraneous-element-in-footnote-section
    :description "Report non-footnote definitions in footnote section"
    :trust 'high
    :categories '(footnote))
   (make-org-lint-checker
    :name 'invalid-keyword-syntax
    :description "Report probable invalid keywords"
    :trust 'low)
   (make-org-lint-checker
    :name 'corrupted-block
    :description "Report invalid blocks"
    :trust 'low)
   (make-org-lint-checker
    :name 'incomplete-drawer
    :description "Report probable incomplete drawers"
    :trust 'low)
   (make-org-lint-checker
    :name 'quote-section
    :description "Report obsolete QUOTE section"
    :categories '(obsolete)
    :trust 'low))
  "List of all available checkers.")

(defun org-lint-duplicate-custom-id (ast)
  (org-element-map ast '(headline inlinetask)
    (let (ids)
      (lambda (e)
	(let ((custom-id (org-element-property :CUSTOM_ID e)))
	  (cond
	   ((not custom-id) nil)
	   ((member custom-id ids)
	    (list (org-element-map e 'node-property
		    (lambda (p)
		      (and (eq (compare-strings
				"CUSTOM_ID" nil nil
				(org-element-property :key p) nil nil
				t)
			       t)
			   (org-element-property :begin p)))
		    nil t)
		  (format "Duplicate CUSTOM_ID property \"%s\"" custom-id)))
	   (t (push custom-id ids) nil)))))))

(defun org-lint-duplicate-name (ast)
  (org-element-map ast org-element-all-elements
    (let (names)
      (lambda (e)
	(let ((name (org-element-property :name e)))
	  (cond
	   ((not name) nil)
	   ((member name names)
	    (list (progn (goto-char (org-element-property :begin e))
			 (let ((case-fold-search t))
			   (re-search-forward
			    (concat "^[ \t]*#\\+NAME: +" (regexp-quote name)))
			   (match-beginning 0)))
		  (format "Duplicate NAME \"%s\"" name)))
	   (t (push name names) nil)))))))

(defun org-lint-duplicate-target (ast)
  (org-element-map ast 'target
    (let (targets)
      (lambda (o)
	(let ((target (org-split-string (org-element-property :value o))))
	  (if (member target targets)
	      (list (org-element-property :begin o)
		    (format "Duplicate target \"%s\""
			    (org-element-property :value o)))
	    (push target targets)
	    nil))))))

(defun org-lint-duplicate-footnote-definition (ast)
  (org-element-map ast 'footnote-definition
    (let (labels)
      (lambda (f)
	(let ((label (org-element-property :label f)))
	  (cond ((not label) nil)
		((member label labels)
		 (list (org-element-property :post-affiliated f)
		       (format "Duplicate footnote definition \"%s\"" label)))
		(t (push label labels) nil)))))))

(defun org-lint-orphaned-affiliated-keywords (ast)
  (org-element-map ast 'keyword
    (lambda (k)
      (let ((key (org-element-property :key k)))
	(and (member key org-element-affiliated-keywords)
	     (list (org-element-property :post-affiliated k)
		   (format "Orphaned affiliated keyword: \"%s\"" key)))))))

(defun org-lint-obsolete-affiliated-keywords (_)
  (let ((regexp (format "^[ \t]*#\\+%s:"
			(regexp-opt '("DATA" "LABEL" "RESNAME" "SOURCE"
				      "SRCNAME" "TBLNAME" "RESULT" "HEADERS")
				    t)))
	reports)
    (while (re-search-forward regexp nil t)
      (let ((key (upcase (org-match-string-no-properties 1))))
	(when (< (point)
		 (org-element-property :post-affiliated (org-element-at-point)))
	  (push
	   (list (line-beginning-position)
		 (format
		  "Obsolete affiliated keyword: \"%s\".  Use \"%s\" instead"
		  key
		  (pcase key
		    ("HEADERS" "HEADER")
		    ("RESULT" "RESULTS")
		    (_ "NAME"))))
	   reports))))
    reports))

(defun org-lint-missing-language-in-src-block (ast)
  (org-element-map ast 'src-block
    (lambda (b)
      (unless (org-element-property :language b)
	(list (org-element-property :post-affiliated b)
	      "Missing language in source block")))))

(defun org-lint-deprecated-category-setup (ast)
  (org-element-map ast 'keyword
    (let (category-flag)
      (lambda (k)
	(cond
	 ((not (string= (org-element-property :key k) "CATEGORY")) nil)
	 (category-flag
	  (list (org-element-property :post-affiliated k)
		"Spurious CATEGORY keyword.  Set :CATEGORY: property instead"))
	 (t (setf category-flag t) nil))))))

(defun org-lint-invalid-coderef-link (ast)
  (let ((info (list :parse-tree ast)))
    (org-element-map ast 'link
      (lambda (link)
	(let ((ref (org-element-property :path link)))
	  (and (equal (org-element-property :type link) "coderef")
	       (not (ignore-errors (org-export-resolve-coderef ref info)))
	       (list (org-element-property :begin link)
		     (format "Unknown coderef \"%s\"" ref))))))))

(defun org-lint-invalid-custom-id-link (ast)
  (let ((info (list :parse-tree ast)))
    (org-element-map ast 'link
      (lambda (link)
	(and (equal (org-element-property :type link) "custom-id")
	     (not (ignore-errors (org-export-resolve-id-link link info)))
	     (list (org-element-property :begin link)
		   (format "Unknown custom ID \"%s\""
			   (org-element-property :path link))))))))

(defun org-lint-invalid-fuzzy-link (ast)
  (let ((info (list :parse-tree ast)))
    (org-element-map ast 'link
      (lambda (link)
	(and (equal (org-element-property :type link) "fuzzy")
	     (not (ignore-errors (org-export-resolve-fuzzy-link link info)))
	     (list (org-element-property :begin link)
		   (format "Unknown fuzzy location \"%s\""
			   (let ((path (org-element-property :path link)))
			     (if (string-prefix-p "*" path)
				 (substring path 1)
			       path)))))))))

(defun org-lint-invalid-id-link (ast)
  (org-element-map ast 'link
    (lambda (link)
      (let ((id (org-element-property :path link)))
	(and (equal (org-element-property :type link) "id")
	     (not (org-id-find id))
	     (list (org-element-property :begin link)
		   (format "Unknown ID \"%s\"" id)))))))

(defun org-lint-special-property-in-properties-drawer (ast)
  (org-element-map ast 'node-property
    (lambda (p)
      (let ((key (org-element-property :key p)))
	(and (member-ignore-case key org-special-properties)
	     (list (org-element-property :begin p)
		   (format
		    "Special property \"%s\" found in a properties drawer"
		    key)))))))

(defun org-lint-obsolete-properties-drawer (ast)
  (org-element-map ast 'drawer
    (lambda (d)
      (when (equal (org-element-property :drawer-name d) "PROPERTIES")
	(let ((section (org-element-lineage d '(section))))
	  (unless (org-element-map section 'property-drawer #'identity nil t)
	    (list (org-element-property :post-affiliated d)
		  (if (save-excursion
			(goto-char (org-element-property :post-affiliated d))
			(forward-line -1)
			(or (org-at-heading-p) (org-at-planning-p)))
		      "Incorrect contents for PROPERTIES drawer"
		    "Incorrect location for PROPERTIES drawer"))))))))

(defun org-lint-link-to-local-file (ast)
  (org-element-map ast 'link
    (lambda (l)
      (when (equal (org-element-property :type l) "file")
	(let ((file (org-element-property :path l)))
	  (and (not (file-remote-p file))
	       (not (file-exists-p file))
	       (list (org-element-property :begin l)
		     (format "Link to non-existent local file \"%s\""
			     file))))))))

(defun org-lint-undefined-footnote-reference (ast)
  (let ((definitions (org-element-map ast 'footnote-definition
		       (lambda (f) (org-element-property :label f)))))
    (org-element-map ast 'footnote-reference
      (lambda (f)
	(let ((label (org-element-property :label f)))
	  (and label
	       (not (member label definitions))
	       (list (org-element-property :begin f)
		     (format "Missing definition for footnote [%s]"
			     label))))))))

(defun org-lint-unreferenced-footnote-definition (ast)
  (let ((references (org-element-map ast 'footnote-reference
		      (lambda (f) (org-element-property :label f)))))
    (org-element-map ast 'footnote-definition
      (lambda (f)
	(let ((label (org-element-property :label f)))
	  (and label
	       (not (member label references))
	       (list (org-element-property :post-affiliated f)
		     (format "No reference for footnote definition [%s]"
			     label))))))))

(defun org-lint-colon-in-name (ast)
  (org-element-map ast org-element-all-elements
    (lambda (e)
      (let ((name (org-element-property :name e)))
	(and name
	     (org-string-match-p ":" name)
	     (list (progn
		     (goto-char (org-element-property :begin e))
		     (let ((case-fold-search t))
		       (re-search-forward
			(concat "^[ \t]*#\\+NAME: +" (regexp-quote name)))
		       (match-beginning 0)))
		   (format
		    "Name \"%s\" contains a colon; Babel cannot use it as input"
		    name)))))))

(defun org-lint-incomplete-drawer (_)
  (let (reports)
    (while (re-search-forward org-drawer-regexp nil t)
      (let ((name (org-trim (org-match-string-no-properties 0)))
	    (element (org-element-at-point)))
	(pcase (org-element-type element)
	  (`(drawer property-drawer)
	   (goto-char (org-element-property :end element))
	   nil)
	  (`paragraph
	   (push (list (line-beginning-position)
		       (format "Possible incomplete drawer \"%s\"" name))
		 reports))
	  (_ nil))))
    reports))

(defun org-lint-corrupted-block (_)
  (let ((case-fold-search t)
	(regexp "^[ \t]*#\\+\\(BEGIN\\|END\\)\\(?::\\|_[^[:space:]]*\\)?[ \t]*")
	reports)
    (while (re-search-forward regexp nil t)
      (let ((name (org-trim (buffer-substring-no-properties
			     (line-beginning-position) (line-end-position)))))
	(cond
	 ((and (string-prefix-p "END" (match-string 1) t)
	       (not (eolp)))
	  (push (list (line-beginning-position)
		      (format "Invalid block closing line \"%s\"" name))
		reports))
	 ((eq (org-element-type (org-element-at-point)) 'paragraph)
	  (push (list (line-beginning-position)
		      (format "Possible incomplete block \"%s\""
			      name))
		reports)))))
    reports))

(defun org-lint-invalid-keyword-syntax (_)
  (let ((regexp "^[ \t]*\\(#\\+[^[:space:]:]*\\)\\(?:[[:space:]]\\|$\\)")
	reports)
    (while (re-search-forward regexp nil t)
      (let ((name (org-match-string-no-properties 1)))
	(unless (or (string-prefix-p "#+BEGIN" name t)
		    (string-prefix-p "#+END" name t))
	  (push (list (match-beginning 0)
		      (format "Possible missing colon in keyword \"%s\"" name))
		reports))))
    reports))

(defun org-lint-extraneous-element-in-footnote-section (ast)
  (org-element-map ast 'headline
    (lambda (h)
      (and (org-element-property :footnote-section-p h)
	   (org-element-map (org-element-contents h)
	       (org-remove-if
		(lambda (e)
		  (memq e '(comment comment-block footnote-definition
				    property-drawer section)))
		org-element-all-elements)
	     (lambda (e)
	       (not (and (eq (org-element-type e) 'headline)
			 (org-element-property :commentedp e))))
	     nil t '(footnote-definition property-drawer))
	   (list (org-element-property :begin h)
		 "Extraneous elements in footnote section")))))

(defun org-lint-quote-section (ast)
  (org-element-map ast '(headline inlinetask)
    (lambda (h)
      (let ((title (org-element-property :raw-value h)))
	(and (or (string-prefix-p "QUOTE " title)
		 (string-prefix-p (concat org-comment-string " QUOTE ") title))
	     (list (org-element-property :begin h)
		   "Deprecated QUOTE section"))))))

(defun org-lint-wrong-header-argument (ast)
  (let (reports)
    (org-element-map ast 'src-block
      (lambda (b)
	(let* ((language (org-element-property :language b))
	       (allowed
		(mapcar #'symbol-name
			(append
			 org-babel-header-arg-names
			 (let ((v (intern (concat "org-babel-header-args:"
						  language))))
			   (and (boundp v)
				(mapcar #'car (symbol-value v))))))))
	  (dolist (header (mapcar
			   (lambda (e) (substring (symbol-name (car e)) 1))
			   (org-babel-parse-header-arguments
			    (org-element-property :parameters b))))
	    (unless (member header allowed)
	      (push (list (org-element-property :post-affiliated b)
			  (format "Unknown header argument \"%s\"" header))
		    reports))))))
    reports))

\f
;;; Reports UI

(defvar org-lint--report-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map tabulated-list-mode-map)
    (define-key map (kbd "RET") 'org-lint--jump-to-source)
    (define-key map (kbd "C-j") 'org-lint--show-source)
    map)
  "Local keymap for `org-lint--report-mode' buffers.")

(define-derived-mode org-lint--report-mode tabulated-list-mode "OrgLint"
  "Major mode used to display reports emitted during linting.
\\<package-menu-mode-map>"
  (setf tabulated-list-format
	`[("Line" 6
	   (lambda (a b)
	     (< (string-to-number (aref (cadr a) 0))
		(string-to-number (aref (cadr b) 0))))
	   :right-align t)
	  ("Trust" 5 t)
	  ("Warning" 0 nil)])
  (tabulated-list-init-header))

(defun org-lint--generate-reports (checkers)
  "Run all CHECKERS in current buffer.
Return an alist (ID [LINE TRUST DESCRIPTION]), suitable for
`tabulated-list-printer'."
  (save-excursion
    (goto-char (point-min))
    (let ((ast (org-element-parse-buffer))
	  (id 0)
	  (last-line 1)
	  (last-pos 1))
      ;; Insert unique ID for each report.  Replace buffer positions
      ;; with line numbers.
      (mapcar
       (lambda (report)
	 (list
	  (incf id)
	  (apply #'vector
		 (cons
		  (progn
		    (goto-char (car report))
		    (beginning-of-line)
		    (prog1 (number-to-string
			    (incf last-line (count-lines last-pos (point))))
		      (setf last-pos (point))))
		  (cdr report)))))
       ;; Insert trust level in generated reports.  Also sort them by
       ;; buffer position in order to optimize lines computation.
       (sort (cl-mapcan
	      (lambda (c)
		(let ((trust (symbol-name (org-lint-checker-trust c))))
		  (mapcar
		   (lambda (report) (list (car report) trust (nth 1 report)))
		   (save-excursion
		     (funcall (intern
			       (concat "org-lint-"
				       (symbol-name (org-lint-checker-name c))))
			      ast)))))
	      checkers)
	     #'car-less-than-car)))))

(defvar org-lint--source-buffer nil
  "Source buffer associated to current report buffer.")
(make-variable-buffer-local 'org-lint--source-buffer)

(defun org-lint--display-reports (source checkers)
  "Display linting reports for buffer SOURCE.
CHECKERS is the list of checkers used."
  (let ((buffer (get-buffer-create "*Org Lint*")))
    (with-current-buffer buffer
      (org-lint--report-mode)
      (setf org-lint--source-buffer source)
      (setf tabulated-list-entries
	    (lambda ()
	      (with-current-buffer source
		(org-lint--generate-reports checkers))))
      (tabulated-list-print))
    (pop-to-buffer buffer)))

(defun org-lint--jump-to-source ()
  "Move to source line that generated the report at point."
  (interactive)
  (let ((l (string-to-number (aref (tabulated-list-get-entry) 0))))
    (switch-to-buffer-other-window org-lint--source-buffer)
    (org-goto-line l)
    (org-show-set-visibility 'local)
    (recenter)))

(defun org-lint--show-source ()
  "Show source line that generated the report at point."
  (interactive)
  (let ((buffer (current-buffer))
	(l (string-to-number (aref (tabulated-list-get-entry) 0))))
    (switch-to-buffer-other-window org-lint--source-buffer)
    (org-goto-line l)
    (org-show-set-visibility 'local)
    (recenter)
    (switch-to-buffer-other-window buffer)))

\f
;;; Public function

;;;###autoload
(defun org-lint (&optional arg)
  "Check current Org buffer for syntax mistakes.

By default, run all checkers.  With a single prefix ARG \
\\[universal-argument],
select one category of checkers only.  With a double prefix
\\[universal-argument] \\[universal-argument], select one precise \
checker by its name.

ARG can also be a list of checker names, as symbols, to run."
  (interactive "P")
  (unless (derived-mode-p 'org-mode) (user-error "Not in an Org buffer"))
  (message "Org linting process starting...")
  (org-lint--display-reports
   (current-buffer)
   (pcase arg
     (`nil org-lint--checkers)
     (`(4)
      (let ((category
	     (completing-read
	      "Checker category: "
	      (mapcar #'org-lint-checker-categories org-lint--checkers)
	      nil t)))
	(org-remove-if-not
	 (lambda (c) (assoc-string (org-lint-checker-categories c) category))
	 org-lint--checkers)))
     (`(16)
      (list
       (let ((name (completing-read
		    "Checker name: "
		    (mapcar #'org-lint-checker-name org-lint--checkers)
		    nil t)))
	 (catch 'exit
	   (dolist (c org-lint--checkers)
	     (when (string= (org-lint-checker-name c) name)
	       (throw 'exit c)))))))
     ((pred consp)
      (org-remove-if-not (lambda (c) (memq (org-lint-checker-name c) arg))
			 org-lint--checkers))
     (_ (user-error "Invalid argument `%S' for `org-lint'" arg))))
  (message "Org linting process completed"))


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