[Emacs-diffs] scratch/flymake-refactor-cleaner-for-emacs-26 2b735b4 08/39: New Flymake variable flymake-diagnostic-types-alist and much cleanup

[João Távora]

branch: scratch/flymake-refactor-cleaner-for-emacs-26
commit 2b735b4a5b5ccfbb5439ecb5cf47ffe6d87604dd
Author: João Távora <address@hidden>
Commit: João Távora <address@hidden>

    New Flymake variable flymake-diagnostic-types-alist and much cleanup
    
    A new user-visible variable is introduced where different diagnostic
    types can be categorized.  Flymake backends can also contribute to
    this variable.  Anything that doesn’t match an existing error type
    is considered.
    
    The variable’s alists are used to propertize the overlays pertaining
    to each error type.  The user can override the built-in properties by
    either by modifying the alist, or by modifying the properties of a
    special "category" symbol, named by the `flymake-category' entry in
    the alist.
    
    The `flymake-category' entry is especially useful for, say, the author
    of foo-flymake-backend, who issues diagnostics of type :foo-note, that
    should behave like notes, except with no fringe bitmap:
    
       (add-to-list 'flymake-diagnostic-types-alist
                    '(:foo-note
                      . ((flymake-category . flymake-note)
                         (bitmap . nil))))
    
    For essential properties like `severity', `priority', etc, a default
    value is produced.  Some properties like `evaporate' cannot be
    overriden.
    
    * lisp/progmodes/flymake.el (flymake--diag): Rename from
    flymake-ler.
    (flymake-ler-make): Obsolete alias for flymake-diagnostic-make
    (flymake-ler-errorp): Rewrite using flymake--severity.
    (flymake--place-overlay): Delete.
    (flymake--overlays): Now a cl-defun with &key args.  Document.
    Use `overlays-at' if BEG is non-nil and END is nil.
    (flymake--lookup-type-property): New helper.
    (flymake--highlight-line): Rewrite.
    (flymake-diagnostic-types-alist): New API variable.
    (flymake--diag-region)
    (flymake--severity, flymake--face)
    (flymake--fringe-overlay-spec): New helper.
    (flymake-popup-current-error-menu): Use new flymake-overlays.
    (flymake-popup-current-error-menu, flymake-report): Use
    flymake--diag-errorp.
    (flymake--fix-line-numbers): Use flymake--diag-line.
    (flymake-goto-next-error): Pass :key to flymake-overlays
    
    * lisp/progmodes/flymake-proc.el
    (flymake-proc--diagnostics-for-pattern): Use flymake-diagnostic-make.
---
 lisp/progmodes/flymake-proc.el |   2 +-
 lisp/progmodes/flymake.el      | 289 ++++++++++++++++++++++++++++-------------
 2 files changed, 198 insertions(+), 93 deletions(-)

diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el
index 0395fff..abda259 100644
--- a/lisp/progmodes/flymake-proc.el
+++ b/lisp/progmodes/flymake-proc.el
@@ -409,7 +409,7 @@ Create parent directories as needed."
                                   (string-to-number col-string))))
             (with-current-buffer (process-buffer proc)
               (push
-               (flymake-ler-make
+               (flymake-make-diagnostic
                 :file fname
                 :line line-number
                 :col col-number
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index f00915a..72acc3a 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -33,6 +33,8 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'thingatpt) ; end-of-thing
+(require 'warnings) ; warning-numeric-level
 
 (defgroup flymake nil
   "Universal on-the-fly syntax checker."
@@ -136,57 +138,18 @@ are the string substitutions (see the function `format')."
       (let* ((msg (apply #'format-message text args)))
        (message "%s" msg))))
 
-(cl-defstruct (flymake-ler
-               (:constructor flymake-ler-make))
+(cl-defstruct (flymake--diag
+               (:constructor flymake-make-diagnostic))
   file line col type text full-file)
-
-(defun flymake-ler-errorp (diag)
-  "Tell if DIAG is a flymake error or something else"
-  (string= "e" (flymake-ler-type diag)))
-
-(defun flymake--place-overlay (beg end tooltip-text face bitmap diag)
-  "Place a flymake overlay in range BEG and END.
-Make a flymake fringe overlay for the line at BEG, if needed."
-  (let* ((fringe-overlay
-          (or (cl-find-if (lambda (ov)
-                            (overlay-get ov 'flymake--fringe-overlay))
-                          (overlays-at beg))
-              (make-overlay beg (1+ beg)))))
-    (let ((ov fringe-overlay))
-      (overlay-put ov 'help-echo
-                   (concat tooltip-text "\n"
-                           (overlay-get ov 'help-echo)))
-      (overlay-put ov 'before-string
-                   (and flymake-fringe-indicator-position
-                        (propertize "!" 'display
-                                    (cons flymake-fringe-indicator-position
-                                          (if (listp bitmap)
-                                              bitmap
-                                            (list bitmap))
-                                          ))))
-      (overlay-put ov 'evaporate t)
-      (overlay-put ov 'flymake-overlay  t)
-      (overlay-put ov 'priority 100)
-      ov)
-    (let ((ov (make-overlay beg end)))
-      (overlay-put ov 'face face)
-      (overlay-put ov 'help-echo
-                   (concat tooltip-text "\n"
-                           (overlay-get ov 'help-echo)))
-      (overlay-put ov 'evaporate t)
-      (overlay-put ov 'flymake-overlay t)
-      (overlay-put ov 'flymake--diagnostic diag))
-    (cl-loop for i from 0
-             for overlay in
-             (flymake--overlays
-              'flymake--diagnostic
-              (lambda (_ov1 ov2)
-                (flymake-ler-errorp
-                 (overlay-get ov2 'flymake--diagnostic)))
-              beg end)
-             do (overlay-put overlay 'priority (+ 100 i)))))
-
-(defun flymake--overlays (&optional filter compare beg end)
+(define-obsolete-function-alias 'flymake-ler-make 'flymake-make-diagnostic 
"26.1"
+  "Constructor for objects of type `flymake--diag'")
+
+(cl-defun flymake--overlays (&key beg end filter compare key)
+  "Get flymake-related overlays.
+If BEG is non-nil and END is nil, consider only `overlays-at'
+BEG. Otherwise consider `overlays-in' the region comprised by BEG
+and END, defaulting to the whole buffer.  Remove all that do not
+verify FILTER, sort them by COMPARE (using KEY)."
   (cl-remove-if-not
    (lambda (ov)
      (and (overlay-get ov 'flymake-overlay)
@@ -195,12 +158,13 @@ Make a flymake fringe overlay for the line at BEG, if 
needed."
                     ((symbolp filter) (overlay-get ov filter))))))
    (save-restriction
      (widen)
-     (let ((ovs (overlays-in (or beg (point-min))
-                             (or end (point-max)))))
+     (let ((ovs (if (and beg (null end))
+                    (overlays-at beg t)
+                  (overlays-in (or beg (point-min))
+                               (or end (point-max))))))
        (if compare
-           (cl-sort ovs
-                    compare
-                    :key #'overlay-start)
+           (cl-sort ovs compare :key (or key
+                                         #'identity))
          ovs)))))
 
 (defun flymake-delete-own-overlays ()
@@ -228,27 +192,167 @@ Make a flymake fringe overlay for the line at BEG, if 
needed."
 (define-obsolete-face-alias 'flymake-warnline 'flymake-warning "26.1")
 (define-obsolete-face-alias 'flymake-errline 'flymake-error "26.1")
 
+(defun flymake--diag-region (diagnostic)
+  "Return the region (BEG . END) for DIAGNOSTIC.
+Or nil if the region is invalid."
+  ;; FIXME: make this a generic function
+  (condition-case-unless-debug _err
+      (save-excursion
+        (goto-char (point-min))
+        (let ((line (flymake--diag-line diagnostic))
+              (col (flymake--diag-col diagnostic)))
+          (forward-line (1- line))
+          (cl-flet ((fallback-bol
+                     () (progn (back-to-indentation) (point)))
+                    (fallback-eol
+                     (beg)
+                     (progn
+                       (end-of-line)
+                       (skip-chars-backward " \t\f\t\n" beg)
+                       (if (eq (point) beg)
+                           (line-beginning-position 2)
+                         (point)))))
+            (if col
+                (let* ((beg (progn (forward-char (1- col)) (point)))
+                       (sexp-end (ignore-errors (end-of-thing 'sexp)))
+                       (end (or sexp-end
+                                (fallback-eol beg))))
+                  (cons (if sexp-end beg (fallback-bol))
+                        end))
+              (let* ((beg (fallback-bol))
+                     (end (fallback-eol beg)))
+                (cons beg end))))))
+    (error (flymake-log 4 "Invalid region for diagnostic %s")
+           nil)))
+
+(defvar flymake-diagnostic-types-alist
+  `((("e" :error error)
+     . ((flymake-category . flymake-error)))
+    (("w" :warning warning)
+     . ((flymake-category . flymake-warning))))
+  "Alist ((KEY . PROPS)*) of properties of flymake error types.
+KEY can be anything passed as `:type' to `flymake-diag-make', or
+a list of these objects.
+
+PROPS is an alist of properties that are applied, in order, to
+the diagnostics of each type.  The recognized properties are:
+
+* Every property pertaining to overlays, except `category' and
+  `evaporate' (see Info Node `(elisp)Overlay Properties'), used
+  affect the appearance of Flymake annotations.
+
+* `bitmap', an image displayed in the fringe according to
+  `flymake-fringe-indicator-position'.  The value actually
+  follows the syntax of `flymake-error-bitmap' (which see).  It
+  is overriden by any `before-string' overlay property.
+
+* `severity', a non-negative integer specifying the diagnostic's
+  severity.  The higher, the more serious.  If the overlay
+  priority `priority' is not specified, `severity' is used to set
+  it and help sort overlapping overlays.
+
+* `flymake-category', a symbol whose property list is considered
+  as a default for missing values of any other properties.  This
+  is useful to backend authors when creating new diagnostic types
+  that differ from an existing type by only a few properties.")
+
+(put 'flymake-error 'face 'flymake-error)
+(put 'flymake-error 'bitmap flymake-error-bitmap)
+(put 'flymake-error 'severity (warning-numeric-level :error))
+(put 'flymake-error 'mode-line-face 'compilation-error)
+
+(put 'flymake-warning 'face 'flymake-warning)
+(put 'flymake-warning 'bitmap flymake-warning-bitmap)
+(put 'flymake-warning 'severity (warning-numeric-level :warning))
+(put 'flymake-warning 'mode-line-face 'compilation-warning)
+
+(put 'flymake-note 'face 'flymake-note)
+(put 'flymake-note 'bitmap flymake-warning-bitmap)
+(put 'flymake-note 'severity (warning-numeric-level :debug))
+(put 'flymake-note 'mode-line-face 'compilation-info)
+
+(defun flymake--lookup-type-property (type prop &optional default)
+  "Look up PROP for TYPE in `flymake-diagnostic-types-alist'.
+If TYPE doesn't declare PROP in either
+`flymake-diagnostic-types-alist' or its associated category,
+return DEFAULT."
+  (let ((alist-probe (assoc type flymake-diagnostic-types-alist
+                            (lambda (entry key)
+                              (or (equal key entry)
+                                  (member key entry))))))
+    (cond (alist-probe
+           (let* ((alist (cdr alist-probe))
+                  (prop-probe (assoc prop alist)))
+             (if prop-probe
+                 (cdr prop-probe)
+               (if-let* ((cat (assoc-default 'flymake-category alist))
+                         (plist (and (symbolp cat)
+                                     (symbol-plist cat)))
+                         (cat-probe (plist-member plist prop)))
+                   (cadr cat-probe)
+                 default))))
+          (t
+           default))))
+
+(defun flymake--diag-errorp (diag)
+  "Tell if DIAG is a flymake error or something else"
+  (let ((sev (flymake--lookup-type-property 'severity
+                                            (flymake--diag-type diag)
+                                            (warning-numeric-level :error))))
+    (>= sev (warning-numeric-level :error))))
+
+(defun flymake--fringe-overlay-spec (bitmap)
+  (and flymake-fringe-indicator-position
+       bitmap
+       (propertize "!" 'display
+                   (cons flymake-fringe-indicator-position
+                         (if (listp bitmap)
+                             bitmap
+                           (list bitmap))))))
+
 (defun flymake--highlight-line (diagnostic)
-  "Highlight buffer with info in DIAGNOSTIC.
-Reuse overlays if necessary
-Perhaps use the message text as a hint to enhance highlighting."
-  (save-excursion
-    (goto-char (point-min))
-    (let ((line-no (flymake-ler-line diagnostic)))
-      (forward-line (1- line-no))
-      (pcase-let* ((beg (progn (back-to-indentation) (point)))
-                   (end (progn
-                          (end-of-line)
-                          (skip-chars-backward " \t\f\t\n" beg)
-                          (if (eq (point) beg)
-                              (line-beginning-position 2)
-                            (point))))
-                   (tooltip-text (flymake-ler-text diagnostic))
-                   (`(,face ,bitmap)
-                    (if (equal "e" (flymake-ler-type diagnostic))
-                        (list 'flymake-errline flymake-error-bitmap)
-                      (list 'flymake-warnline flymake-warning-bitmap))))
-        (flymake--place-overlay beg end tooltip-text face bitmap 
diagnostic)))))
+  "Highlight buffer with info in DIAGNOSTIC."
+  (when-let* ((region (flymake--diag-region diagnostic))
+              (ov (make-overlay (car region) (cdr region))))
+    ;; First set `category' in the overlay, then copy over every other
+    ;; property.
+    ;;
+    (let ((alist (assoc-default (flymake--diag-type diagnostic)
+                                flymake-diagnostic-types-alist)))
+      (overlay-put ov 'category (assoc-default 'flymake-category alist))
+      (cl-loop for (k . v) in alist
+               unless (eq k 'category)
+               do (overlay-put ov k v)))
+    ;; Now ensure some essential defaults are set
+    ;;
+    (cl-flet ((default-maybe
+                (prop value)
+                (unless (or (plist-member (overlay-properties ov) prop)
+                            (let ((cat (overlay-get ov
+                                                    'flymake-category)))
+                              (and cat
+                                   (plist-member (symbol-plist cat) prop))))
+                  (overlay-put ov prop value))))
+      (default-maybe 'bitmap flymake-error-bitmap)
+      (default-maybe 'before-string
+        (flymake--fringe-overlay-spec
+         (overlay-get ov 'bitmap)))
+      (default-maybe 'help-echo
+        (lambda (_window _ov pos)
+          (mapconcat
+           (lambda (ov)
+             (let ((diag (overlay-get ov 'flymake--diagnostic)))
+               (flymake--diag-text diag)))
+           (flymake--overlays :beg pos)
+           "\n")))
+      (default-maybe 'severity (warning-numeric-level :error))
+      (default-maybe 'priority (+ 100 (overlay-get ov 'severity))))
+    ;; Some properties can't be overriden
+    ;;
+    (overlay-put ov 'evaporate t)
+    (overlay-put ov 'flymake-overlay t)
+    (overlay-put ov 'flymake--diagnostic diagnostic)))
+
 
 (defvar-local flymake-is-running nil
   "If t, flymake syntax check process is running for the current buffer.")
@@ -273,17 +377,17 @@ Perhaps use the message text as a hint to enhance 
highlighting."
   "Pop up a menu with errors/warnings for current line."
   (interactive (list last-nonmenu-event))
   (let* ((diag-overlays (or
-                         (flymake--overlays 'flymake--diagnostic nil
-                                            (line-beginning-position)
-                                            (line-end-position))
+                         (flymake--overlays :filter 'flymake--diagnostic
+                                            :beg (line-beginning-position)
+                                            :end (line-end-position))
                          (user-error "No flymake problem for current line")))
          (menu (mapcar (lambda (ov)
                          (let ((diag (overlay-get ov 'flymake--diagnostic)))
                            (cons (format "%s - %s(%s)"
-                                         (flymake-ler-text diag)
-                                         (or (flymake-ler-file diag)
+                                         (flymake--diag-text diag)
+                                         (or (flymake--diag-file diag)
                                              "(no file)")
-                                         (or (flymake-ler-line diag)
+                                         (or (flymake--diag-line diag)
                                              "?"))
                                  ov)))
                        diag-overlays))
@@ -294,8 +398,8 @@ Perhaps use the message text as a hint to enhance 
highlighting."
                               diag-overlays))
          (title (format "Line %d: %d error(s), %d other(s)"
                         (line-number-at-pos)
-                        (cl-count-if #'flymake-ler-errorp diagnostics)
-                        (cl-count-if-not #'flymake-ler-errorp diagnostics)))
+                        (cl-count-if #'flymake--diag-errorp diagnostics)
+                        (cl-count-if-not #'flymake--diag-errorp diagnostics)))
          (choice (x-popup-menu event (list title (cons "" menu)))))
     (flymake-log 3 "choice=%s" choice)
     ;; FIXME: What is the point of going to the problem locus if we're
@@ -338,8 +442,8 @@ Perhaps use the message text as a hint to enhance 
highlighting."
 
 (defun flymake--fix-line-numbers (diagnostic)
   "Ensure DIAGNOSTIC has sensible error lines"
-  (setf (flymake-ler-line diagnostic)
-        (min (max (flymake-ler-line diagnostic)
+  (setf (flymake--diag-line diagnostic)
+        (min (max (flymake--diag-line diagnostic)
                   1)
              (line-number-at-pos (point-max) 'absolute))))
 
@@ -349,8 +453,8 @@ Perhaps use the message text as a hint to enhance 
highlighting."
     (flymake-delete-own-overlays)
     (mapc #'flymake--fix-line-numbers diagnostics)
     (mapc #'flymake--highlight-line diagnostics)
-    (let ((err-count (cl-count-if #'flymake-ler-errorp diagnostics))
-          (warn-count (cl-count-if-not #'flymake-ler-errorp diagnostics)))
+    (let ((err-count (cl-count-if #'flymake--diag-errorp diagnostics))
+          (warn-count (cl-count-if-not #'flymake--diag-errorp diagnostics)))
       (when flymake-check-start-time
         (flymake-log 2 "%s: %d error(s), %d other(s) in %.2f second(s)"
                      (buffer-name) err-count warn-count
@@ -447,11 +551,12 @@ Perhaps use the message text as a hint to enhance 
highlighting."
   "Go to next, or Nth next, flymake error in buffer."
   (interactive (list 1 t))
   (let* ((n (or n 1))
-        (ovs (flymake--overlays 'flymake--diagnostic
-                                (if (cl-plusp n) #'< #'>)))
-        (chain (cl-member-if (lambda (ov)
-                               (if (cl-plusp n)
-                                   (> (overlay-start ov)
+         (ovs (flymake--overlays :filter 'flymake--diagnostic
+                                 :compare (if (cl-plusp n) #'< #'>)
+                                 :key #'overlay-start))
+         (chain (cl-member-if (lambda (ov)
+                                (if (cl-plusp n)
+                                    (> (overlay-start ov)
                                        (point))
                                  (< (overlay-start ov)
                                      (point))))