bug#25022: 25.1.50; Different highlighting for different citation level in message-mode

[Hong Xu]

message-cited-text-color.png
Description: PNG image

On 2016-11-24 Thu 15:22 GMT-0800, Hong Xu <hong@topbug.net> wrote:

> Currently in message-mode all cited texts are highlighted in the same
> way. It would be nicer if the highlighting of different citation levels
> can be easily customized.
>

Here is a patch and a screenshot. The default colors I chose may not be
optimal -- but I guess I'll leave that part to professionals.

Add support for different faces for different citation levels in message-mode.

        * message.el (message-font-lock-keywords)
        (message-font-lock-make-cited-text-matcher): Add support for
        different faces for different citation levels.  The faces are
        defined in the faces named `message-cited-text-N': N of the
        Mth citation level will be M mod 4.
        (message-cited-text-1, message-cited-text-2)
        (message-cited-text-3, message-cited-text-4): Add customization
        for the faces of 4 different citation level.  In the future, the
        number of faces may increase, as the code is flexible enough to
        automatically deal with that.
        (message-cite-level-function): Add a function to customize the
        determination of cite levels given the prefix of the cited text.

diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 448ba7b99718..a61ced374aaf 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -649,6 +649,11 @@ message-cite-prefix-regexp
               (setq gnus-message-cite-prefix-regexp
                     (concat "^\\(?:" value "\\)"))))))
 
+(defcustom message-cite-level-function
+  (lambda (s) (cl-count ?> s))
+  "A function to determine the level of cited text.  The function
+  accepts 1 parameter which is the matched prefix.")
+
 (defcustom message-cancel-message "I am canceling my own article.\n"
   "Message to be inserted in the cancel message."
   :group 'message-interface
@@ -1548,18 +1553,57 @@ message-separator
 (put 'message-separator-face 'face-alias 'message-separator)
 (put 'message-separator-face 'obsolete-face "22.1")
 
-(defface message-cited-text
+(defface message-cited-text-1
   '((((class color)
       (background dark))
      (:foreground "LightPink1"))
     (((class color)
       (background light))
-     (:foreground "red"))
+     (:foreground "red1"))
+    (t
+     (:bold t)))
+  "Face used for displaying 1st-level cited text."
+  :group 'message-faces)
+
+(defface message-cited-text-2
+  '((((class color)
+      (background dark))
+     (:foreground "forest green"))
+    (((class color)
+      (background light))
+     (:foreground "red4"))
     (t
      (:bold t)))
-  "Face used for displaying cited text names."
+  "Face used for displaying 2nd-level cited text."
   :group 'message-faces)
+
+(defface message-cited-text-3
+  '((((class color)
+      (background dark))
+     (:foreground "goldenrod3"))
+    (((class color)
+      (background light))
+     (:foreground "OliveDrab4"))
+    (t
+     (:bold t)))
+  "Face used for displaying 3rd-level cited text."
+  :group 'message-faces)
+
+(defface message-cited-text-4
+  '((((class color)
+      (background dark))
+     (:foreground "chocolate3"))
+    (((class color)
+      (background light))
+     (:foreground "SteelBlue4"))
+    (t
+     (:bold t)))
+  "Face used for displaying 4th-level cited text."
+  :group 'message-faces)
+
 ;; backward-compatibility alias
+(put 'message-cited-text 'face-alias 'message-cited-text-1)
+(put 'message-cited-text 'obsolete-face "26.1")
 (put 'message-cited-text-face 'face-alias 'message-cited-text)
 (put 'message-cited-text-face 'obsolete-face "22.1")
 
@@ -1596,45 +1640,83 @@ message-font-lock-make-header-matcher
        (byte-compile form)
       form)))
 
+(defun message-font-lock-make-cited-text-matcher (level maxlevel)
+  "Generate the matcher for cited text.  LEVEL is the citation
+level to be matched and MAXLEVEL is the number of levels
+specified in the faces `message-cited-text-*'."
+  (byte-compile
+   `(lambda (limit)
+      (let (matched)
+        ;; Keep search until `message-cite-level-function' returns the level
+        ;; we want to match.
+        (while
+            (and (re-search-forward (concat "^\\("
+                                            message-cite-prefix-regexp
+                                            "\\).*")
+                                    limit t)
+                 (not (setq matched
+                            (save-match-data
+                              (= ,(1- level)
+                                 (mod
+                                  (1- (funcall message-cite-level-function
+                                               (match-string 1)))
+                                  ,maxlevel)))))))
+        matched))))
+
 (defvar message-font-lock-keywords
-  (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
-    `((,(message-font-lock-make-header-matcher
-        (concat "^\\([Tt]o:\\)" content))
-       (1 'message-header-name)
-       (2 'message-header-to nil t))
-      (,(message-font-lock-make-header-matcher
-        (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
-       (1 'message-header-name)
-       (2 'message-header-cc nil t))
-      (,(message-font-lock-make-header-matcher
-        (concat "^\\([Ss]ubject:\\)" content))
-       (1 'message-header-name)
-       (2 'message-header-subject nil t))
-      (,(message-font-lock-make-header-matcher
-        (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
-       (1 'message-header-name)
-       (2 'message-header-newsgroups nil t))
-      (,(message-font-lock-make-header-matcher
-        (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
-       (1 'message-header-name)
-       (2 'message-header-xheader))
-      (,(message-font-lock-make-header-matcher
-        (concat "^\\([A-Z][^: \n\t]+:\\)" content))
-       (1 'message-header-name)
-       (2 'message-header-other nil t))
-      ,@(if (and mail-header-separator
-                (not (equal mail-header-separator "")))
-           `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
-              1 'message-separator))
-         nil)
-      ((lambda (limit)
-        (re-search-forward (concat "^\\("
-                                   message-cite-prefix-regexp
-                                   "\\).*")
-                           limit t))
-       (0 'message-cited-text))
-      ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>"
-       (0 'message-mml))))
+  (nconc
+   (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
+     `((,(message-font-lock-make-header-matcher
+          (concat "^\\([Tt]o:\\)" content))
+        (1 'message-header-name)
+        (2 'message-header-to nil t))
+       (,(message-font-lock-make-header-matcher
+          (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
+        (1 'message-header-name)
+        (2 'message-header-cc nil t))
+       (,(message-font-lock-make-header-matcher
+          (concat "^\\([Ss]ubject:\\)" content))
+        (1 'message-header-name)
+        (2 'message-header-subject nil t))
+       (,(message-font-lock-make-header-matcher
+          (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
+        (1 'message-header-name)
+        (2 'message-header-newsgroups nil t))
+       (,(message-font-lock-make-header-matcher
+          (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
+        (1 'message-header-name)
+        (2 'message-header-xheader))
+       (,(message-font-lock-make-header-matcher
+          (concat "^\\([A-Z][^: \n\t]+:\\)" content))
+        (1 'message-header-name)
+        (2 'message-header-other nil t))
+       ,@(if (and mail-header-separator
+                  (not (equal mail-header-separator "")))
+             `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+                1 'message-separator))
+           nil)
+       ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>"
+        (0 'message-mml))))
+   ;; Additional font locks to highlight different levels of cited text
+   (let ((maxlevel 1)
+         (level 1)
+         cited-text-face
+         keywords)
+     ;; Compute the max level.
+     (while (setq cited-text-face
+                  (intern-soft (format "message-cited-text-%d" maxlevel)))
+       (setq maxlevel (1+ maxlevel)))
+     (setq maxlevel (1- maxlevel))
+     ;; Generate the keywords.
+     (while (setq cited-text-face
+                  (intern-soft (format "message-cited-text-%d" level)))
+       (setq keywords
+             (cons
+              `(,(message-font-lock-make-cited-text-matcher level maxlevel)
+                (0 ',cited-text-face))
+              keywords))
+       (setq level (1+ level)))
+     keywords))
   "Additional expressions to highlight in Message mode.")
 
 (defvar message-face-alist

signature.asc
Description: PGP signature