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