iankelling.org Git - visible-mark/blob - visible-mark.el

   1 ;;; visible-mark.el --- Make marks visible.
   2
   3 ;;; Commentary:
   4
   5 ;; This was hacked together by Jorgen Schäfer
   6 ;; And hacked again by Yann Hodique
   7 ;; Donated to the public domain. Use at your own risk.
   8
   9 ;;; History:
  10 ;; 2008-02-21  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
  11 ;;
  12 ;;      * visible-mark.el: Added function to inhibit trailing overlay.
  13 ;;
  14 ;; 2008-01-31  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
  15 ;;
  16 ;;      * visible-mark.el: Create formal emacs lisp file from
  17 ;;        http://www.emacswiki.org/cgi-bin/wiki/VisibleMark.
  18 ;;        Yann Hodique and Jorgen Schäfer are original authors.
  19 ;;        Added function to make multiple marks visible.
  20 ;;
  21
  22 ;;; Code:
  23
  24 (eval-when-compile
  25   (require 'cl))
  26
  27 (defgroup visible-mark nil
  28   "Show the position of your mark."
  29   :group 'convenience
  30   :prefix "visible-mark-")
  31
  32 (defface visible-mark-face
  33   `((((type tty) (class color))
  34      (:background "gray" :foreground "white"))
  35     (((type tty) (class mono))
  36      (:inverse-video t))
  37     (((class color) (background dark))
  38      (:background "gray"))
  39     (((class color) (background light))
  40      (:background "grey80"))
  41     (t (:background "gray")))
  42   "Face for the mark."
  43   :group 'visible-mark)
  44
  45 (defvar visible-mark-overlays nil
  46   "The overlays used in this buffer.")
  47 (make-variable-buffer-local 'visible-mark-overlays)
  48
  49 (defvar visible-mark-non-trailing-faces nil)
  50
  51 (defcustom visible-mark-inhibit-trailing-overlay t
  52   "If non-nil, inhibit trailing overlay with underline face."
  53   :group 'visible-mark
  54   :type 'boolean)
  55
  56 (defcustom visible-mark-max 1
  57   "A number of mark to be visible."
  58   :group 'visible-mark
  59   :type 'integer)
  60
  61 (defcustom visible-mark-faces nil
  62   "A list of mark faces."
  63   :group 'visible-mark
  64   :type '(repeat face))
  65
  66 (defcustom global-visible-mark-mode-exclude-alist nil
  67   "A list of buffer names to be excluded"
  68   :group 'visible-mark
  69   :type '(repeat regexp))
  70
  71 (defun visible-mark-initialize-faces ()
  72   (if (and visible-mark-inhibit-trailing-overlay
  73            (null visible-mark-non-trailing-faces))
  74       (let (faces)
  75         (dotimes (i visible-mark-max)
  76           (let ((face (or (nth i visible-mark-faces) 'visible-mark-face))
  77                 (symbol (intern (format "visible-mark-non-trailing-face%s" i))))
  78             (copy-face face symbol)
  79             (set-face-attribute symbol nil
  80                                 :foreground (or (face-attribute face :background) t)
  81                                 :background 'unspecified
  82                                 :underline t)
  83             (push symbol faces)))
  84         (setq visible-mark-non-trailing-faces (nreverse faces)))))
  85
  86 (defun visible-mark-initialize-overlays ()
  87   (mapcar 'delete-overlay visible-mark-overlays)
  88   (let (overlays)
  89     (dotimes (i visible-mark-max)
  90       (let ((overlay (make-overlay (point-min) (point-min))))
  91         (push overlay overlays)))
  92     (setq visible-mark-overlays (nreverse overlays))))
  93
  94 (defun visible-mark-move-overlays ()
  95   "Move the overlay in `visible-mark-overlay' to a new position."
  96   (let ((marks (cons (mark-marker) mark-ring))
  97         (overlays visible-mark-overlays))
  98     (dotimes (i visible-mark-max)
  99       (let* ((mark (car-safe marks))
 100              (overlay (car overlays))
 101              (pos (and mark (marker-position mark))))
 102         (when pos
 103           (overlay-put overlay 'face
 104                        (if (and visible-mark-inhibit-trailing-overlay
 105                                 (save-excursion
 106                                   (goto-char pos)
 107                                   (eolp)))
 108                            (nth i visible-mark-non-trailing-faces)
 109                          (or (nth i visible-mark-faces) 'visible-mark-face)))
 110           (move-overlay overlay pos (1+ pos)))
 111         (setq marks (cdr marks)))
 112         (setq overlays (cdr overlays)))))
 113
 114 (require 'easy-mmode)
 115
 116 (defun visible-mark-mode-maybe ()
 117   (when (cond
 118          ((minibufferp (current-buffer)) nil)
 119          ((flet ((fun (arg)
 120                       (if (null arg) nil
 121                         (or (string-match (car arg) (buffer-name))
 122                             (fun (cdr arg))))))
 123             (fun global-visible-mark-mode-exclude-alist)) nil)
 124          (t t))
 125     (visible-mark-mode)))
 126
 127 (define-minor-mode visible-mark-mode
 128   "A mode to make the mark visible."
 129   nil nil nil
 130   :group 'visible-mark
 131   (if visible-mark-mode
 132       (progn
 133         (visible-mark-initialize-faces)
 134         (visible-mark-initialize-overlays)
 135         (add-hook 'post-command-hook 'visible-mark-move-overlays nil t))
 136     (mapcar 'delete-overlay visible-mark-overlays)
 137     (setq visible-mark-overlays nil)
 138     (remove-hook 'post-command-hook 'visible-mark-move-overlays t)))
 139
 140 (define-global-minor-mode
 141   global-visible-mark-mode visible-mark-mode visible-mark-mode-maybe
 142   :group 'visible-mark)
 143
 144 (provide 'visible-mark)
 145 ;;; visible-mark.el ends here