Subject: 29.0.50; [PATCH] Turning off compilation-minor-mode removes fontification of other modes

From: [email-masked]
Date: Fri, 14 Oct 2022 17:15:24 +0200

I propose the attached patch, which fixes the following problem:

1. M-x shell
2. grep -R -n --color=always 'some-search-string-which-yeilds-resuts'
   File names and line numbers output by grep should be in color
3. M-x compilation-shell-minor-mode
   File names and line numbers are now underlined by compile.el
4. M-x compilation-shell-minor-mode, to turn it back off

File names and line numbers lose their fontification completely, that
is, they are now in the default face.

The attached patch makes them return to the face they had after step 2,
as specified by the grep command. It also "name-spaces" other text
properties used by compile.el, such as keymap and mouse-face. If other
minor or major modes make use of these text properties, turning off
compilation-shell-minor-mode or compilation-minor-mode should now leave
them alone. (Though the ones from compile.el take precedence as long as
compilation-*-mode is active.)
From 0b60dc0bfbe22dd8c570fab25b6ae1087da76022 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Miha=20Rihtar=C5=A1i=C4=8D?= <[email-masked]>
Date: Fri, 14 Oct 2022 14:58:44 +0200
Subject: [PATCH] compile.el: Don't clobber text properties of other modes

* lisp/progmodes/compile.el (compilation-mode-font-lock-keywords):
(compilation-directory-properties):
(compilation-internal-error-properties):
(compilation-parse-errors):
(compilation--remove-properties): Don't modify 'font-lock-face' and
other public text properties directly.  Modify the private
'compilation-face' property instead.

(compilation-setup): Set up 'compilation-face' text property up as an
alias to the 'font-lock-face', and similarly for the other private
compilation text properties.

(compilation--unsetup): Remove the text property aliases.
---
 lisp/progmodes/compile.el | 90 ++++++++++++++++++---------------------
 1 file changed, 42 insertions(+), 48 deletions(-)

diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 6473b50778..c543d40d64 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -762,10 +762,10 @@ compilation-mode-font-lock-keywords
       (1 font-lock-function-name-face) (3 compilation-line-face nil t))
      (" --?o\\(?:utfile\\|utput\\)?[= ]\\(\\S +\\)" . 1)
      ("^Compilation \\(finished\\).*"
-      (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
+      (0 '(face nil compilation-message nil compilation-help-echo nil compilation-mouse-face nil) t)
       (1 compilation-info-face))
      ("^Compilation \\(exited abnormally\\|interrupt\\|killed\\|terminated\\|segmentation fault\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
-      (0 '(face nil compilation-message nil help-echo nil mouse-face nil) t)
+      (0 '(face nil compilation-message nil compilation-help-echo nil compilation-mouse-face nil) t)
       (1 compilation-error-face)
       (2 compilation-error-face nil t)))
    "Additional things to highlight in Compilation mode.
@@ -1185,9 +1185,9 @@ compilation-directory-properties
   (let ((dir (compilation--previous-directory (match-beginning 0))))
     (setq dir (if dir (or (get-text-property (1- dir) 'compilation-directory)
 			  (get-text-property dir 'compilation-directory))))
-    `(font-lock-face ,(if leave
-                          compilation-leave-directory-face
-                        compilation-enter-directory-face)
+    `(compilation-face ,(if leave
+                            compilation-leave-directory-face
+                          compilation-enter-directory-face)
       compilation-directory ,(if leave
                                  (or (cdr dir)
                                      '(nil)) ; nil only isn't a property-change
@@ -1195,9 +1195,9 @@ compilation-directory-properties
       ;; Place a `compilation-message' everywhere we change text-properties
       ;; so compilation--remove-properties can know what to remove.
       compilation-message ,(compilation--make-message nil 0 nil nil)
-      mouse-face highlight
-      keymap compilation-button-map
-      help-echo "mouse-2: visit destination directory")))
+      compilation-mouse-face highlight
+      compilation-keymap compilation-button-map
+      compilation-help-echo "mouse-2: visit destination directory")))
 
 ;; Data type `reverse-ordered-alist' retriever.  This function retrieves the
 ;; KEY element from the ALIST, creating it in the right position if not already
@@ -1467,15 +1467,15 @@ compilation-internal-error-properties
                                               end-marker))))
 
     ;; Must start with face
-    `(font-lock-face ,compilation-message-face
+    `(compilation-face ,compilation-message-face
       compilation-message ,(compilation--make-message loc type end-loc rule)
-      help-echo ,(if col
-                     "mouse-2: visit this file, line and column"
-                   (if line
-                       "mouse-2: visit this file and line"
-                     "mouse-2: visit this file"))
-      keymap compilation-button-map
-      mouse-face highlight)))
+      compilation-help-echo ,(if col
+                                 "mouse-2: visit this file, line and column"
+                               (if line
+                                   "mouse-2: visit this file and line"
+                                 "mouse-2: visit this file"))
+      compilation-keymap compilation-button-map
+      compilation-mouse-face highlight)))
 
 (defun compilation--put-prop (matchnum prop val)
   (when (and (integerp matchnum) (match-beginning matchnum))
@@ -1485,30 +1485,11 @@ compilation--put-prop
 
 (defun compilation--remove-properties (&optional start end)
   (with-silent-modifications
-    ;; When compile.el used font-lock directly, we could just remove all
-    ;; our text-properties in one go, but now that we manually place
-    ;; font-lock-face, we have to be careful to only remove the font-lock-face
-    ;; we placed.
-    ;; (remove-list-of-text-properties
-    ;;  (or start (point-min)) (or end (point-max))
-    ;;  '(compilation-debug compilation-directory compilation-message
-    ;;    font-lock-face help-echo mouse-face))
-    (let (next)
-      (unless start (setq start (point-min)))
-      (unless end (setq end (point-max)))
-      (compilation--flush-directory-cache start end)
-      (while
-          (progn
-            (setq next (or (next-single-property-change
-                            start 'compilation-message nil end)
-                           end))
-            (when (get-text-property start 'compilation-message)
-              (remove-list-of-text-properties
-               start next
-               '(compilation-debug compilation-directory compilation-message
-                 font-lock-face help-echo mouse-face)))
-            (< next end))
-        (setq start next)))))
+    (remove-list-of-text-properties
+     (or start (point-min)) (or end (point-max))
+     '( compilation-debug compilation-directory compilation-message
+        compilation-face compilation-help-echo compilation-keymap
+        compilation-mouse-face))))
 
 (defun compilation--parse-region (start end)
   (goto-char end)
@@ -1609,21 +1590,21 @@ compilation-parse-errors
                 (compilation--note-type this-type)
 
                 (compilation--put-prop
-                 file 'font-lock-face
+                 file 'compilation-face
                  (symbol-value (aref [compilation-info-face
                                       compilation-warning-face
                                       compilation-error-face]
                                      this-type)))))
 
             (compilation--put-prop
-             line 'font-lock-face compilation-line-face)
+             line 'compilation-face compilation-line-face)
             (compilation--put-prop
-             end-line 'font-lock-face compilation-line-face)
+             end-line 'compilation-face compilation-line-face)
 
             (compilation--put-prop
-             col 'font-lock-face compilation-column-face)
+             col 'compilation-face compilation-column-face)
             (compilation--put-prop
-             end-col 'font-lock-face compilation-column-face)
+             end-col 'compilation-face compilation-column-face)
 
             ;; Obey HIGHLIGHT.
             (dolist (extra-item (nthcdr 6 item))
@@ -1635,12 +1616,12 @@ compilation-parse-errors
                      ((or (symbolp face) (stringp face))
                       (put-text-property
                        (match-beginning mn) (match-end mn)
-                       'font-lock-face face))
+                       'compilation-face face))
 		     ((and (listp face)
 			   (eq (car face) 'face)
 			   (or (symbolp (cadr face))
 			       (stringp (cadr face))))
-                      (compilation--put-prop mn 'font-lock-face (cadr face))
+                      (compilation--put-prop mn 'compilation-face (cadr face))
                       (add-text-properties
                        (match-beginning mn) (match-end mn)
                        (nthcdr 2 face)))
@@ -1657,7 +1638,7 @@ compilation-parse-errors
                (cddr props))
               (font-lock-append-text-property
                (match-beginning mn) (match-end mn)
-               'font-lock-face (cadr props)))))))))
+               'compilation-face (cadr props)))))))))
 
 (defvar-local compilation--parsed -1)
 
@@ -2385,6 +2366,13 @@ compilation-setup
   (add-hook 'before-change-functions #'compilation--flush-parse nil t)
   ;; Also for minor mode, since it's not permanent-local.
   (add-hook 'change-major-mode-hook #'compilation--remove-properties nil t)
+
+  (let ((alist (copy-alist char-property-alias-alist)))
+    (cl-pushnew 'compilation-face (alist-get 'face alist))
+    (cl-pushnew 'compilation-mouse-face (alist-get 'mouse-face alist))
+    (cl-pushnew 'compilation-help-echo (alist-get 'help-echo alist))
+    (cl-pushnew 'compilation-keymap (alist-get 'keymap alist))
+    (setq-local char-property-alias-alist alist))
   (if minor
       (progn
 	(font-lock-add-keywords nil (compilation-mode-font-lock-keywords))
@@ -2394,6 +2382,12 @@ compilation-setup
 (defun compilation--unsetup ()
   ;; Only for minor mode.
   (font-lock-remove-keywords nil (compilation-mode-font-lock-keywords))
+  (let ((alist (copy-alist char-property-alias-alist)))
+    (when-let ((as (assq 'face alist))) (delq 'compilation-face as))
+    (when-let ((as (assq 'mouse-face alist))) (delq 'compilation-mose-face as))
+    (when-let ((as (assq 'help-echo alist))) (delq 'compilation-help-echo as))
+    (when-let ((as (assq 'keymap alist))) (delq 'compilation-keymap as))
+    (setq-local char-property-alias-alist alist))
   (remove-hook 'before-change-functions #'compilation--flush-parse t)
   (kill-local-variable 'compilation--parsed)
   (compilation--remove-properties)
-- 
2.38.0