[Emacs-diffs] master 29d1c72: Introduce new value t for compilation-context-lines to eliminate scrolling

[Alan Mackenzie]

branch: master
commit 29d1c72d7c98ea23d5af434c5af6b39a5bd264d9
Author: Alan Mackenzie <address@hidden>
Commit: Alan Mackenzie <address@hidden>

    Introduce new value t for compilation-context-lines to eliminate scrolling
    
    In particular, to prevent scrolling in a window lacking a left fringe.
    Instead, a visible arrow "=>" is inserted before column zero.  This fixes
    bug #36832.
    
    * lisp/progmodes/compile.el (compilation-context-lines): Add the new value 
t.
    (compilation-set-window): Amend to handle compilation-context-lines being t.
    (overlay-arrow-overlay): New variable holding an overlay with before-string
    property "=>".
    (compilation-set-overlay-arrow): New function which manipulates
    overlay-arrow-overlay.
    (compilation-goto-locus, compilation-find-file): In addition to calling
    compilation-set-window, also call compilation-set-overlay-arrow.
    
    * doc/emacs/building.texi (Compilation Mode): Document the new value t which
    compilation-context-lines can take.
    
    * etc/NEWS: Add an entry for this change.
---
 doc/emacs/building.texi   | 11 +++---
 etc/NEWS                  |  5 +++
 lisp/progmodes/compile.el | 90 +++++++++++++++++++++++++++++++++++------------
 3 files changed, 79 insertions(+), 27 deletions(-)

diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi
index 990b82d..f7809d4 100644
--- a/doc/emacs/building.texi
+++ b/doc/emacs/building.texi
@@ -266,11 +266,12 @@ fringe (@pxref{Fringes}), the locus-visiting commands put 
an arrow in
 the fringe, pointing to the current error message.  If the window has
 no left fringe, such as on a text terminal, these commands scroll the
 window so that the current message is at the top of the window.  If
-you change the variable @code{compilation-context-lines} to an integer
-value @var{n}, these commands scroll the window so that the current
-error message is @var{n} lines from the top, whether or not there is a
-fringe; the default value, @code{nil}, gives the behavior described
-above.
+you change the variable @code{compilation-context-lines} to @code{t},
+a visible arrow is inserted before column zero instead.  If you change
+the variable to an integer value @var{n}, these commands scroll the
+window so that the current error message is @var{n} lines from the
+top, whether or not there is a fringe; the default value, @code{nil},
+gives the behavior described above.
 
 @vindex compilation-error-regexp-alist
 @vindex grep-regexp-alist
diff --git a/etc/NEWS b/etc/NEWS
index 1d98cca..a03e202 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -558,6 +558,11 @@ that it doesn't bring any measurable benefit.
 ---
 *** In 'compilation-error-regexp-alist', 'line' (and 'end-line') can
 be functions.
++++
+*** 'compilation-context-lines' can now take the value t; this is like
+nil, but instead of scrolling the current line to the top of the
+screen when there is no left fringe, it inserts a visible arrow before
+column zero.
 
 ** cl-lib.el
 +++
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 4cc1daf..09188dc 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -701,9 +701,8 @@ of `my-compilation-root' here."
 ;;;###autoload
 (defcustom compilation-search-path '(nil)
   "List of directories to search for source files named in error messages.
-Elements should be directory names, not file names of
-directories.  The value nil as an element means the error
-message buffer `default-directory'."
+Elements should be directory names, not file names of directories.
+The value nil as an element means to try the default directory."
   :type '(repeat (choice (const :tag "Default" nil)
                         (string :tag "Directory"))))
 
@@ -2575,28 +2574,73 @@ region and the first line of the next region."
 
 (defcustom compilation-context-lines nil
   "Display this many lines of leading context before the current message.
-If nil and the left fringe is displayed, don't scroll the
+If nil or t, and the left fringe is displayed, don't scroll the
 compilation output window; an arrow in the left fringe points to
-the current message.  If nil and there is no left fringe, the message
-displays at the top of the window; there is no arrow."
-  :type '(choice integer (const :tag "No window scrolling" nil))
+the current message.  With no left fringe, If nil, the message
+scrolls to the top of the window; there is no arrow.  If t, don't
+scroll the compilation output window at all; an arrow before
+column zero points to the current message."
+  :type '(choice integer
+                 (const :tag "Scroll window when no fringe" nil)
+                 (const :tag  "No window scrolling" t))
   :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)
-      (set-window-start w (save-excursion
-                           (goto-char mk)
-                           (compilation-beginning-of-line
-                            (- 1 compilation-context-lines))
-                           (point)))
+  "Maybe align the compilation output window W with marker MK near top."
+  (cond ((integerp compilation-context-lines)
+         (set-window-start w (save-excursion
+                              (goto-char mk)
+                              (compilation-beginning-of-line
+                               (- 1 compilation-context-lines))
+                              (point))))
+        ((eq compilation-context-lines t))
     ;; If there is no left fringe.
-    (when (equal (car (window-fringes w)) 0)
-      (set-window-start w (save-excursion
-                            (goto-char mk)
-                           (beginning-of-line 1)
-                           (point)))))
-    (set-window-point w mk))
+        ((equal (car (window-fringes w)) 0)
+         (set-window-start w (save-excursion
+                               (goto-char mk)
+                              (beginning-of-line 1)
+                              (point)))
+         (set-window-point w mk))))
+
+(defvar-local overlay-arrow-overlay nil
+  "Overlay with the before-string property of `overlay-arrow-string'.
+
+When non-nil, this overlay causes redisplay to display `overlay-arrow-string'
+at the overlay's start position.")
+
+(defun compilation-set-overlay-arrow (w)
+  "Set up, or switch off, the overlay-arrow for window W."
+  (with-current-buffer (window-buffer w)
+    (if (and (eq compilation-context-lines t)
+             (equal (car (window-fringes w)) 0)) ; No left fringe
+        ;; Insert a "=>" before-string overlay at the beginning of the
+        ;; line pointed to by `overlay-arrow-position'.
+        (cond
+         ((overlayp overlay-arrow-overlay)
+          (when (not (eq (overlay-start overlay-arrow-overlay)
+                        overlay-arrow-position))
+           (if overlay-arrow-position
+                (progn
+                 (move-overlay overlay-arrow-overlay
+                               overlay-arrow-position overlay-arrow-position)
+                  (setq overlay-arrow-string "=>")
+                  (overlay-put overlay-arrow-overlay
+                               'before-string overlay-arrow-string))
+             (delete-overlay overlay-arrow-overlay)
+             (setq overlay-arrow-overlay nil))))
+
+         (overlay-arrow-position
+          (setq overlay-arrow-overlay
+               (make-overlay overlay-arrow-position overlay-arrow-position))
+          (setq overlay-arrow-string "=>")
+          (overlay-put overlay-arrow-overlay 'before-string 
overlay-arrow-string)))
+
+      ;; `compilation-context-lines' isn't t, or we've got a left
+      ;; fringe, so remove any overlay arrow.
+      (when (overlayp overlay-arrow-overlay)
+        (setq overlay-arrow-string "")
+        (delete-overlay overlay-arrow-overlay)
+        (setq overlay-arrow-overlay nil)))))
 
 (defvar next-error-highlight-timer)
 
@@ -2618,7 +2662,8 @@ and overlay is highlighted between MK and END-MK."
         (highlight-regexp (with-current-buffer (marker-buffer msg)
                             ;; also do this while we change buffer
                             (goto-char (marker-position msg))
-                            (and w (compilation-set-window w msg))
+                            (and w (progn (compilation-set-window w msg)
+                                           (compilation-set-overlay-arrow w)))
                             compilation-highlight-regexp)))
     ;; Ideally, the window-size should be passed to `display-buffer'
     ;; so it's only used when creating a new window.
@@ -2739,7 +2784,8 @@ attempts to find a file whose name is produced by (format 
FMT FILENAME)."
                                   '(nil (allow-no-window . t))))))
           (with-current-buffer (marker-buffer marker)
            (goto-char marker)
-           (and w (compilation-set-window w marker)))
+           (and w (progn (compilation-set-window w marker)
+                          (compilation-set-overlay-arrow w))))
           (let* ((name (read-file-name
                         (format "Find this %s in (default %s): "
                                 compilation-error filename)