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