1b6c552f2e6b35b719cf3ee24053dbed243a5414
[visible-mark] / visible-mark.el
1 ;;; visible-mark.el --- Make marks visible.
2
3 ;;; Commentary:
4
5 ;; This was hacked together by Jorgen Schäfer
6 ;; And hacked again by Yann Hodique
7 ;; Donated to the public domain. Use at your own risk.
8
9 ;;; History:
10 ;; 2008-02-21 MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
11 ;;
12 ;; * visible-mark.el: Added function to inhibit trailing overlay.
13 ;;
14 ;; 2008-01-31 MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com>
15 ;;
16 ;; * visible-mark.el: Create formal emacs lisp file from
17 ;; http://www.emacswiki.org/cgi-bin/wiki/VisibleMark.
18 ;; Yann Hodique and Jorgen Schäfer are original authors.
19 ;; Added function to make multiple marks visible.
20 ;;
21
22 ;;; Code:
23
24 (eval-when-compile
25 (require 'cl))
26
27 (defgroup visible-mark nil
28 "Show the position of your mark."
29 :group 'convenience
30 :prefix "visible-mark-")
31
32 (defface visible-mark-face
33 `((((type tty) (class color))
34 (:background "gray" :foreground "white"))
35 (((type tty) (class mono))
36 (:inverse-video t))
37 (((class color) (background dark))
38 (:background "gray"))
39 (((class color) (background light))
40 (:background "grey80"))
41 (t (:background "gray")))
42 "Face for the mark."
43 :group 'visible-mark)
44
45 (defvar visible-mark-overlays nil
46 "The overlays used in this buffer.")
47 (make-variable-buffer-local 'visible-mark-overlays)
48
49 (defvar visible-mark-non-trailing-faces nil)
50
51 (defcustom visible-mark-inhibit-trailing-overlay t
52 "If non-nil, inhibit trailing overlay with underline face."
53 :group 'visible-mark
54 :type 'boolean)
55
56 (defcustom visible-mark-max 1
57 "A number of mark to be visible."
58 :group 'visible-mark
59 :type 'integer)
60
61 (defcustom visible-mark-faces nil
62 "A list of mark faces."
63 :group 'visible-mark
64 :type '(repeat face))
65
66 (defcustom global-visible-mark-mode-exclude-alist nil
67 "A list of buffer names to be excluded"
68 :group 'visible-mark
69 :type '(repeat regexp))
70
71 (defun visible-mark-initialize-faces ()
72 (if (and visible-mark-inhibit-trailing-overlay
73 (null visible-mark-non-trailing-faces))
74 (let (faces)
75 (dotimes (i visible-mark-max)
76 (let ((face (or (nth i visible-mark-faces) 'visible-mark-face))
77 (symbol (intern (format "visible-mark-non-trailing-face%s" i))))
78 (copy-face face symbol)
79 (set-face-attribute symbol nil
80 :foreground (or (face-attribute face :background) t)
81 :background 'unspecified
82 :underline t)
83 (push symbol faces)))
84 (setq visible-mark-non-trailing-faces (nreverse faces)))))
85
86 (defun visible-mark-initialize-overlays ()
87 (mapcar 'delete-overlay visible-mark-overlays)
88 (let (overlays)
89 (dotimes (i visible-mark-max)
90 (let ((overlay (make-overlay (point-min) (point-min))))
91 (push overlay overlays)))
92 (setq visible-mark-overlays (nreverse overlays))))
93
94 (defun visible-mark-move-overlays ()
95 "Move the overlay in `visible-mark-overlay' to a new position."
96 (let ((marks (cons (mark-marker) mark-ring))
97 (overlays visible-mark-overlays))
98 (dotimes (i visible-mark-max)
99 (let* ((mark (car-safe marks))
100 (overlay (car overlays))
101 (pos (and mark (marker-position mark))))
102 (when pos
103 (overlay-put overlay 'face
104 (if (and visible-mark-inhibit-trailing-overlay
105 (save-excursion
106 (goto-char pos)
107 (eolp)))
108 (nth i visible-mark-non-trailing-faces)
109 (or (nth i visible-mark-faces) 'visible-mark-face)))
110 (move-overlay overlay pos (1+ pos)))
111 (setq marks (cdr marks)))
112 (setq overlays (cdr overlays)))))
113
114 (require 'easy-mmode)
115
116 (defun visible-mark-mode-maybe ()
117 (when (cond
118 ((minibufferp (current-buffer)) nil)
119 ((flet ((fun (arg)
120 (if (null arg) nil
121 (or (string-match (car arg) (buffer-name))
122 (fun (cdr arg))))))
123 (fun global-visible-mark-mode-exclude-alist)) nil)
124 (t t))
125 (visible-mark-mode)))
126
127 (define-minor-mode visible-mark-mode
128 "A mode to make the mark visible."
129 nil nil nil
130 :group 'visible-mark
131 (if visible-mark-mode
132 (progn
133 (visible-mark-initialize-faces)
134 (visible-mark-initialize-overlays)
135 (add-hook 'post-command-hook 'visible-mark-move-overlays nil t))
136 (mapcar 'delete-overlay visible-mark-overlays)
137 (setq visible-mark-overlays nil)
138 (remove-hook 'post-command-hook 'visible-mark-move-overlays t)))
139
140 (define-global-minor-mode
141 global-visible-mark-mode visible-mark-mode visible-mark-mode-maybe
142 :group 'visible-mark)
143
144 (provide 'visible-mark)
145 ;;; visible-mark.el ends here