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 "black"))
  35     (((type tty) (class mono))
  36      (:inverse-video t))
  37     (((class color) (background dark))
  38      (:background "gray" :foreground "black"))
  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 (defcustom visible-mark-inhibit-trailing-overlay t
  50   "If non-nil, inhibit trailing overlay with underline face."
  51   :group 'visible-mark
  52   :type 'boolean)
  53
  54 (defcustom visible-mark-max 1
  55   "A number of mark to be visible."
  56   :group 'visible-mark
  57   :type 'integer)
  58
  59 (defcustom visible-mark-faces nil
  60   "A list of mark faces."
  61   :group 'visible-mark
  62   :type '(repeat face))
  63
  64 (defcustom global-visible-mark-mode-exclude-alist nil
  65   "A list of buffer names to be excluded"
  66   :group 'visible-mark
  67   :type '(repeat regexp))
  68
  69 (defun visible-mark-initialize-overlays ()
  70   (mapcar 'delete-overlay visible-mark-overlays)
  71   (let (overlays)
  72     (dotimes (i visible-mark-max)
  73       (let ((overlay (make-overlay (point-min) (point-min))))
  74         (push overlay overlays)))
  75     (setq visible-mark-overlays (nreverse overlays))))
  76
  77 (defun visible-mark-move-overlays ()
  78   "Move the overlay in `visible-mark-overlay' to a new position."
  79   (let ((marks (cons (mark-marker) mark-ring))
  80         (overlays visible-mark-overlays))
  81     (dotimes (i visible-mark-max)
  82       (let* ((mark (car-safe marks))
  83              (overlay (car overlays))
  84              (pos (and mark (marker-position mark))))
  85         (when pos
  86           (overlay-put overlay 'face
  87                        (if (and visible-mark-inhibit-trailing-overlay
  88                                 (save-excursion
  89                                   (goto-char pos)
  90                                   (eolp)))
  91                            (nth i visible-mark-non-trailing-faces)
  92                          (or (nth i visible-mark-faces) 'visible-mark-face)))
  93           (move-overlay overlay pos (1+ pos)))
  94         (setq marks (cdr marks)))
  95         (setq overlays (cdr overlays)))))
  96
  97 (require 'easy-mmode)
  98
  99 (defun visible-mark-mode-maybe ()
 100   (when (cond
 101          ((minibufferp (current-buffer)) nil)
 102          ((flet ((fun (arg)
 103                       (if (null arg) nil
 104                         (or (string-match (car arg) (buffer-name))
 105                             (fun (cdr arg))))))
 106             (fun global-visible-mark-mode-exclude-alist)) nil)
 107          (t t))
 108     (visible-mark-mode t)))
 109
 110 (define-minor-mode visible-mark-mode
 111   "A mode to make the mark visible."
 112   nil nil nil
 113   :group 'visible-mark
 114   (if visible-mark-mode
 115       (progn
 116         (visible-mark-initialize-overlays)
 117         (add-hook 'post-command-hook 'visible-mark-move-overlays nil t))
 118     (mapcar 'delete-overlay visible-mark-overlays)
 119     (setq visible-mark-overlays nil)
 120     (remove-hook 'post-command-hook 'visible-mark-move-overlays t)))
 121
 122 (define-global-minor-mode
 123   global-visible-mark-mode visible-mark-mode visible-mark-mode-maybe
 124   :group 'visible-mark)
 125
 126 (provide 'visible-mark)
 127 ;;; visible-mark.el ends here