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   (mapc 'delete-overlay visible-mark-overlays)
  71   (let (overlays)
  72     (dotimes (i visible-mark-max)
  73       (let ((overlay (make-overlay (point-min) (point-min))))
  74         (overlay-put overlay 'category 'visible-mark)
  75         (push overlay overlays)))
  76     (setq visible-mark-overlays (nreverse overlays))))
  77
  78 (defun visible-mark-find-overlay-at (pos)
  79   (let ((overlays (overlays-at pos))
  80         found)
  81     (while (and overlays (not found))
  82       (let ((overlay (car overlays)))
  83         (if (eq 'visible-mark (overlay-get overlay 'category))
  84             (setq found overlay)))
  85       (setq overlays (cdr overlays)))
  86     found))
  87
  88 (defun visible-mark-move-overlays ()
  89   "Move the overlay in `visible-mark-overlay' to a new position."
  90   (mapc (lambda (x) (move-overlay x 0 0))
  91         visible-mark-overlays)
  92   (let ((marks (cons (mark-marker) mark-ring))
  93         (overlays visible-mark-overlays))
  94     (dotimes (i visible-mark-max)
  95       (let* ((mark (car-safe marks))
  96              (overlay (car overlays))
  97              (pos (and mark (marker-position mark))))
  98         (when pos
  99           (cond
 100             ((and visible-mark-inhibit-trailing-overlay
 101                   (save-excursion (goto-char pos) (eolp)))
 102              (overlay-put overlay 'face nil)
 103              (if (visible-mark-find-overlay-at pos)
 104                  (progn (overlay-put overlay 'before-string nil)
 105                         (move-overlay overlay 0 0))
 106                  (overlay-put overlay 'before-string
 107                               (propertize
 108                                " "
 109                                'face (or (nth i visible-mark-faces) 'visible-mark-face)
 110                                'cursor 0))
 111                  (move-overlay overlay pos (1+ pos))))
 112             (t
 113              (overlay-put overlay 'before-string nil)
 114              (overlay-put overlay 'face
 115                           (or (nth i visible-mark-faces) 'visible-mark-face))
 116              (move-overlay overlay pos (1+ pos)))))
 117         (setq marks (cdr marks)))
 118       (setq overlays (cdr overlays)))))
 119
 120 (require 'easy-mmode)
 121
 122 (defun visible-mark-mode-maybe ()
 123   (when (cond
 124          ((minibufferp (current-buffer)) nil)
 125          ((flet ((fun (arg)
 126                       (if (null arg) nil
 127                         (or (string-match (car arg) (buffer-name))
 128                             (fun (cdr arg))))))
 129             (fun global-visible-mark-mode-exclude-alist)) nil)
 130          (t t))
 131     (visible-mark-mode t)))
 132
 133 (define-minor-mode visible-mark-mode
 134   "A mode to make the mark visible."
 135   nil nil nil
 136   :group 'visible-mark
 137   (if visible-mark-mode
 138       (progn
 139         (visible-mark-initialize-overlays)
 140         (add-hook 'post-command-hook 'visible-mark-move-overlays nil t))
 141     (mapc 'delete-overlay visible-mark-overlays)
 142     (setq visible-mark-overlays nil)
 143     (remove-hook 'post-command-hook 'visible-mark-move-overlays t)))
 144
 145 (define-global-minor-mode
 146   global-visible-mark-mode visible-mark-mode visible-mark-mode-maybe
 147   :group 'visible-mark)
 148
 149 (provide 'visible-mark)
 150 ;;; visible-mark.el ends here