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