bug#39121: 27.0.60; occur: Add bindings for next-error-no-select

["Mattias Engdegård" <mattiase@acm.org>]

[-- Attachment #1: Type: text/plain, Size: 599 bytes --]

24 juli 2021 kl. 13.46 skrev Lars Ingebrigtsen <larsi@gnus.org>:

> That does indeed sound like a better solution.

All right, this might work. Patch!

The immediate visible benefit is that all matches on the same line are highlighted, not just the first one. It also fixes the compatibility problems mentioned above by removing occur-highlight-regexp entirely.

External packages that populate occur-mode buffers themselves should still work, since the old `occur-target` property format is still recognised. In those cases we just highlight from the first match to the end of the line.


[-- Attachment #2: 0001-Keep-track-of-match-extents-in-occur-mode-bug-39121.patch --]
[-- Type: application/octet-stream, Size: 16050 bytes --]

From 9035a88e1b62980f38362c938eba6b042d500686 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sat, 24 Jul 2021 16:32:11 +0200
Subject: [PATCH] Keep track of match extents in occur-mode (bug#39121)

Use the `occur-target` text property to keep track of the extents of
all matches on each line instead of just the start of the first match.
Doing so allows us to highlight all matches when jumping to a matching
line instead of just the first one, and it works in a more principled
way.  It also removes compatibility problems that were introduced with
occur-highlight-regexp.

For compatibility with code that populate their own occur-mode
buffers, we still accept `occur-target` properties with a single
marker as value.

* lisp/replace.el (occur-highlight-regexp, occur-highlight-overlay):
Remove.
(occur-highlight-overlays): New.
(occur--targets-start): New.
* lisp/replace.el (occur-after-change-function):
(occur-mode-find-occurrence): Replace with...
(occur-mode--find-occurrences): ...this function that returns the
whole `occur-target` property value.
(occur-mode-goto-occurrence, occur-mode-goto-occurrence-other-window)
(occur-goto-locus-delete-o, occur-mode-display-occurrence)
(occur-engine): Adjust to new property format.
(occur--highlight-occurrence): Replace with...
(occur--highlight-occurrences): ...this function that takes
the `occur-target` property value as argument.
(occur-1): Don't use `occur-highlight-regexp`.
* test/lisp/replace-tests.el (occur-highlight-occurrence):
Adapt to new property format.
---
 lisp/replace.el            | 177 +++++++++++++++++++------------------
 test/lisp/replace-tests.el |   2 +-
 2 files changed, 91 insertions(+), 88 deletions(-)

diff --git a/lisp/replace.el b/lisp/replace.el
index 7e30f1fc55..24befed241 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -792,12 +792,8 @@ regexp-history
 Maximum length of the history list is determined by the value
 of `history-length', which see.")
 
-(defvar occur-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 occur-highlight-overlay nil
-  "Overlay used to temporarily highlight occur matches.")
+(defvar occur-highlight-overlays nil
+  "Overlays used to temporarily highlight occur matches.")
 
 (defvar occur-collect-regexp-history '("\\1")
   "History of regexp for occur's collect operation")
@@ -1357,18 +1353,27 @@ occur-cease-edit
     (occur-mode)
     (message "Switching to Occur mode.")))
 
+(defun occur--targets-start (targets)
+  "First marker of the `occur-target' property value TARGETS."
+  (if (consp targets)
+      (caar targets)
+    ;; Tolerate an `occur-target' value that is a single marker for
+    ;; compatibility.
+    targets))
+
 (defun occur-after-change-function (beg end length)
   (save-excursion
     (goto-char beg)
     (let* ((line-beg (line-beginning-position))
-	   (m (get-text-property line-beg 'occur-target))
+	   (targets (get-text-property line-beg 'occur-target))
+           (m (occur--targets-start targets))
 	   (buf (marker-buffer m))
 	   col)
       (when (and (get-text-property line-beg 'occur-prefix)
 		 (not (get-text-property end 'occur-prefix)))
 	(when (= length 0)
 	  ;; Apply occur-target property to inserted (e.g. yanked) text.
-	  (put-text-property beg end 'occur-target m)
+	  (put-text-property beg end 'occur-target targets)
 	  ;; Did we insert a newline?  Occur Edit mode can't create new
 	  ;; Occur entries; just discard everything after the newline.
 	  (save-excursion
@@ -1402,35 +1407,38 @@ occur-revert-function
   "Handle `revert-buffer' for Occur mode buffers."
   (apply #'occur-1 (append occur-revert-arguments (list (buffer-name)))))
 
-(defun occur-mode-find-occurrence ()
-  (let ((pos (get-text-property (point) 'occur-target)))
-    (unless pos
+(defun occur-mode--find-occurrences ()
+  ;; The `occur-target' property value is a list of (BEG . END) for each
+  ;; match on the line, or (for compatibility) a single marker to the start
+  ;; of the first match.
+  (let* ((targets (get-text-property (point) 'occur-target))
+         (start (occur--targets-start targets)))
+    (unless targets
       (error "No occurrence on this line"))
-    (unless (buffer-live-p (marker-buffer pos))
+    (unless (buffer-live-p (marker-buffer start))
       (error "Buffer for this occurrence was killed"))
-    pos))
+    targets))
 
 (defalias 'occur-mode-mouse-goto 'occur-mode-goto-occurrence)
 (defun occur-mode-goto-occurrence (&optional event)
   "Go to the occurrence specified by EVENT, a mouse click.
 If not invoked by a mouse click, go to occurrence on the current line."
   (interactive (list last-nonmenu-event))
-  (let ((buffer (when event (current-buffer)))
-        (pos
-         (if (null event)
-             ;; Actually `event-end' works correctly with a nil argument as
-             ;; well, so we could dispense with this test, but let's not
-             ;; rely on this undocumented behavior.
-             (occur-mode-find-occurrence)
-           (with-current-buffer (window-buffer (posn-window (event-end event)))
-             (save-excursion
-               (goto-char (posn-point (event-end event)))
-               (occur-mode-find-occurrence)))))
-        (regexp occur-highlight-regexp))
+  (let* ((buffer (when event (current-buffer)))
+         (targets
+          (if (null event)
+              ;; Actually `event-end' works correctly with a nil argument as
+              ;; well, so we could dispense with this test, but let's not
+              ;; rely on this undocumented behavior.
+              (occur-mode--find-occurrences)
+            (with-current-buffer (window-buffer (posn-window (event-end event)))
+              (save-excursion
+                (goto-char (posn-point (event-end event)))
+                (occur-mode--find-occurrences)))))
+         (pos (occur--targets-start targets)))
     (pop-to-buffer (marker-buffer pos))
     (goto-char pos)
-    (let ((end-mk (save-excursion (re-search-forward regexp nil t))))
-      (occur--highlight-occurrence pos end-mk))
+    (occur--highlight-occurrences targets)
     (when buffer (next-error-found buffer (current-buffer)))
     (run-hooks 'occur-mode-find-occurrence-hook)))
 
@@ -1438,15 +1446,15 @@ occur-mode-goto-occurrence-other-window
   "Go to the occurrence the current line describes, in another window."
   (interactive)
   (let ((buffer (current-buffer))
-        (pos (occur-mode-find-occurrence)))
+        (pos (occur--targets-start (occur-mode--find-occurrences))))
     (switch-to-buffer-other-window (marker-buffer pos))
     (goto-char pos)
     (next-error-found buffer (current-buffer))
     (run-hooks 'occur-mode-find-occurrence-hook)))
 
-;; Stolen from compile.el
 (defun occur-goto-locus-delete-o ()
-  (delete-overlay occur-highlight-overlay)
+  (mapc #'delete-overlay occur-highlight-overlays)
+  (setq occur-highlight-overlays nil)
   ;; Get rid of timer and hook that would try to do this again.
   (if (timerp next-error-highlight-timer)
       (cancel-timer next-error-highlight-timer))
@@ -1454,64 +1462,55 @@ occur-goto-locus-delete-o
                #'occur-goto-locus-delete-o))
 
 ;; Highlight the current visited occurrence.
-;; Adapted from `compilation-goto-locus'.
-(defun occur--highlight-occurrence (mk end-mk)
-  (let ((highlight-regexp occur-highlight-regexp))
-    (if (timerp next-error-highlight-timer)
-        (cancel-timer next-error-highlight-timer))
-    (unless occur-highlight-overlay
-      (setq occur-highlight-overlay
-	    (make-overlay (point-min) (point-min)))
-      (overlay-put occur-highlight-overlay 'face 'next-error))
-    (with-current-buffer (marker-buffer mk)
-      (save-excursion
-        (if end-mk (goto-char end-mk) (end-of-line))
-        (let ((end (point)))
-	  (if mk (goto-char mk) (beginning-of-line))
-	  (if (and (stringp highlight-regexp)
-		   (re-search-forward highlight-regexp end t))
-	      (progn
-	        (goto-char (match-beginning 0))
-	        (move-overlay occur-highlight-overlay
-			      (match-beginning 0) (match-end 0)
-			      (current-buffer)))
-	    (move-overlay occur-highlight-overlay
-			  (point) end (current-buffer)))
-	  (if (or (eq next-error-highlight t)
-		  (numberp next-error-highlight))
-	      ;; We want highlighting: delete overlay on next input.
-	      (add-hook 'pre-command-hook
-		        #'occur-goto-locus-delete-o)
-	    ;; We don't want highlighting: delete overlay now.
-	    (delete-overlay occur-highlight-overlay))
-	  ;; We want highlighting for a limited time:
-	  ;; set up a timer to delete it.
-	  (when (numberp next-error-highlight)
-	    (setq next-error-highlight-timer
-		  (run-at-time next-error-highlight nil
-			       'occur-goto-locus-delete-o))))))
-    (when (eq next-error-highlight 'fringe-arrow)
-      ;; We want a fringe arrow (instead of highlighting).
-      (setq next-error-overlay-arrow-position
-	    (copy-marker (line-beginning-position))))))
+(defun occur--highlight-occurrences (targets)
+  (let ((start-marker (occur--targets-start targets)))
+    (occur-goto-locus-delete-o)
+    (with-current-buffer (marker-buffer start-marker)
+      (when (or (eq next-error-highlight t)
+	        (numberp next-error-highlight))
+        (setq occur-highlight-overlays
+              (mapcar (lambda (target)
+                        (let ((o (make-overlay (car target) (cdr target))))
+                          (overlay-put o 'face 'next-error)
+                          o))
+                      (if (listp targets)
+                          targets
+                        ;; `occur-target' compatibility: when we only
+                        ;; have a single starting point, highlight the
+                        ;; rest of the line.
+                        (let ((end-pos (save-excursion
+                                         (goto-char start-marker)
+                                         (line-end-position))))
+                          (list (cons start-marker end-pos))))))
+        (add-hook 'pre-command-hook #'occur-goto-locus-delete-o)
+        (when (numberp next-error-highlight)
+          ;; We want highlighting for a limited time:
+          ;; set up a timer to delete it.
+	  (setq next-error-highlight-timer
+	        (run-at-time next-error-highlight nil
+			     'occur-goto-locus-delete-o))))
+
+      (when (eq next-error-highlight 'fringe-arrow)
+        ;; We want a fringe arrow (instead of highlighting).
+        (setq next-error-overlay-arrow-position
+	      (copy-marker (line-beginning-position)))))))
 
 (defun occur-mode-display-occurrence ()
   "Display in another window the occurrence the current line describes."
   (interactive)
-  (let ((buffer (current-buffer))
-        (pos (occur-mode-find-occurrence))
-        (regexp occur-highlight-regexp)
-        (next-error-highlight next-error-highlight-no-select)
-        (display-buffer-overriding-action
-         '(nil (inhibit-same-window . t)))
-	window)
+  (let* ((buffer (current-buffer))
+         (targets (occur-mode--find-occurrences))
+         (pos (occur--targets-start targets))
+         (next-error-highlight next-error-highlight-no-select)
+         (display-buffer-overriding-action
+          '(nil (inhibit-same-window . t)))
+	 window)
     (setq window (display-buffer (marker-buffer pos) t))
     ;; This is the way to set point in the proper window.
     (save-selected-window
       (select-window window)
       (goto-char pos)
-      (let ((end-mk (save-excursion (re-search-forward regexp nil t))))
-        (occur--highlight-occurrence pos end-mk))
+      (occur--highlight-occurrences targets)
       (next-error-found buffer (current-buffer))
       (run-hooks 'occur-mode-find-occurrence-hook))))
 
@@ -1868,7 +1867,6 @@ occur-1
 	    (buffer-undo-list t)
 	    (occur--final-pos nil))
 	(erase-buffer)
-        (setq-local occur-highlight-regexp regexp)
 	(let ((count
 	       (if (stringp nlines)
                    ;; Treat nlines as a regexp to collect.
@@ -1968,7 +1966,7 @@ occur-engine
 		       (origpt nil)
 		       (begpt nil)
 		       (endpt nil)
-		       (marker nil)
+                       markers            ; list of (BEG-MARKER . END-MARKER)
 		       (curstring "")
 		       (ret nil)
 	               ;; The following binding is for when case-fold-search
@@ -1994,8 +1992,7 @@ occur-engine
 		        (setq endpt (line-end-position)))
 		      ;; Sum line numbers up to the first match line.
 		      (setq curr-line (+ curr-line (count-lines origpt begpt)))
-		      (setq marker (make-marker))
-		      (set-marker marker matchbeg)
+                      (setq markers nil)
 		      (setq curstring (occur-engine-line begpt endpt keep-props))
 		      ;; Highlight the matches
 		      (let ((len (length curstring))
@@ -2017,6 +2014,11 @@ occur-engine
 			    (setq orig-line-shown-p t)))
 		        (while (and (< start len)
 				    (string-match regexp curstring start))
+                          (push (cons (set-marker (make-marker)
+                                                  (+ begpt (match-beginning 0)))
+                                      (set-marker (make-marker)
+                                                  (+ begpt (match-end 0))))
+                                markers)
 			  (setq matches (1+ matches))
 			  (add-text-properties
 			   (match-beginning 0) (match-end 0)
@@ -2029,6 +2031,7 @@ occur-engine
 			  ;; Avoid infloop (Bug#7593).
 			  (let ((end (match-end 0)))
 			    (setq start (if (= start end) (1+ start) end)))))
+                      (setq markers (nreverse markers))
 		      ;; Generate the string to insert for this match
 		      (let* ((match-prefix
 			      ;; Using 7 digits aligns tabs properly.
@@ -2042,7 +2045,7 @@ occur-engine
 				                     ;; (for Occur Edit mode).
 				                     front-sticky t
 						     rear-nonsticky t
-						     occur-target ,marker
+						     occur-target ,markers
 						     follow-link t
 				                     help-echo "mouse-2: go to this occurrence"))))
 			     (match-str
@@ -2050,7 +2053,7 @@ occur-engine
 			      ;; because that loses.  And don't put it
 			      ;; on context lines to reduce flicker.
 			      (propertize curstring
-					  'occur-target marker
+					  'occur-target markers
 					  'follow-link t
 					  'help-echo
 					  "mouse-2: go to this occurrence"))
@@ -2069,8 +2072,8 @@ occur-engine
                                 ;; get a contiguous highlight.
 			        (propertize (concat match-prefix match-str)
                                             'mouse-face 'highlight))
-			       ;; Add marker at eol, but no mouse props.
-			       (propertize "\n" 'occur-target marker)))
+			       ;; Add markers at eol, but no mouse props.
+			       (propertize "\n" 'occur-target markers)))
 			     (data
 			      (if (= nlines 0)
 				  ;; The simple display style
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 417946c35f..7f62a417a0 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -589,7 +589,7 @@ occur-highlight-occurrence
       (replace-tests-with-highlighted-occurrence highlight-locus
         (occur-mode-display-occurrence)
         (with-current-buffer (marker-buffer
-                              (get-text-property (point) 'occur-target))
+                              (caar (get-text-property (point) 'occur-target)))
           (should (funcall check-overlays has-overlay)))))))
 
 (ert-deftest replace-regexp-bug45973 ()
-- 
2.21.1 (Apple Git-122.3)