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