Re: Overlay arrow in *compilation* and *grep* buffers

[Juri Linkov <juri@jurta.org>]

> I don't like this change because its not the case that one user wants an arrow
> and another doesn't but rather one context may benefit from an arrow
> (graphical display) while another may not (text terminal).
>
> Previously I have suggested a change that gives compilation-context-lines a
> context dependent values so that the error scrolls to the top of the window on
> a text terminal.  This or a similar change could be generalised to the case of
> no left-fringe which I think could be tested by:
>
> (if (or (not (display-graphic-p))
>         (equal fringe-mode 0)
>         (equal (car fringe-mode) 0))...

Even on text terminals users might prefer not to scroll the window.
Since overlay arrows are problematic on text terminals, there should
be an alternative method of highlighting.  I propose to add one of the
methods of next-error highlighting for compilation messages, i.e. a
persistent overlay fontified in a special face.

The new option compilation-current-message-highlight will support
three values: `arrow', t for highlighting the whole current message
line, and nil to turn all indications off.

The default value can be selected based on the following conditions:

1. When left-fringe is available (tested with a condition like you proposed),
   use an arrow.
2. Otherwise, if compilation-context-lines is nil, highlight the
   current line in a special face with the persistent overlay.
3. If compilation-context-lines is not nil, don't highlight the current
   message since the current message is indicated by its location
   at the top of the window (by default).

There is a brief list of changes in the patch below:

1. New defcustom compilation-current-message-highlight.
2. compilation-context-lines moved up before compilation-context-lines.
3. compilation-highlight-overlay renamed to next-error-highlight-overlay,
   because this overlay is actually used for highlighting source lines
   visited by `next-error'.
4. compilation-highlight-overlay is used for highlighting lines
   in the compilation buffer.
6. The value `fringe-arrow' renamed to more general name `arrow'.

Index: lisp/progmodes/compile.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/progmodes/compile.el,v
retrieving revision 1.353
diff -u -r1.353 compile.el
--- lisp/progmodes/compile.el	7 May 2005 16:18:36 -0000	1.353
+++ lisp/progmodes/compile.el	13 May 2005 04:59:43 -0000
@@ -383,12 +383,38 @@
    "Additional things to highlight in Compilation mode.
 This gets tacked on the end of the generated expressions.")
 
+(defcustom compilation-context-lines 0
+  "*Display this many lines of leading context before message.
+If nil, don't scroll the compilation output window."
+  :type '(choice integer (const :tag "No window scrolling" nil))
+  :group 'compilation
+  :version "22.1")
+
 (defvar compilation-highlight-regexp t
   "Regexp matching part of visited source lines to highlight temporarily.
 Highlight entire line if t; don't highlight source lines if nil.")
 
 (defvar compilation-highlight-overlay nil
-  "Overlay used to temporarily highlight compilation matches.")
+  "Overlay used to highlight the current message in the compilation buffer.")
+
+(defcustom compilation-current-message-highlight
+  (if (and (or (not (display-graphic-p))
+	       (equal fringe-mode 0)
+	       (equal (car-safe fringe-mode) 0)))
+      (not compilation-context-lines)
+    'arrow)
+  "*Highlighting of the current message in the compilation buffer.
+If t, highlight the current message with `compilation-current-message-face'.
+If nil, don't highlight the message in the compilation buffer.
+If `arrow', indicate the current message by the fringe or overlay arrow.
+
+The default is `arrow' when left fringe arrow is displayable.  Otherwise,
+the default is t when compilation-context-lines is nil."
+  :type '(choice (const :tag "Highligh whole line" t)
+                 (const :tag "No highlighting" nil)
+                 (const :tag "Arrow" 'arrow))
+  :group 'compilation
+  :version "22.1")
 
 (defcustom compilation-error-screen-columns t
   "*If non-nil, column numbers in error messages are screen columns.
@@ -491,6 +517,10 @@
 `compilation-info-face', `compilation-line-face' and
 `compilation-column-face' get prepended to this, when applicable.")
 
+(defvar compilation-current-message-face 'region
+  "Face name to use for the current message selected by `next-error'.
+Used when `compilation-current-message-highlight' is t.")
+
 (defvar compilation-error-face 'font-lock-warning-face
   "Face name to use for file name in error messages.")
 
@@ -1248,7 +1278,7 @@
   (make-local-variable 'compilation-error-screen-columns)
   (make-local-variable 'overlay-arrow-position)
   (set (make-local-variable 'overlay-arrow-string)
-       (if (display-graphic-p) "=>" ""))
+       (if (eq compilation-current-message-highlight 'arrow) "=>" ""))
   (setq next-error-overlay-arrow-position nil)
   (add-hook 'kill-buffer-hook
 	    (lambda () (setq next-error-overlay-arrow-position nil)) nil t)
@@ -1506,11 +1536,24 @@
 	 (end-loc (nth 2 loc))
 	 (marker (point-marker)))
     (setq compilation-current-error (point-marker)
-	  overlay-arrow-position
-	    (if (bolp)
-		compilation-current-error
-	      (copy-marker (line-beginning-position)))
 	  loc (car loc))
+    (cond ((eq compilation-current-message-highlight 'arrow)
+	   (setq overlay-arrow-position
+		 (if (bolp)
+		     compilation-current-error
+		   (copy-marker (line-beginning-position)))))
+	  ((eq compilation-current-message-highlight t)
+	   (unless compilation-highlight-overlay
+	     (setq compilation-highlight-overlay
+		   (make-overlay (point-min) (point-min)))
+	     (overlay-put compilation-highlight-overlay 'face 'match))
+	   (move-overlay compilation-highlight-overlay
+			 (copy-marker (line-beginning-position))
+			 (copy-marker (line-end-position))
+			 (current-buffer)))
+	  ((not compilation-current-message-highlight)
+	   (if compilation-highlight-overlay
+	       (delete-overlay compilation-highlight-overlay))))
     ;; If loc contains no marker, no error in that file has been visited.  If
     ;; the marker is invalid the buffer has been killed.  So, recalculate all
     ;; markers for that file.
@@ -1575,13 +1618,6 @@
       (setcdr loc (list line file marker)))
     loc))
 
-(defcustom compilation-context-lines 0
-  "*Display this many lines of leading context before message.
-If nil, don't scroll the compilation output window."
-  :type '(choice integer (const :tag "No window scrolling" nil))
-  :group 'compilation
-  :version "22.1")
-
 (defsubst compilation-set-window (w mk)
   "Align the compilation output window W with marker MK near top."
   (if (integerp compilation-context-lines)
@@ -1591,8 +1627,6 @@
                             (point))))
   (set-window-point w mk))
 
-(defvar next-error-highlight-timer)
-
 (defun compilation-goto-locus (msg mk end-mk)
   "Jump to an error corresponding to MSG at MK.
 All arguments are markers.  If END-MK is non-nil, mark is set there
@@ -1636,10 +1670,10 @@
     (when highlight-regexp
       (if (timerp next-error-highlight-timer)
 	  (cancel-timer next-error-highlight-timer))
-      (unless compilation-highlight-overlay
-	(setq compilation-highlight-overlay
+      (unless next-error-highlight-overlay
+	(setq next-error-highlight-overlay
 	      (make-overlay (point-min) (point-min)))
-	(overlay-put compilation-highlight-overlay 'face 'next-error))
+	(overlay-put next-error-highlight-overlay 'face 'next-error))
       (with-current-buffer (marker-buffer mk)
 	(save-excursion
 	  (if end-mk (goto-char end-mk) (end-of-line))
@@ -1649,19 +1683,19 @@
 		     (re-search-forward highlight-regexp end t))
 		(progn
 		  (goto-char (match-beginning 0))
-		  (move-overlay compilation-highlight-overlay
+		  (move-overlay next-error-highlight-overlay
 				(match-beginning 0) (match-end 0)
 				(current-buffer)))
-	      (move-overlay compilation-highlight-overlay
+	      (move-overlay next-error-highlight-overlay
 			    (point) end (current-buffer)))
 	    (if (numberp next-error-highlight)
 		(setq next-error-highlight-timer
 		      (run-at-time next-error-highlight nil 'delete-overlay
-				   compilation-highlight-overlay)))
+				   next-error-highlight-overlay)))
 	    (if (not (or (eq next-error-highlight t)
 			 (numberp next-error-highlight)))
-		(delete-overlay compilation-highlight-overlay))))))
-    (when (and (eq next-error-highlight 'fringe-arrow))
+		(delete-overlay next-error-highlight-overlay))))))
+    (when (and (eq next-error-highlight 'arrow))
       (setq next-error-overlay-arrow-position
 	    (copy-marker (line-beginning-position))))))

Index: lisp/simple.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/simple.el,v
retrieving revision 1.720
diff -u -r1.720 simple.el
--- lisp/simple.el	8 May 2005 19:33:14 -0000	1.720
+++ lisp/simple.el	13 May 2005 04:55:15 -0000
@@ -89,11 +89,11 @@
 If number, highlight the locus in next-error face for given time in seconds.
 If t, use persistent overlays fontified in next-error face.
 If nil, don't highlight the locus in the source buffer.
-If `fringe-arrow', indicate the locus by the fringe arrow."
+If `arrow', indicate the locus by the fringe or overlay arrow."
   :type '(choice (number :tag "Delay")
                  (const :tag "Persistent overlay" t)
                  (const :tag "No highlighting" nil)
-                 (const :tag "Fringe arrow" 'fringe-arrow))
+                 (const :tag "Arrow" 'arrow))
   :group 'next-error
   :version "22.1")
 
@@ -102,14 +102,17 @@
 If number, highlight the locus in next-error face for given time in seconds.
 If t, use persistent overlays fontified in next-error face.
 If nil, don't highlight the locus in the source buffer.
-If `fringe-arrow', indicate the locus by the fringe arrow."
+If `arrow', indicate the locus by the fringe or overlay arrow."
   :type '(choice (number :tag "Delay")
                  (const :tag "Persistent overlay" t)
                  (const :tag "No highlighting" nil)
-                 (const :tag "Fringe arrow" 'fringe-arrow))
+                 (const :tag "Arrow" 'arrow))
   :group 'next-error
   :version "22.1")
 
+(defvar next-error-highlight-overlay nil
+  "Overlay used to highlight next-error matches.")
+
 (defvar next-error-highlight-timer nil)
 
 (defvar next-error-overlay-arrow-position nil)

-- 
Juri Linkov
http://www.jurta.org/emacs/