[Emacs-diffs] master 4c1edb0: Add different faces for different citation levels in Message mode

[Lars Ingebrigtsen]

branch: master
commit 4c1edb0228721c54dff4db6a1df303be3b39aa39
Author: Hong Xu <address@hidden>
Commit: Lars Ingebrigtsen <address@hidden>

    Add 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
    (bug#25022).
---
 lisp/gnus/message.el | 174 +++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 128 insertions(+), 46 deletions(-)

diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index c211bcc..35baae0 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -660,6 +660,12 @@ variable should be a regexp or a list of regexps."
               (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."
+  :type 'function
+  :version "27.1")
+
 (defcustom message-cancel-message "I am canceling my own article.\n"
   "Message to be inserted in the cancel message."
   :group 'message-interface
@@ -1540,18 +1546,58 @@ starting with `not' and followed by regexps."
   "Face used for displaying the separator."
   :group 'message-faces)
 
-(defface message-cited-text
+(defface message-cited-text-1
   '((((class color)
       (background dark))
-     :foreground "LightPink1")
+     (:foreground "LightPink1"))
     (((class color)
       (background light))
-     :foreground "red")
+     (:foreground "red1"))
     (t
-     :bold t))
-  "Face used for displaying cited text names."
+     (: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 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")
+
 (defface message-mml
   '((((class color)
       (background dark))
@@ -1580,48 +1626,84 @@ starting with `not' and followed by regexps."
       (set-match-data (list start (point)))
       (point))))
 
+(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-*'."
+  (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-match-to-eoh
-       (,(concat "^\\([Tt]o:\\)" content)
-       (progn (goto-char (match-beginning 0)) (match-end 0)) nil
-       (1 'message-header-name)
-       (2 'message-header-to nil t))
-       (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)
-       (progn (goto-char (match-beginning 0)) (match-end 0)) nil
-       (1 'message-header-name)
-       (2 'message-header-cc nil t))
-       (,(concat "^\\([Ss]ubject:\\)" content)
-       (progn (goto-char (match-beginning 0)) (match-end 0)) nil
-       (1 'message-header-name)
-       (2 'message-header-subject nil t))
-       (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
-       (progn (goto-char (match-beginning 0)) (match-end 0)) nil
-       (1 'message-header-name)
-       (2 'message-header-newsgroups nil t))
-       (,(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)
-       (progn (goto-char (match-beginning 0)) (match-end 0)) nil
-       (1 'message-header-name)
-       (2 'message-header-xheader))
-       (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
-       (progn (goto-char (match-beginning 0)) (match-end 0)) nil
-        (1 'message-header-name)
-        (2 'message-header-other nil t)))
-      (,(lambda (limit)
-          (and mail-header-separator
-               (not (equal mail-header-separator ""))
-               (re-search-forward
-                (concat "^" (regexp-quote mail-header-separator) "$")
-                limit t)))
-       0 'message-separator)
-      (,(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-match-to-eoh
+       (,(concat "^\\([Tt]o:\\)" content)
+        (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+        (1 'message-header-name)
+        (2 'message-header-to nil t))
+       (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)
+        (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+        (1 'message-header-name)
+        (2 'message-header-cc nil t))
+       (,(concat "^\\([Ss]ubject:\\)" content)
+        (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+        (1 'message-header-name)
+        (2 'message-header-subject nil t))
+       (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)
+        (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+        (1 'message-header-name)
+        (2 'message-header-newsgroups nil t))
+       (,(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)
+        (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+        (1 'message-header-name)
+        (2 'message-header-xheader))
+       (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)
+        (progn (goto-char (match-beginning 0)) (match-end 0)) nil
+         (1 'message-header-name)
+         (2 'message-header-other nil t)))
+       (,(lambda (limit)
+           (and mail-header-separator
+               (not (equal mail-header-separator ""))
+               (re-search-forward
+                 (concat "^" (regexp-quote mail-header-separator) "$")
+                 limit t)))
+       0 'message-separator)
+       ("<#/?\\(?: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