[elpa] externals/relint 562225c 2/4: Add error suppression mechanism

[Mattias Engdegård]

branch: externals/relint
commit 562225c672d736c930da73ce3f1d2b0dd55158d7
Author: Mattias Engdegård <address@hidden>
Commit: Mattias Engdegård <address@hidden>

    Add error suppression mechanism
    
    It relies on a special comment on a line preceding the error, on the form
    
     ;; relint suppression: SUBSTRING
    
    where SUBSTRING is a substring of the error message to be suppressed.
    More than one suppression line can precede a code line, each suppressing
    a different error in that line.
---
 README.org |  16 ++++++++
 relint.el  | 133 +++++++++++++++++++++++++++++++++++++++++--------------------
 2 files changed, 106 insertions(+), 43 deletions(-)

diff --git a/README.org b/README.org
index 6735e1c..1f9599e 100644
--- a/README.org
+++ b/README.org
@@ -175,6 +175,22 @@ If you are just building a string containing a regexp for 
display
 purposes, consider using other delimiters than square brackets;
 displaying the regexp ~0-9~ as ~[0-9]~ is very misleading.
 
+* Suppressing diagnostics
+
+While relint has been designed to avoid false positives, there may
+be cases where it emits unfounded complaints. Most of the time, it
+is worth the trouble to change the code to make them go away, but
+sometimes it cannot be done in a reasonable way.
+
+To suppress such diagnostics, add a comment on the form
+
+: ;; relint suppression: MESSAGE
+
+on the line before the code where the error occurred. MESSAGE is a
+substring of the message to be suppressed. Multiple suppression
+comment lines can precede a line of code to eliminate several
+complaints on the same line.
+
 * Bugs
 
 The recognition of regexps is done by ad-hoc rules; the simplistic
diff --git a/relint.el b/relint.el
index a0b092b..b26fbba 100644
--- a/relint.el
+++ b/relint.el
@@ -100,6 +100,7 @@
           buf))))
 
 (defvar relint--error-count)
+(defvar relint--suppression-count)
 
 (defun relint--add-to-error-buffer (string)
   (with-current-buffer (relint--error-buffer)
@@ -112,52 +113,90 @@
                                 (seq ";" (0+ nonl))))))
     (goto-char (match-end 0))))
 
-(defun relint--line-col-from-pos-path (pos path)
-  "Compute (LINE . COLUMN) from POS (toplevel position)
-and PATH (reversed list of list indices to follow to target)."
-  (save-excursion
-    (goto-char pos)
-    (let ((p (reverse path)))
-      (while p
-        (relint--skip-whitespace)
-        (let ((skip (car p)))
-          ;; Enter next sexp and skip past the `skip' first sexps inside.
-          (cond
-           ((looking-at (rx (or "'" "#'" "`" "," ",@")))
-            (goto-char (match-end 0))
-            (setq skip (1- skip)))
-           ((looking-at (rx "("))
-            (forward-char 1)))
-          (while (> skip 0)
-            (relint--skip-whitespace)
-            (if (looking-at (rx "."))
-                (progn
+(defun relint--go-to-pos-path (toplevel-pos path)
+  "Move point to TOPLEVEL-POS and PATH (reversed list of list
+indices to follow to target)."
+  (goto-char toplevel-pos)
+  (let ((p (reverse path)))
+    (while p
+      (relint--skip-whitespace)
+      (let ((skip (car p)))
+        ;; Enter next sexp and skip past the `skip' first sexps inside.
+        (cond
+         ((looking-at (rx (or "'" "#'" "`" "," ",@")))
+          (goto-char (match-end 0))
+          (setq skip (1- skip)))
+         ((looking-at (rx "("))
+          (forward-char 1)))
+        (while (> skip 0)
+          (relint--skip-whitespace)
+          (if (looking-at (rx "."))
+              (progn
+                (goto-char (match-end 0))
+                (relint--skip-whitespace)
+                (cond
+                 ((looking-at (rx (or "'" "#'" "`" "," ",@")))
+                  ;; Sugar after dot represents one sexp.
                   (goto-char (match-end 0))
-                  (relint--skip-whitespace)
-                  (cond
-                   ((looking-at (rx (or "'" "#'" "`" "," ",@")))
-                    ;; Sugar after dot represents one sexp.
-                    (goto-char (match-end 0))
-                    (setq skip (1- skip)))
-                   ((looking-at (rx "("))
-                    ;; `. (' represents zero sexps.
-                    (goto-char (match-end 0)))))
-              (forward-sexp)
-              (setq skip (1- skip)))))
-        (setq p (cdr p))))
-    (relint--skip-whitespace)
-    (cons (line-number-at-pos (point) t)
+                  (setq skip (1- skip)))
+                 ((looking-at (rx "("))
+                  ;; `. (' represents zero sexps.
+                  (goto-char (match-end 0)))))
+            (forward-sexp)
+            (setq skip (1- skip)))))
+      (setq p (cdr p))))
+  (relint--skip-whitespace))
+
+(defun relint--pos-line-col-from-toplevel-pos-path (toplevel-pos path)
+  "Compute (POINT LINE COLUMN) from TOPLEVEL-POS and PATH (reversed
+list of list indices to follow to target)."
+  (save-excursion
+    (relint--go-to-pos-path toplevel-pos path)
+    (list (point)
+          (line-number-at-pos (point) t)
           (1+ (current-column)))))
 
+(defun relint--suppression (pos message)
+  "Whether there is a suppression for MESSAGE at POS."
+  (save-excursion
+    ;; On a preceding line, look for a comment on the form
+    ;;
+    ;; relint suppression: SUBSTRING
+    ;;
+    ;; where SUBSTRING is a substring of MESSAGE. There can be
+    ;; multiple suppression lines preceding a line of code with
+    ;; several errors.
+    (goto-char pos)
+    (forward-line -1)
+    (let ((matched nil))
+      (while (and
+              (not (setq matched
+                         (and
+                          (looking-at (rx (0+ blank) (1+ ";") (0+ blank)
+                                          "relint suppression:" (0+ blank)
+                                          (group (0+ nonl)
+                                                 (not (any "\n" blank)))))
+                          (let ((substr (match-string 1)))
+                            (string-match-p (regexp-quote substr) message)))))
+              (looking-at (rx bol
+                              (0+ blank) (opt ";" (0+ nonl))
+                              eol))
+              (not (bobp)))
+        (forward-line -1))
+      matched)))
+
 (defun relint--output-error (string)
   (if noninteractive
       (message "%s" string)
     (relint--add-to-error-buffer (concat string "\n"))))
 
 (defun relint--report (file pos path message)
-  (let ((line-col (relint--line-col-from-pos-path pos path)))
-    (relint--output-error
-     (format "%s:%d:%d: %s" file (car line-col) (cdr line-col) message)))
+  (let ((point-line-col (relint--pos-line-col-from-toplevel-pos-path pos 
path)))
+    (if (relint--suppression (nth 0 point-line-col) message)
+        (setq relint--suppression-count (1+ relint--suppression-count))
+      (relint--output-error
+       (format "%s:%d:%d: %s"
+               file (nth 1 point-line-col) (nth 2 point-line-col) message))))
   (setq relint--error-count (1+ relint--error-count)))
 
 (defun relint--quote-string (str)
@@ -1320,7 +1359,9 @@ Return a list of (FORM . STARTING-POSITION)."
 
 (defun relint--init (target base-dir)
   (if noninteractive
-      (setq relint--error-count 0)
+      (progn
+        (setq relint--error-count 0)
+        (setq relint--suppression-count 0))
     (with-current-buffer (relint--error-buffer)
       (let ((inhibit-read-only t))
         (compilation-forget-errors)
@@ -1329,14 +1370,20 @@ Return a list of (FORM . STARTING-POSITION)."
         (relint--show-errors))
       (setq relint-last-target target)
       (setq default-directory base-dir)
-      (setq relint--error-count 0))))
+      (setq relint--error-count 0)
+      (setq relint--suppression-count 0))))
 
 (defun relint--finish ()
-  (let* ((errors relint--error-count)
-         (msg (format "%d error%s" errors (if (= errors 1) "" "s"))))
+  (let* ((supp relint--suppression-count)
+         (errors (- relint--error-count supp))
+         (msg (format "%d error%s%s"
+                      errors (if (= errors 1) "" "s")
+                      (if (zerop supp)
+                          ""
+                        (format " (%s suppressed)" supp)))))
     (unless noninteractive
-      (relint--add-to-error-buffer (format "\nFinished -- %s found.\n" msg)))
-    (message "relint: %s found." msg)))
+      (relint--add-to-error-buffer (format "\nFinished -- %s.\n" msg)))
+    (message "relint: %s." msg)))
 
 (defun relint-again ()
   "Re-run relint on the same file, directory or buffer as last time."