Fancy Flymake mode-line construct displays status

Imitates compilation-mode's mode-line a bit, and uses its faces.

* lisp/progmodes/flymake.el
(flymake-error, flymake-warning, flymake-note): Add
mode-line-face to these flymake error types.
(flymake-note): Notes don't need a noisy fringe bitmap.
(flymake-lighter): Delete.
(flymake--update-lighter): Delete.
(flymake--mode-line-format): New function and variable.
(flymake--diagnostics-table): New buffer-local variable.
(flymake--handle-report): Don't update "lighters".  Affect
flymake--diagnostics-table.
(flymake--run-backend): Init flymake--diagnostics-table for backend.
(flymake-mode): Use flymake--mode-line-format.
(flymake-mode): Don't update lighter.
(flymake--highlight-line): Be more careful when overriding a
nil default overlay property.

1 files changed, 112 insertions, 22 deletions

diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index f136e14ec19..03b319f8715 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -35,7 +35,8 @@
 (require 'cl-lib)
 (require 'thingatpt) ; end-of-thing
 (require 'warnings) ; warning-numeric-level, display-warning
-(eval-when-compile (require 'subr-x)) ; when-let*, if-let*
+(require 'compile) ; for some faces
+(eval-when-compile (require 'subr-x)) ; when-let*, if-let*, hash-table-keys
 
 (defgroup flymake nil
   "Universal on-the-fly syntax checker."
@@ -362,20 +363,23 @@ the diagnostics of each type.  The recognized properties are:
 (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 'bitmap nil)
 (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
-`flymake-category', return DEFAULT."
+`flymake-diagnostic-types-alist' or in the symbol of its
+associated `flymake-category' return DEFAULT."
   (let ((alist-probe (assoc type flymake-diagnostic-types-alist)))
     (cond (alist-probe
            (let* ((alist (cdr alist-probe))
@@ -496,16 +500,6 @@ If TYPE doesn't declare PROP in either
     ;;
     (when choice (goto-char (overlay-start choice)))))
 
-;; flymake minor mode declarations
-(defvar-local flymake-lighter nil)
-
-(defun flymake--update-lighter (info &optional extended)
-  "Update Flymake’s \"lighter\" with INFO and EXTENDED."
-  (setq flymake-lighter (format " Flymake(%s%s)"
-                                info
-                                (if extended
-                                    (format ",%s" extended)
-                                  ""))))
 
 ;; Nothing in flymake uses this at all any more, so this is just for
 ;; third-party compatibility.
@@ -520,6 +514,9 @@ that has been invoked but hasn't reported any final status yet.")
   "List of currently disabled flymake backends.
 A backend is disabled if it reported `:panic'.")
 
+(defvar-local flymake--diagnostics-table nil
+  "Hash table of all diagnostics indexed by backend.")
+
 (defun flymake-is-running ()
   "Tell if flymake has running backends in this buffer"
   flymake--running-backends)
@@ -547,6 +544,7 @@ A backend is disabled if it reported `:panic'.")
            (eq backend
                (flymake--diag-backend
                 (overlay-get ov 'flymake--diagnostic)))))
+        (puthash backend diagnostics flymake--diagnostics-table)
         (mapc (lambda (diag)
                 (flymake--highlight-line diag)
                 (setf (flymake--diag-backend diag) backend))
@@ -557,11 +555,7 @@ A backend is disabled if it reported `:panic'.")
           (when flymake-check-start-time
             (flymake-log 2 "%d error(s), %d other(s) in %.2f second(s)"
                          err-count warn-count
-                         (- (float-time) flymake-check-start-time)))
-          (if (null diagnostics)
-              (flymake--update-lighter "[ok]")
-            (flymake--update-lighter
-             (format "%d/%d" err-count warn-count)))))))
+                         (- (float-time) flymake-check-start-time)))))))
    (t
     (flymake--disable-backend "?"
                               :strange
@@ -584,6 +578,7 @@ sources."
 (defun flymake--run-backend (backend)
   "Run the backend BACKEND."
   (push backend flymake--running-backends)
+  (remhash backend flymake--diagnostics-table)
   ;; FIXME: Should use `condition-case-unless-debug'
   ;; here, but that won't let me catch errors during
   ;; testing where `debug-on-error' is always t
@@ -621,7 +616,7 @@ non-nil."
 
 ;;;###autoload
 (define-minor-mode flymake-mode nil
-  :group 'flymake :lighter flymake-lighter
+  :group 'flymake :lighter flymake--mode-line-format
   (setq flymake--running-backends nil
         flymake--disabled-backends nil)
   (cond
@@ -635,10 +630,9 @@ non-nil."
       (add-hook 'after-save-hook 'flymake-after-save-hook nil t)
       (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t)
 
-      (flymake--update-lighter "*" "*")
-
       (setq flymake-timer
             (run-at-time nil 1 'flymake-on-timer-event (current-buffer)))
+      (setq flymake--diagnostics-table (make-hash-table))
 
       (when flymake-start-syntax-check-on-find-file
         (flymake--start-syntax-check)))))
@@ -757,6 +751,102 @@ diagnostics of type `:error' and `:warning'."
                      t))
   (flymake-goto-next-error (- (or n 1)) filter interactive))
 
+
+;;; Mode-line fanciness
+;;;
+(defvar flymake--mode-line-format `(:eval (flymake--mode-line-format)))
+
+(put 'flymake--mode-line-format 'risky-local-variable t)
+
+(defun flymake--mode-line-format ()
+  "Produce a pretty minor mode indicator."
+  (let ((running flymake--running-backends)
+        (reported (hash-table-keys flymake--diagnostics-table)))
+    `((:propertize " Flymake"
+                   mouse-face mode-line-highlight
+                   ,@(when (not reported)
+                       `(face compilation-mode-line-fail))
+                   help-echo
+                   ,(concat (format "%s registered backends\n"
+                                    (length flymake-diagnostic-functions))
+                            (format "%s running\n"
+                                    (length running))
+                            (format "%s disabled\n"
+                                    (length flymake--disabled-backends))
+                            "mouse-1: go to log buffer ")
+                   keymap
+                   ,(let ((map (make-sparse-keymap)))
+                      (define-key map [mode-line mouse-1]
+                        (lambda (_event)
+                          (interactive "e")
+                          (switch-to-buffer "*Flymake log*")))
+                      map))
+      ,@(when running
+          `(":" (:propertize "Run"
+                             face compilation-mode-line-run
+                             help-echo
+                             ,(format "%s running backends"
+                                      (length running)))))
+      ,@(when reported
+          (let ((by-type (make-hash-table)))
+            (maphash (lambda (_backend diags)
+                       (mapc (lambda (diag)
+                               (push diag
+                                     (gethash (flymake--diag-type diag)
+                                              by-type)))
+                             diags))
+                     flymake--diagnostics-table)
+            (cl-loop
+             for (type . severity)
+             in (cl-sort (mapcar (lambda (type)
+                                   (cons type (flymake--lookup-type-property
+                                               type
+                                               'severity
+                                               (warning-numeric-level :error))))
+                                 (cl-union (hash-table-keys by-type)
+                                           '(:error :warning)))
+                         #'>
+                         :key #'cdr)
+             for diags = (gethash type by-type)
+             for face = (flymake--lookup-type-property type
+                                                       'mode-line-face
+                                                       'compilation-error)
+             when (or diags
+                      (>= severity (warning-numeric-level :warning)))
+             collect `(:propertize
+                       ,(format "%d" (length diags))
+                       face ,face
+                       mouse-face mode-line-highlight
+                       keymap
+                       ,(let ((map (make-sparse-keymap))
+                              (type type))
+                          (define-key map [mode-line mouse-4]
+                            (lambda (_event)
+                              (interactive "e")
+                              (flymake-goto-prev-error 1 (list type) t)))
+                          (define-key map [mode-line mouse-5]
+                            (lambda (_event)
+                              (interactive "e")
+                              (flymake-goto-next-error 1 (list type) t)))
+                          map)
+                       help-echo
+                       ,(concat (format "%s diagnostics of type %s\n"
+                                        (propertize (format "%d"
+                                                            (length diags))
+                                                    'face face)
+                                        (propertize (format "%s" type)
+                                                    'face face))
+                                "mouse-4/mouse-5: previous/next of this type\n"))
+             into forms
+             finally return
+             `((:propertize "[")
+               ,@(cl-loop for (a . rest) on forms by #'cdr
+                          collect a when rest collect
+                          '(:propertize " "))
+               (:propertize "]"))))))))
+
+
+
 
 (provide 'flymake)