Mode like Evil Visual Mark Mode

[okamsn]

Evil Visual Mark Mode (https://github.com/roman/evil-visual-mark-mode) is a mode for displaying the positions and character of Evil's marks in the buffer. The below code does so for Emacs's position registers (from point-to-register). Like EVMM, it shows the registers in the Normal and Motion states and hides them in the Insert state.

I'm sure there's room for improvement, but it seems to be working pretty well so far.

;;; meow-visible-registers --- Show position registers in buffers -*- lexical-binding: t; -*-

;;; Commentary:
;; - Based on Evil Visual Mark mode
;;   (https://github.com/roman/evil-visual-mark-mode).
;;
;; - Registers are global, not buffer local.
;;
;; - Meow Normal state's block cursor is placed on the character after
;;   point (point being between characters), so we show the overlay
;;   as being before the position.
;;
;; - TODO: Overlays are sometimes moved differently than a register's marker,
;;   for some reason.  For example, if we place a register and create the
;;   overlay, then delete the text around the register, then hit undo a few
;;   times, sometimes the overlay is returned to one character before where the
;;   register actually is.
;;
;;   To work around this, we reposition the overlays (possibly correcting them)
;;   when entering the Normal and Motion states and in `after-change-functions'
;;   in those states.  We don't use `after-change-functions' in Insert state.

;;; Code:

(require 'map)
(require 'meow)

(defvar register-alist)
(declare-function set-register "register")

(defface meow-visible-registers
  '((t (:inherit highlight)))
  "Face for Meow Visible Register."
  :group 'meow)

(defvar meow-visible-registers--overlay-alist nil
  "Alist of Meow Visible Registers registers and their overlays.

Keys are register characters, values are overlays.")

(defun meow-visible-registers--show-overlay (register-char overlay)
  "Show OVERLAY as REGISTER-CHAR using the `before-string' property."
  (overlay-put overlay 'before-string (propertize (char-to-string
                                                   register-char)
                                                  'face
                                                  'meow-visible-registers)))

(defun meow-visible-registers--update-or-remove-association (register-char register-value)
  "Associate an overlay with REGISTER-CHAR, if REGISTER-VALUE is a marker.

If an associated overlay already exists for REGISTER-CHAR, just
update its position and buffer with REGISTER-VALUE.

If REGISTER-VALUE is not a marker, delete the associated
overlay (if one exists) and remove the association.

This function advises `set-register' and is used when setting up
the mode."
  (let* ((entry (map-elt meow-visible-registers--overlay-alist register-char))
         (markerp (markerp register-value))
         (marker-buffer (and markerp (marker-buffer register-value))))
    (cond
     ((and (not markerp) entry)
      (delete-overlay entry)
      (setq meow-visible-registers--overlay-alist
            (map-delete meow-visible-registers--overlay-alist register-char)))
     (entry
      (move-overlay entry register-value register-value marker-buffer))
     (markerp
      (let ((new-ov (make-overlay register-value register-value marker-buffer)))
        (setq meow-visible-registers--overlay-alist
              (map-insert meow-visible-registers--overlay-alist register-char new-ov))
        (unless (meow-insert-mode-p)
          (meow-visible-registers--show-overlay register-char new-ov)))))))

;; TODO: Is there an overlay setting that would fix this?
(defun meow-visible-registers--reposition-current-buffer-overlays (&rest _)
  "Reposition overlays in `after-change-functions'.

Some commands, such as undo, seem to update markers and overlays differently."
  (map-do (let ((buffer (current-buffer)))
            (lambda (reg ov)
              (when (equal buffer (overlay-buffer ov))
                (let ((place (map-elt register-alist reg)))
                  (unless (equal place (overlay-start ov))
                    (move-overlay ov place place buffer))))))
          meow-visible-registers--overlay-alist))

(defun meow-visible-registers--show-current-buffer-overlays ()
  "Show all overlays for Meow Visible Registers in BUFFER."
  (map-do (let ((buffer (current-buffer)))
            (lambda (register-char overlay)
              (when (equal (overlay-buffer overlay) buffer)
                (meow-visible-registers--show-overlay register-char overlay))))
          meow-visible-registers--overlay-alist))

(defun meow-visible-registers--hide-current-buffer-overlays ()
  "Hide all overlays for Meow Visible Registers in BUFFER."
  (map-do (let ((buffer (current-buffer)))
            (lambda (_ overlay)
              (when (equal (overlay-buffer overlay) buffer)
                (overlay-put overlay 'before-string ""))))
          meow-visible-registers--overlay-alist))

(defun meow-visible-registers--hide ()
  "Hide overlays when entering Insert state."
  (remove-hook 'after-change-functions
               #'meow-visible-registers--reposition-current-buffer-overlays
               t)
  (meow-visible-registers--hide-current-buffer-overlays))

(defun meow-visible-registers--show ()
  "Show overlays when exiting Insert state."
  ;; Correct overlay positions after any changes.
  (meow-visible-registers--reposition-current-buffer-overlays)
  (meow-visible-registers--show-current-buffer-overlays)
  (add-hook 'after-change-functions
            #'meow-visible-registers--reposition-current-buffer-overlays
            99 t))

;;;###autoload
(define-minor-mode meow-visible-registers-mode
  "Make position registers visible and easy to remember."
  :global t
  :group 'meow
  ;; Clean up
  (when meow-visible-registers--overlay-alist
    (map-do (lambda (_ ov) (delete-overlay ov))
            meow-visible-registers--overlay-alist)
    (setq meow-visible-registers--overlay-alist nil))

  (remove-hook 'meow-insert-enter-hook #'meow-visible-registers--hide)
  (remove-hook 'meow-insert-exit-hook #'meow-visible-registers--show)
  (advice-remove 'set-register #'meow-visible-registers--update-or-remove-association)
  (dolist (b (buffer-list))
    (with-current-buffer b
      (remove-hook 'after-change-functions
                   #'meow-visible-registers--reposition-current-buffer-overlays
                   t)))

  ;; Set up
  (when meow-visible-registers-mode
    ;; Create overlays as needed.
    (map-do (lambda (register value)
              (meow-visible-registers--update-or-remove-association register value))
            register-alist)

    (dolist (b (buffer-list))
      (with-current-buffer b
        (when (and meow-mode (not (meow-insert-mode-p)))
          (meow-visible-registers--show))))

    (add-hook 'meow-insert-enter-hook #'meow-visible-registers--hide)
    (add-hook 'meow-insert-exit-hook #'meow-visible-registers--show)
    (advice-add 'set-register :after #'meow-visible-registers--update-or-remove-association)))

  (provide 'meow-visible-registers)
;;; meow-visible-registers.el ends here