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

   1 ;;; visible-mark.el --- Make marks visible.
   2
   3 ;; Copyright (C) 2014 by Ian Kelling
   4
   5 ;; Author: Several people, most recently Ian Kelling <ian@iankelling.org>
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20
  21 ;;; Commentary:
  22
  23 ;; Minor mode to display custom overlay faces on mark location(s).
  24 ;; Can display marks from the mark ring in the normal backward direction
  25 ;; in the forward direction.
  26 ;;
  27 ;; Example installation:
  28 ;;
  29 ;; 1. Put this file in Emacs's load-path
  30 ;;
  31 ;; 2. add to init file
  32 ;; (require 'visible-mark)
  33 ;;
  34 ;; ;; example of customizations.
  35 ;; ;; This could be set via M-x customize-group visible-mark
  36 ;; (setq visible-mark-max 2)
  37 ;; (defface my-visible-mark-face-2
  38 ;;   `((t (:background "orange" :foreground "black")))
  39 ;;   "Face for the mark."
  40 ;;   :group 'visible-mark)
  41 ;; (setq visible-mark-faces `(visible-mark-face1 my-visible-mark-face-2))
  42 ;;
  43 ;; (global-visible-mark-mode +1)
  44 ;;
  45 ;;
  46 ;; Additional useful functions like unpoping the mark are listed
  47 ;; http://www.emacswiki.org/emacs/MarkCommands
  48 ;; and http://www.emacswiki.org/emacs/VisibleMark
  49
  50 ;;; Pre-git history:
  51 ;;
  52 ;; 2008-02-21  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
  53 ;;
  54 ;;      * visible-mark.el: Added function to inhibit trailing overlay.
  55 ;;
  56 ;; 2008-01-31  MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
  57 ;;
  58 ;;      * visible-mark.el: Create formal emacs lisp file from
  59 ;;        http://www.emacswiki.org/cgi-bin/wiki/VisibleMark.
  60 ;;        Yann Hodique and Jorgen Schäfer are original authors.
  61 ;;        Added function to make multiple marks visible.
  62 ;;
  63 ;;
  64 ;; Known bugs
  65 ;;
  66 ;; Observed in circe, when the buffer has a right margin, and there
  67 ;; is a mark at the beginning of a line, any text in the margin on that line
  68 ;; gets styled with the mark's face. May also happen for left margins, but
  69 ;; haven't tested yet.
  70 ;;
  71 ;; Patches / pull requests welcome.
  72
  73 ;;; Code:
  74
  75 (eval-when-compile
  76   (require 'cl))
  77
  78 (defgroup visible-mark nil
  79   "Show the position of your mark."
  80   :group 'convenience
  81   :prefix "visible-mark-")
  82
  83 (defface visible-mark-active
  84   '((((type tty) (class color))
  85      (:background "gray" :foreground "black"))
  86     (((type tty) (class mono))
  87      (:inverse-video t))
  88     (((class color) (background dark))
  89      (:background "gray" :foreground "black"))
  90     (((class color) (background light))
  91      (:background "grey80"))
  92     (t (:background "gray")))
  93   "Face for the active mark."
  94   :group 'visible-mark)
  95
  96 (defface visible-mark-face1
  97   '((((type tty) (class mono)))
  98     (t (:background "light salmon")))
  99   "Example face which can be customized and added to subsequent face lists."
 100   :group 'visible-mark)
 101
 102 (defface visible-mark-face2
 103   '((((type tty) (class mono)))
 104     (t (:background "light goldenrod")))
 105   "Example face which can be customized and added to subsequent face lists."
 106   :group 'visible-mark)
 107
 108 (defface visible-mark-forward-face1
 109   '((((type tty) (class mono)))
 110     (t (:background "pale green")))
 111   "Example face which can be customized and added to subsequent face lists."
 112   :group 'visible-mark)
 113
 114 (defface visible-mark-forward-face2
 115   nil
 116   "Placeholder face for customization and addition to subsequent face lists."
 117   :group 'visible-mark)
 118
 119
 120 (defvar visible-mark-overlays nil
 121   "The overlays used in this buffer.")
 122 (make-variable-buffer-local 'visible-mark-overlays)
 123
 124 (defcustom visible-mark-inhibit-trailing-overlay t
 125   "If non-nil, inhibit the extension of an overlay at the end of a line
 126 to the window margin."
 127   :group 'visible-mark
 128   :type 'boolean)
 129
 130
 131 (defcustom visible-mark-max 1
 132   "The number of marks in the backward direction to be visible."
 133   :group 'visible-mark
 134   :type 'integer)
 135
 136 (defcustom visible-mark-forward-max 0
 137   "The number of marks in the forward direction to be visible."
 138   :group 'visible-mark
 139   :type 'integer)
 140
 141 (defcustom visible-mark-faces nil
 142   "A list of mark faces for marks in the backward direction.
 143 If visible-mark-max is greater than the amount of visible-mark-faces,
 144 the last defined face will be reused."
 145   :group 'visible-mark
 146   :type '(repeat face))
 147
 148 (defcustom visible-mark-forward-faces nil
 149   "A list of mark faces for marks in the forward direction."
 150   :group 'visible-mark
 151   :type '(repeat face))
 152
 153 (defcustom global-visible-mark-mode-exclude-alist nil
 154   "A list of buffer names to be excluded."
 155   :group 'visible-mark
 156   :type '(repeat regexp))
 157
 158 (defun visible-mark-initialize-overlays ()
 159   (mapc
 160    (lambda (x)
 161      (when (eq 'visible-mark (overlay-get x 'category))
 162        (delete-overlay x)))
 163    (overlays-in (point-min) (point-max)))
 164   (let (overlays)
 165     (dotimes (i (+ visible-mark-max visible-mark-forward-max))
 166       (let ((overlay (make-overlay (point-min) (point-min))))
 167         (overlay-put overlay 'category 'visible-mark)
 168         (push overlay overlays)))
 169     (setq visible-mark-overlays (nreverse overlays))))
 170
 171 (defun visible-mark-find-overlay-at (pos)
 172   (let ((overlays (overlays-at pos))
 173         found)
 174     (while (and overlays (not found))
 175       (let ((overlay (car overlays)))
 176         (if (eq 'visible-mark (overlay-get overlay 'category))
 177             (setq found overlay)))
 178       (setq overlays (cdr overlays)))
 179     found))
 180
 181 (defun visible-mark-move-overlays ()
 182   "Update overlays in `visible-mark-overlays'. This is run in the `post-command-hook'"
 183   (mapc (lambda (x) (delete-overlay x))
 184         visible-mark-overlays)
 185   (let ((marks (cons (mark-marker) mark-ring))
 186         (overlays visible-mark-overlays)
 187         (faces visible-mark-faces)
 188         (faces-forward visible-mark-forward-faces))
 189     (if mark-active (setq faces (cons 'visible-mark-active (cdr faces))))
 190     (dotimes (i visible-mark-max)
 191       (visible-mark-move-overlay (pop overlays) (pop marks) (car faces))
 192       (if (cdr faces) (pop faces)))
 193     (dotimes (i visible-mark-forward-max)
 194       (visible-mark-move-overlay (pop overlays) (car (last marks (1+ i))) (car faces-forward))
 195       (if (cdr faces-forward) (pop faces-forward)))))
 196
 197 (defun visible-mark-move-overlay (overlay mark face)
 198   "Set OVERLAY to position of MARK and display of FACE."
 199   (let ((pos (and mark (marker-position mark))))
 200     (when (and pos (not (equal (point) pos)))
 201       (cond
 202        ((and
 203          visible-mark-inhibit-trailing-overlay
 204          (save-excursion (goto-char pos) (eolp)))
 205         (overlay-put overlay 'face nil)
 206         (if (visible-mark-find-overlay-at pos)
 207             (progn (overlay-put overlay 'before-string nil))
 208           (overlay-put overlay 'before-string
 209                        (propertize
 210                         " "
 211                         'face face))
 212           (move-overlay overlay pos (1+ pos))))
 213        (t
 214         (overlay-put overlay 'before-string nil)
 215         (overlay-put overlay 'face face)
 216         (move-overlay overlay pos (1+ pos)))))))
 217
 218 (require 'easy-mmode)
 219 (defun visible-mark-mode-maybe ()
 220   (when (cond
 221          ((minibufferp (current-buffer)) nil)
 222          ((cl-flet ((fun (arg)
 223                          (if (null arg) nil
 224                            (or (string-match (car arg) (buffer-name))
 225                                (fun (cdr arg))))))
 226             (fun global-visible-mark-mode-exclude-alist)) nil)
 227          (t t))
 228     (visible-mark-mode t)))
 229
 230 (define-minor-mode visible-mark-mode
 231   "A mode to make the mark visible."
 232   nil nil nil
 233   :group 'visible-mark
 234   (if visible-mark-mode
 235       (progn
 236         (visible-mark-initialize-overlays)
 237         (add-hook 'post-command-hook 'visible-mark-move-overlays nil t))
 238     (mapc 'delete-overlay visible-mark-overlays)
 239     (setq visible-mark-overlays nil)
 240     (remove-hook 'post-command-hook 'visible-mark-move-overlays t)))
 241
 242 (define-global-minor-mode
 243   global-visible-mark-mode visible-mark-mode visible-mark-mode-maybe
 244   :group 'visible-mark)
 245
 246 (provide 'visible-mark)
 247 ;;; visible-mark.el ends here