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