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