Cannot flash line in other window

[Nordlöw]

Hey!

I have written a module to temporary (with a timer) highlight a
region. I find highly usable as it temporarily flashes the region when
we perform operations that change the position and window of the
cursor. It tries to be unification of all other such highlighting
modules I have seen. One thing doesn't work though: I cannot get it to
highlight things in a window other than the selected one. So I'm
asking you for help with this. I need this to highlight the
compilation message line in the compilation buffer (see the advice for
previous-error and next-error).

Thank in advance for any help,
Per Nordlöw

;;; hictx.el --- Highlight Operation Result or Context.
;; Author: Per Nordlöw
;; See: 
http://groups.google.se/group/gnu.emacs.help/browse_thread/thread/25024cc86611ea35#

(require 'timer)

(defgroup hictx nil
  "Highlight Contexts of Operations."
  :group 'tools)

(defface hictx-face
  '((t (:background
        ;;"#f0f0f0"
        ;;"#40f080"
        "#404040"
        )))
  "Face used to highlight context.")

(defcustom hictx-timeout 0.35
  "Default time interval to display the highlighted context."
  :group 'hictx)

(defvar hictx-last-overlay nil
  "Last overlay created by `hictx-generic'.")

;; See: 
http://groups.google.com/group/gnu.emacs.help/browse_thread/thread/1a9678d00146647c
(defun hictx-generic (&optional start end window face duration keep-
last async-flag)
  "Highlight region from START to END with FACE in WINDOW for
DURATION seconds. START defaults to beginning of line, END to end
of line, WINDOW to `selected-window', FACE to `next-error' and
DURATION to `hictx-timeout'. If KEEP-LAST is non-nil keep the
previous overlay, `hictx-last-overlay'."
  (with-selected-window (or window (selected-window))
    (let ((ov (make-overlay (or start (line-beginning-position))
                            (or end (line-end-position)))))
      (when (and (not keep-last) hictx-last-overlay)
        (delete-overlay hictx-last-overlay)) ;remove old
      (setq hictx-last-overlay
ov)                                  ;set new
      (overlay-put ov 'window (selected-window))
      (overlay-put ov 'face (or face 'hictx-face))
      (if async-flag
          (run-with-timer (or duration hictx-timeout) nil #'delete-
overlay ov) ;delete overlay later kind of "asynchronously"
        (with-timeout ((or duration hictx-timeout))
          (hictx-wait-key))            ;wait for key
        (delete-overlay ov)             ;and delete
        )
      nil)))
;; Use: (progn (hictx-generic (- (point) 10) (+ (point) 0)) (hictx-
generic (+ (point) 10) (+ (point) 20) nil nil nil t))
;; Use: (progn (hictx-generic (- (point) 10) (+ (point) 0)) (hictx-
generic (+ (point) 10) (+ (point) 20) nil nil nil t t))

(defun hictx-line (&optional window face duration keep-last async-
flag)
  (hictx-generic (line-beginning-position) (line-beginning-position 2)
window face duration keep-last async-flag))

(defun hictx-line-content (&optional window face duration keep-last
async-flag)
  (hictx-generic (line-beginning-position) (line-end-position)))

(defun hictx-region (&optional window face duration keep-last async-
flag)
  (hictx-generic (region-beginning) (region-end) window face duration
keep-last async-flag))

(defun hictx-defun-afpt (&optional window face duration keep-last
async-flag)
  (let ((beg (point)) (end (save-excursion (end-of-defun 1) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-defun-bfpt (&optional window face duration keep-last
async-flag)
  (let ((end (point)) (beg (save-excursion (beginning-of-defun 1)
(point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-c-defun-afpt (&optional window face duration keep-last
async-flag)
  (let ((beg (point)) (end (save-excursion (c-end-of-defun 1)
(point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-c-defun-bfpt (&optional window face duration keep-last
async-flag)
  (let ((end (point)) (beg (save-excursion (c-beginning-of-defun 1)
(point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-c-statement-afpt (&optional window face duration keep-
last async-flag)
  (let ((beg (point)) (end (save-excursion (c-end-of-statement 1)
(point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-c-statement-bfpt (&optional window face duration keep-
last async-flag)
  (let ((end (point)) (beg (save-excursion (c-beginning-of-statement
1) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-sexp-afpt (&optional window face duration keep-last async-
flag)
  (let ((beg (point)) (end (save-excursion (forward-sexp) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-sexp-bfpt (&optional window face duration keep-last async-
flag)
  (let ((end (point)) (beg (save-excursion (backward-sexp) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-word-afpt (&optional window face duration keep-last async-
flag)
  (let ((beg (point)) (end (save-excursion (forward-word) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-word-bfpt (&optional window face duration keep-last async-
flag)
  (let ((end (point)) (beg (save-excursion (backward-word) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-c-arg-afpt (&optional window face duration keep-last
async-flag)
  (let ((beg (point)) (end (save-excursion (c-forward-arg) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-c-arg-bfpt (&optional window face duration keep-last
async-flag)
  (let ((end (point)) (beg (save-excursion (c-backward-arg) (point))))
    (hictx-generic beg end window face duration keep-last async-
flag)))

(defun hictx-wait-key (&optional exit-char message)
  "Momentarily wait until a key stroke is pressed.
The pressed key is not consumed and will be acted upon as usual.
This is used to do something after the next key is pressed.
Imagine that you're levitating in a Tibetan buddhist temple and
that you're waiting for the other shoe to drop.  This was
inspired by the implementation of momentary-string-display."
  (let ((inhibit-read-only t)
        ;; Don't modify the undo list at all.
        (buffer-undo-list t)
        )
    (unwind-protect
        (let (char)
          (when exit-char
            (message (or message "Type %s to continue editing.")
                     (single-key-description exit-char)))
          (if (integerp exit-char)
              (condition-case nil
                  (progn
                    (setq char (read-char))
                    (or (eq char exit-char)
                        (setq unread-command-events (list char))))
                (error
                 ;; `exit-char' is a character, hence it differs
                 ;; from char, which is an event.
                 (setq unread-command-events (list char))))

            ;; `exit-char' can be an event, or an event description
            ;; list.
            (setq char (read-event))
            (or (eq char exit-char)
                (eq char (event-convert-list exit-char))
                (setq unread-command-events (list char)))))
      ))
  nil)

(defun hictx-add-default-advice ()
  "Set default highlight context advices."
  (interactive)
  ;; Buffer
  (defadvice beginning-of-buffer (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice end-of-buffer (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; Function
  (defadvice beginning-of-defun (after ctx-flash activate) (when
(called-interactively-p t) (hictx-defun-afpt)))
  (defadvice end-of-defun (after ctx-flash activate) (when (called-
interactively-p t) (hictx-defun-bfpt)))
  ;; C Function
  (defadvice c-beginning-of-defun (after ctx-flash activate) (when
(called-interactively-p t) (hictx-c-defun-afpt)))
  (defadvice c-end-of-defun (after ctx-flash activate) (when (called-
interactively-p t) (hictx-c-defun-bfpt)))
  ;; C Statement
  (defadvice c-beginning-of-statement (after ctx-flash activate) (when
(called-interactively-p t) (hictx-c-statement-afpt)))
  (defadvice c-end-of-statement (after ctx-flash activate) (when
(called-interactively-p t) (hictx-c-statement-bfpt)))
  ;; Line
  (defadvice move-beginning-of-line (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line-content)))
  (defadvice move-end-of-line (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line-content)))
  ;; Ibuffer Line
  (defadvice ibuffer-backward-line (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice ibuffer-forward-line (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice ibuffer-unmark-forward (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice ibuffer-mark-for-delete (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice ibuffer-mark-forward (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  ;; Ibuffer Line
  (defadvice dired-previous-line (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice dired-next-line (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; Sentence
  (defadvice forward-sentence (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice backward-sentence (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  ;; SExp
  (defadvice forward-sexp (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-bfpt)))
  (defadvice backward-sexp (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-afpt)))
  (defadvice forward-sexp-with-ding (after ctx-flash activate) (when
(called-interactively-p t) (hictx-sexp-bfpt)))
  (defadvice backward-sexp-with-ding (after ctx-flash activate) (when
(called-interactively-p t) (hictx-sexp-afpt)))
  (defadvice paredit-forward (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-bfpt)))
  (defadvice paredit-backward (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-afpt)))
  ;; C SubWord
  (defadvice subword-forward (after ctx-flash activate) (when (called-
interactively-p t) (hictx-word-bfpt)))
  (defadvice subword-backward (after ctx-flash activate) (when (called-
interactively-p t) (hictx-word-afpt)))
  ;; Word
  (defadvice forward-word (after ctx-flash activate) (when (called-
interactively-p t) (hictx-word-bfpt)))
  (defadvice backward-word (after ctx-flash activate) (when (called-
interactively-p t) (hictx-word-afpt)))
  (defadvice forward-word-with-ding (after ctx-flash activate) (when
(called-interactively-p t) (hictx-word-bfpt)))
  (defadvice backward-word-with-ding (after ctx-flash activate) (when
(called-interactively-p t) (hictx-word-afpt)))
  ;; C Arguments
  (defadvice c-forward-arg (after ctx-flash activate) (when (called-
interactively-p t) (hictx-c-arg-bfpt)))
  (defadvice c-backward-arg (after ctx-flash activate) (when (called-
interactively-p t) (hictx-c-arg-afpt)))
  (defadvice c-beginning-of-arglist (after ctx-flash activate) (when
(called-interactively-p t) (hictx-c-arg-afpt)))
  (defadvice c-end-of-arglist (after ctx-flash activate) (when (called-
interactively-p t) (hictx-c-arg-bfpt)))
  ;; List
  (defadvice backward-up-list (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-afpt)))
  (defadvice down-list (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-afpt)))
  (defadvice beginning-of-list (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice end-of-list (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; Line
  (defadvice goto-line (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; Char
  (defadvice goto-char (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; Minibuffer Completion Navigation (right/left)
  (defadvice previous-completion (after ctx-flash activate) (when
(called-interactively-p t) (hictx-sexp-afpt)))
  (defadvice next-completion (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-afpt)))

  ;; Paragraph
  (defadvice backward-paragraph-nomark (after ctx-flash activate)
(when (called-interactively-p t) (hictx-line)))
  (defadvice forward-paragraph-nomark (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; Window Focus and Layout
  (defadvice other-window (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice window-number-select (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice select-window-by-number (after ctx-flash activate) (hictx-
line))
  (defadvice windmove-do-window-select (after ctx-flash activate)
(when (called-interactively-p t) (hictx-line)))
  (defadvice winner-undo (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice winner-redo (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice select-previous-window (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice select-next-window (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; Search
  (defadvice isearch-beginning-of-buffer (after ctx-flash activate)
(when (called-interactively-p t) (hictx-line)))
  (defadvice isearch-end-of-buffer (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; Window Scrolling
  (defadvice recenter (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice recenter-top-bottom (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice reposition-window (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; Point/Mark
  (defadvice exchange-point-and-mark (after ctx-flash activate) (when
(called-interactively-p t) (hictx-region)))
  (defadvice exchange-point-and-mark-nomark (after ctx-flash activate)
(when (called-interactively-p t) (hictx-region)))

  ;; Undo/Redo
  (defadvice undo-tree-undo (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice undo-tree-redo (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))

  ;; TODO: Makes `recenter-top-bottom' error?
  ;; (defadvice scroll-down (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; (defadvice scroll-up (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  ;; (defadvice scroll-down-nomark (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  ;; (defadvice scroll-up-nomark (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  (defadvice kill-ring-save (after ctx-flash activate)
    (when (called-interactively-p t)
      (when (and transient-mark-mode mark-active)
        (hictx-region))))

  (defadvice kill-region (after ctx-flash activate)
    (when (called-interactively-p t)
      (when (and transient-mark-mode mark-active)
        (hictx-line))))

  (defadvice copy-region-as-kill-nomark (after ctx-flash activate)
    (when (called-interactively-p t)
      (if (and transient-mark-mode mark-active)
          (hictx-region)
        (hictx-line))))

  ;; Tag Navigation
  (defadvice find-ectag (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice pop-tag-mark (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice icicle-pop-tag-mark-pnw (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice icicle-find-first-tag (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  (defadvice icicle-pop-tag-mark (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; IMenu
  (defadvice imenu-default-goto-function (after ctx-flash activate)
(when (called-interactively-p t) (hictx-line)))

  ;; Buttons
  (defadvice push-button (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))

  ;; Org Navigation
  (defadvice org-shifttab (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))

  ;; Buffer/File Navigation
  (defadvice toggle-source-dwim (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; Org Navigation
  (defadvice vc-dir-find-file (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))
  (defadvice vc-dir-find-file-other-window (after ctx-flash activate)
(when (called-interactively-p t) (hictx-line)))

  ;; (defadvice ibuffer-forward-line (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  ;; (defadvice ibuffer-backward-line (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  ;; (defadvice ibuffer-mark-forward (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))

  ;; (defadvice previous-error (after ctx-flash activate) (when
(called-interactively-p t) (hictx-line)))
  ;; (defadvice next-error (after ctx-flash activate) (when (called-
interactively-p t) (hictx-line)))

  ;; EDebug
  (defadvice edebug-next-mode (after ctx-flash activate) (when (called-
interactively-p t) (hictx-sexp-bfpt)))

  ;; Previous and Next Error
  (defadvice previous-error (after ctx-flash activate)
    (when (called-interactively-p t) (hictx-line (get-buffer-window
next-error-last-buffer))))
  (defadvice next-error (after ctx-flash activate)
    (when (called-interactively-p t) (hictx-line (get-buffer-window
next-error-last-buffer))))
  (defadvice previous-error-with-ding (after ctx-flash activate)
    (when (called-interactively-p t) (hictx-line (get-buffer-window
next-error-last-buffer))))
  (defadvice next-error-with-ding (after ctx-flash activate)
    (when (called-interactively-p t) (hictx-line (get-buffer-window
next-error-last-buffer))))

  (when nil
    (defadvice icicle-find-first-tag (after pulse-advice activate)
      "After going to a tag, pulse the line the cursor lands on."
      (when (and pulse-command-advice-flag (interactive-p))
        (pulse-momentary-highlight-one-line (point))))
    (defadvice icicle-pop-tag-mark (after pulse-advice activate)
      "After going to a hit, pulse the line the cursor lands on."
      (when (and pulse-command-advice-flag (interactive-p))
        (pulse-momentary-highlight-one-line (point)))))
  )

(provide 'hictx)