Is there a better way to override opening window in compilation-goto-locus?

Question

I don't like the behavior of compilation-goto-locus (bound to Enter in a *compilation* or *grep* buffer), where it splits the window and jumps to the line in a new window. I prefer the *compilation*/*grep* buffer to be entirely replaced. I've accomplished this by copy-pasting the whole definition of compilation-goto-locus into my init.el from compile.el, and commenting out the behavior I don't like. It looks like this

(require 'compile)

(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
and overlay is highlighted between MK and END-MK."
  ;; Show compilation buffer in other window, scrolled to this error.
  (let* ((from-compilation-buffer (eq (window-buffer)
                                      (marker-buffer msg)))
         ;; Use an existing window if it is in a visible frame.
         (pre-existing (get-buffer-window (marker-buffer msg) 0))
         (w (if (and from-compilation-buffer pre-existing)
                ;; Calling display-buffer here may end up (partly) hiding
                ;; the error location if the two buffers are in two
                ;; different frames.  So don't do it if it's not necessary.
                pre-existing
          (display-buffer (marker-buffer msg) '(nil (allow-no-window . t)))))
     (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))
                 compilation-highlight-regexp)))
    ;; Ideally, the window-size should be passed to `display-buffer'
    ;; so it's only used when creating a new window.
    (when (and (not pre-existing) w)
      (compilation-set-window-height w))

;; I commented out this code

;;    (if from-compilation-buffer
;;        ;; If the compilation buffer window was selected,
;;        ;; keep the compilation buffer in this window;
;;        ;; display the source in another window.
;;        (let ((pop-up-windows t))
;;          (pop-to-buffer (marker-buffer mk) 'other-window))
;;      (switch-to-buffer (marker-buffer mk)))

;; and replaced it with this line

    (switch-to-buffer (marker-buffer mk))


    (unless (eq (goto-char mk) (point))
      ;; If narrowing gets in the way of going to the right place, widen.
      (widen)
      (if next-error-move-function
      (funcall next-error-move-function msg mk)
    (goto-char mk)))
    (if end-mk
        (push-mark end-mk t)
      (if mark-active (setq mark-active)))
    ;; If hideshow got in the way of
    ;; seeing the right place, open permanently.
    (dolist (ov (overlays-at (point)))
      (when (eq 'hs (overlay-get ov 'invisible))
        (delete-overlay ov)
        (goto-char mk)))

    (when highlight-regexp
      (if (timerp next-error-highlight-timer)
      (cancel-timer next-error-highlight-timer))
      (unless compilation-highlight-overlay
    (setq compilation-highlight-overlay
          (make-overlay (point-min) (point-min)))
    (overlay-put compilation-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 compilation-highlight-overlay
                (match-beginning 0) (match-end 0)
                (current-buffer)))
          (move-overlay compilation-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
              'compilation-goto-locus-delete-o)
          ;; We don't want highlighting: delete overlay now.
          (delete-overlay compilation-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
                 'compilation-goto-locus-delete-o)))))))
    (when (and (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))))))

my question is: is there a better way to accomplish this? It seems tricky, because the behavior is controlled by the pop-up-windows variable, which the commented out code is explicitly resetting.

Answer 1

You could use display-buffer-alist and dispatch on the executed command, like this.

(defvar display-buffer-same-window-commands
  '(occur-mode-goto-occurrence compile-goto-error))

(add-to-list 'display-buffer-alist
             '((lambda (&rest _)
                 (memq this-command display-buffer-same-window-commands))
               (display-buffer-reuse-window
                display-buffer-same-window)
               (inhibit-same-window . nil)))

Answer 2

I've developed some machinery using temporary advice that should accomplish what you want. Notice that if you replace pop-to-buffer in the code you commented out with pop-to-buffer-same-window, everything should work like you want it to.

I think this should do what you want, but be aware that I've done only the most cursory testing.

(defun my/compilation-goto-locus (msg mk end-mk)
  "As `compilation-goto-locus', but open in same window." 
  (my/with-advice
      ((:once #'pop-to-buffer :override
              (lambda (buffer &optional action norecord)
                (pop-to-buffer-same-window buffer norecord))))
    (compilation-goto-locus msg mk end-mk)))

This is the macro doing the heavy lifting:

(require 'cl-lib)           ; For `cl-destructuring-bind', `cl-gensym'

(defmacro my/with-advice (adlist &rest body)
  "Execute BODY with temporary advice in ADLIST.

Each element of ADLIST should be a list of the form
  ([OPTION] SYMBOL WHERE FUNCTION [PROPS]).
Here SYMBOL, WHERE, FUNCTION, and PROPS are as in `advice-add', and
OPTION is a keyword modifying how the advice should be handled.  At
present, the following keywords are recognized, with the specified
effects:

:once
This keyword indicates that the advice should be applied using
`my/advice-once' so that it is executed at most once.

The BODY is wrapped in an `unwind-protect' form, so the advice
will be removed even in the event of an error or nonlocal exit."
  (declare (debug ((&rest (&rest form)) body))
           (indent 1))
  (let ((removal-list nil))
    `(progn
       ,@(mapcar
          (lambda (adform)
            (let ((option (if (keywordp (car adform)) (pop adform) nil)))
              (cl-destructuring-bind
                  (symbol where function &optional props) adform
                (cond
                 ((null option)
                  (push `(advice-remove ,symbol ,function) removal-list)
                  (cons 'advice-add adform))

                 ((eq option :once)
                  (push `(advice-remove ,symbol ,function) removal-list)
                  (cons 'my/advice-once adform))))))
          adlist) 
       (unwind-protect (progn ,@body)
         ,@removal-list))))

(defun my/advice-once (symbol where function &optional props)
  "As `advice-add', but remove advice after first call.

This can be useful to avoid infinite recursion, in the event that
FUNCTION calls the function named by SYMBOL directly."
  (let* ((id      (cl-gensym "my/advice-once:cleanup-"))
         (cleanup (lambda (&rest args)
                    (advice-remove symbol function)
                    (advice-remove symbol id))))
    (advice-add symbol where function props) 
    (advice-add symbol :before cleanup `((name . ,id)))))

Notice that we need to use the :once keyword here because pop-to-buffer-same-window calls pop-to-buffer, and if we don't replace only the first pop-to-buffer call, we go into infinite recursion.