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