Commit | Line | Data |
---|---|---|
b2b35d56 CY |
1 | ;;; pulse.el --- Pulsing Overlays |
2 | ||
3 | ;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Eric M. Ludlam <eric@siege-engine.com> | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | ;;; Commentary: | |
23 | ;; | |
24 | ;; Manage temporary pulsing of faces and overlays. | |
25 | ;; | |
26 | ;; This is a temporal decoration technique where something is to be | |
27 | ;; highlighted briefly. This adds a gentle pulsing style to the text | |
28 | ;; decorated this way. | |
29 | ;; | |
30 | ;; Useful user functions: | |
31 | ;; | |
32 | ;; `pulse-enable-integration-advice' - Turn on advice to make various | |
33 | ;; Emacs commands pulse, such as `goto-line', or `find-tag'. | |
34 | ;; | |
35 | ;; The following are useful entry points: | |
36 | ;; | |
37 | ;; `pulse' - Cause `pulse-highlight-face' to shift toward background color. | |
38 | ;; Assumes you are using a version of Emacs that supports pulsing. | |
39 | ;; | |
40 | ;; | |
41 | ;; `pulse-momentary-highlight-one-line' - Pulse a single line at POINT. | |
42 | ;; `pulse-momentary-highlight-region' - Pulse a region. | |
43 | ;; `pulse-momentary-highlight-overlay' - Pulse an overlay | |
44 | ;; These three functions will just blink the specified area if | |
45 | ;; the version of Emacs you are using doesn't support pulsing. | |
46 | ;; | |
47 | ;; `pulse-line-hook-function' - A simple function that can be used in a | |
48 | ;; hook that will pulse whatever line the cursor is on. | |
49 | ;; | |
50 | ;;; History: | |
51 | ;; | |
52 | ;; The original pulse code was written for semantic tag highlighting. | |
53 | ;; It has been extracted, and adapted for general purpose pulsing. | |
54 | ;; | |
55 | ;; Pulse is a part of CEDET. http://cedet.sf.net | |
56 | ||
57 | ||
58 | (defun pulse-available-p () | |
59 | "Return non-nil if pulsing is available on the current frame." | |
60 | (condition-case nil | |
61 | (let ((v (color-values (face-background 'default)))) | |
62 | (numberp (car-safe v))) | |
63 | (error nil))) | |
64 | ||
65 | (defcustom pulse-flag (pulse-available-p) | |
66 | "*Non-nil means to pulse the overlay face for momentary highlighting. | |
67 | Pulsing involves a bright highlight that slowly shifts to the background | |
68 | color. Non-nil just means to highlight with an unchanging color for a short | |
69 | time. | |
70 | ||
71 | If `pulse-flag' is non-nil, but `pulse-available-p' is nil, then | |
72 | this flag is ignored." | |
73 | :group 'pulse | |
74 | :type 'boolean) | |
75 | ||
76 | (defface pulse-highlight-start-face | |
77 | '((((class color) (background dark)) | |
78 | (:background "#AAAA33")) | |
79 | (((class color) (background light)) | |
80 | (:background "#FFFFAA"))) | |
81 | "*Face used at beginning of a highight." | |
82 | :group 'pulse) | |
83 | ||
84 | (defface pulse-highlight-face | |
85 | '((((class color) (background dark)) | |
86 | (:background "#AAAA33")) | |
87 | (((class color) (background light)) | |
88 | (:background "#FFFFAA"))) | |
89 | "*Face used during a pulse for display. *DO NOT CUSTOMIZE* | |
90 | Face used for temporary highlighting of tags for effect." | |
91 | :group 'pulse) | |
92 | ||
93 | ;;; Compatibility | |
94 | (defalias 'pulse-overlay-live-p 'overlay-buffer) | |
95 | (defalias 'pulse-overlay-put 'overlay-put) | |
96 | (defalias 'pulse-overlay-get 'overlay-get) | |
97 | (defalias 'pulse-overlay-delete 'delete-overlay) | |
98 | (defalias 'pulse-make-overlay 'make-overlay) | |
99 | ||
100 | (when (featurep 'xemacs) | |
101 | (defalias 'pulse-overlay-live-p | |
102 | (lambda (o) | |
103 | (and (extent-live-p o) | |
104 | (not (extent-detached-p o)) | |
105 | (bufferp (extent-buffer o))))) | |
106 | (defalias 'pulse-overlay-put 'set-extent-property) | |
107 | (defalias 'pulse-overlay-get 'extent-property) | |
108 | (defalias 'pulse-overlay-delete 'delete-extent) | |
109 | (defalias 'pulse-make-overlay 'make-extent)) | |
110 | ||
111 | ;;; Code: | |
112 | ;; | |
113 | (defun pulse-int-to-hex (int &optional nb-digits) | |
114 | "Convert integer argument INT to a #XXXXXXXXXXXX format hex string. | |
115 | Each X in the output string is a hexadecimal digit. | |
116 | NB-DIGITS is the number of hex digits. If INT is too large to be | |
117 | represented with NB-DIGITS, then the result is truncated from the | |
118 | left. So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since | |
119 | the hex equivalent of 256 decimal is 100, which is more than 2 digits. | |
120 | ||
121 | This function was blindly copied from hexrgb.el by Drew Adams. | |
122 | http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el" | |
123 | (setq nb-digits (or nb-digits 4)) | |
124 | (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits))) | |
125 | ||
126 | (defun pulse-color-values-to-hex (values) | |
127 | "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX. | |
128 | Each X in the string is a hexadecimal digit. | |
129 | Input VALUES is as for the output of `x-color-values'. | |
130 | ||
131 | This function was blindly copied from hexrgb.el by Drew Adams. | |
132 | http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el" | |
133 | (concat "#" | |
134 | (pulse-int-to-hex (nth 0 values) 4) ; red | |
135 | (pulse-int-to-hex (nth 1 values) 4) ; green | |
136 | (pulse-int-to-hex (nth 2 values) 4))) ; blue | |
137 | ||
138 | (defcustom pulse-iterations 10 | |
139 | "Number of iterations in a pulse operation." | |
140 | :group 'pulse | |
141 | :type 'number) | |
142 | (defcustom pulse-delay .03 | |
143 | "Delay between face lightening iterations, as used by `sit-for'." | |
144 | :group 'pulse | |
145 | :type 'number) | |
146 | ||
147 | (defun pulse-lighten-highlight () | |
148 | "Lighten the face by 1/`pulse-iterations' toward the background color. | |
149 | Return t if there is more drift to do, nil if completed." | |
150 | (if (>= (get 'pulse-highlight-face :iteration) pulse-iterations) | |
151 | nil | |
152 | (let* ((frame (color-values (face-background 'default))) | |
153 | (start (color-values (face-background | |
154 | (get 'pulse-highlight-face | |
155 | :startface)))) | |
156 | (frac (list (/ (- (nth 0 frame) (nth 0 start)) pulse-iterations) | |
157 | (/ (- (nth 1 frame) (nth 1 start)) pulse-iterations) | |
158 | (/ (- (nth 2 frame) (nth 2 start)) pulse-iterations))) | |
159 | (it (get 'pulse-highlight-face :iteration)) | |
160 | ) | |
161 | (set-face-background 'pulse-highlight-face | |
162 | (pulse-color-values-to-hex | |
163 | (list | |
164 | (+ (nth 0 start) (* (nth 0 frac) it)) | |
165 | (+ (nth 1 start) (* (nth 1 frac) it)) | |
166 | (+ (nth 2 start) (* (nth 2 frac) it))))) | |
167 | (put 'pulse-highlight-face :iteration (1+ it)) | |
168 | (if (>= (1+ it) pulse-iterations) | |
169 | nil | |
170 | t)))) | |
171 | ||
172 | (defun pulse-reset-face (&optional face) | |
173 | "Reset the pulse highlighting FACE." | |
174 | (set-face-background 'pulse-highlight-face | |
175 | (if face | |
176 | (face-background face) | |
177 | (face-background 'pulse-highlight-start-face) | |
178 | )) | |
179 | (put 'pulse-highlight-face :startface (or face | |
180 | 'pulse-highlight-start-face)) | |
181 | (put 'pulse-highlight-face :iteration 0)) | |
182 | ||
183 | (defun pulse (&optional face) | |
184 | "Pulse the colors on our highlight face. | |
185 | If optional FACE is provide, reset the face to FACE color, | |
186 | instead of `pulse-highlight-start-face'. | |
187 | Be sure to call `pulse-reset-face' after calling pulse." | |
188 | (unwind-protect | |
189 | (progn | |
190 | (pulse-reset-face face) | |
191 | (while (and (pulse-lighten-highlight) | |
192 | (sit-for pulse-delay)) | |
193 | nil)) | |
194 | )) | |
195 | ||
196 | (defun pulse-test (&optional no-error) | |
197 | "Test the lightening function for pulsing a line. | |
198 | When optional NO-ERROR Don't throw an error if we can't run tests." | |
199 | (interactive) | |
200 | (if (or (not pulse-flag) (not (pulse-available-p))) | |
201 | (if no-error | |
202 | nil | |
203 | (error (concat "Pulse test only works on versions of Emacs" | |
204 | " that support pulsing"))) | |
205 | ;; Run the tests | |
206 | (when (interactive-p) | |
207 | (message "<Press a key> Pulse one line.") | |
208 | (read-char)) | |
209 | (pulse-momentary-highlight-one-line (point)) | |
210 | (when (interactive-p) | |
211 | (message "<Press a key> Pulse a region.") | |
212 | (read-char)) | |
213 | (pulse-momentary-highlight-region (point) | |
214 | (save-excursion | |
215 | (condition-case nil | |
216 | (forward-char 30) | |
217 | (error nil)) | |
218 | (point))) | |
219 | (when (interactive-p) | |
220 | (message "<Press a key> Pulse line a specific color.") | |
221 | (read-char)) | |
222 | (pulse-momentary-highlight-one-line (point) 'modeline) | |
223 | (when (interactive-p) | |
224 | (message "<Press a key> Pulse a pre-existing overlay.") | |
225 | (read-char)) | |
226 | (let* ((start (point-at-bol)) | |
227 | (end (save-excursion | |
228 | (end-of-line) | |
229 | (when (not (eobp)) | |
230 | (forward-char 1)) | |
231 | (point))) | |
232 | (o (pulse-make-overlay start end)) | |
233 | ) | |
234 | (pulse-momentary-highlight-overlay o) | |
235 | (if (pulse-overlay-live-p o) | |
236 | (pulse-overlay-delete o) | |
237 | (error "Non-temporary overlay was deleted!")) | |
238 | ) | |
239 | (when (interactive-p) | |
240 | (message "Done!")))) | |
241 | ||
242 | ||
243 | ;;; Convenience Functions | |
244 | ;; | |
245 | (defvar pulse-momentary-overlay nil | |
246 | "The current pulsing overlay.") | |
247 | ||
248 | (defun pulse-momentary-highlight-overlay (o &optional face) | |
249 | "Pulse the overlay O, unhighlighting before next command. | |
250 | Optional argument FACE specifies the fact to do the highlighting." | |
251 | (pulse-overlay-put o 'original-face (pulse-overlay-get o 'face)) | |
252 | (add-to-list 'pulse-momentary-overlay o) | |
253 | (if (or (not pulse-flag) (not (pulse-available-p))) | |
254 | ;; Provide a face... clear on next command | |
255 | (progn | |
256 | (pulse-overlay-put o 'face (or face 'pulse-highlight-start-face)) | |
257 | (add-hook 'pre-command-hook | |
258 | 'pulse-momentary-unhighlight) | |
259 | ) | |
260 | ;; pulse it. | |
261 | (unwind-protect | |
262 | (progn | |
263 | (pulse-overlay-put o 'face 'pulse-highlight-face) | |
264 | ;; The pulse function puts FACE onto 'pulse-highlight-face. | |
265 | ;; Thus above we put our face on the overlay, but pulse | |
266 | ;; with a reference face needed for the color. | |
267 | (pulse face)) | |
268 | (pulse-momentary-unhighlight)) | |
269 | ) | |
270 | ) | |
271 | ||
272 | (defun pulse-momentary-unhighlight () | |
273 | "Unhighlight a line recently highlighted." | |
274 | ;; If someone passes in an overlay, then pulse-momentary-overlay | |
275 | ;; will still be nil, and won't need modifying. | |
276 | (when pulse-momentary-overlay | |
277 | ;; clear the starting face | |
278 | (mapc | |
279 | (lambda (ol) | |
280 | (pulse-overlay-put ol 'face (pulse-overlay-get ol 'original-face)) | |
281 | (pulse-overlay-put ol 'original-face nil) | |
282 | ;; Clear the overlay if it needs deleting. | |
283 | (when (pulse-overlay-get ol 'pulse-delete) (pulse-overlay-delete ol))) | |
284 | pulse-momentary-overlay) | |
285 | ||
286 | ;; Clear the variable. | |
287 | (setq pulse-momentary-overlay nil)) | |
288 | ||
289 | ;; Reset the pulsing face. | |
290 | (pulse-reset-face) | |
291 | ||
292 | ;; Remove this hook. | |
293 | (remove-hook 'pre-command-hook 'pulse-momentary-unhighlight) | |
294 | ) | |
295 | ||
296 | (defun pulse-momentary-highlight-one-line (point &optional face) | |
297 | "Highlight the line around POINT, unhighlighting before next command. | |
298 | Optional argument FACE specifies the face to do the highlighting." | |
299 | (let ((start (point-at-bol)) | |
300 | (end (save-excursion | |
301 | (end-of-line) | |
302 | (when (not (eobp)) | |
303 | (forward-char 1)) | |
304 | (point)))) | |
305 | (pulse-momentary-highlight-region start end face) | |
306 | )) | |
307 | ||
308 | (defun pulse-momentary-highlight-region (start end &optional face) | |
309 | "Highlight between START and END, unhighlighting before next command. | |
310 | Optional argument FACE specifies the fact to do the highlighting." | |
311 | (let ((o (pulse-make-overlay start end))) | |
312 | ;; Mark it for deletion | |
313 | (pulse-overlay-put o 'pulse-delete t) | |
314 | (pulse-momentary-highlight-overlay o face))) | |
315 | ||
316 | ;;; Random integration with other tools | |
317 | ;; | |
318 | (defvar pulse-command-advice-flag nil | |
319 | "Non-nil means pulse advice is active. | |
320 | To active pulse advice, use `pulse-enable-integration-advice'.") | |
321 | ||
322 | (defun pulse-toggle-integration-advice (arg) | |
323 | "Toggle activation of advised functions that will now pulse. | |
324 | Wint no ARG, toggle the pulse advice. | |
325 | With a negative ARG, disable pulse advice. | |
326 | With a positive ARG, enable pulse advice. | |
327 | Currently advised functions include: | |
328 | `goto-line' | |
329 | `exchange-point-and-mark' | |
330 | `find-tag' | |
331 | `tags-search' | |
332 | `tags-loop-continue' | |
333 | `pop-tag-mark' | |
334 | `imenu-default-goto-function' | |
335 | Pulsing via `pulse-line-hook-function' has also been added to | |
336 | the following hook: | |
337 | `next-error-hook'" | |
338 | (interactive "P") | |
339 | (if (null arg) | |
340 | (setq pulse-command-advice-flag (not pulse-command-advice-flag)) | |
341 | (if (< (prefix-numeric-value arg) 0) | |
342 | (setq pulse-command-advice-flag nil) | |
343 | (setq pulse-command-advice-flag t) | |
344 | ) | |
345 | ) | |
346 | (if pulse-command-advice-flag | |
347 | (message "Pulse advice enabled") | |
348 | (message "Pulse advice disabled")) | |
349 | ) | |
350 | ||
351 | (defadvice goto-line (after pulse-advice activate) | |
352 | "Cause the line that is `goto'd to pulse when the cursor gets there." | |
353 | (when (and pulse-command-advice-flag (interactive-p)) | |
354 | (pulse-momentary-highlight-one-line (point)))) | |
355 | ||
356 | (defadvice exchange-point-and-mark (after pulse-advice activate) | |
357 | "Cause the line that is `goto'd to pulse when the cursor gets there." | |
358 | (when (and pulse-command-advice-flag (interactive-p) | |
359 | (> (abs (- (point) (mark))) 400)) | |
360 | (pulse-momentary-highlight-one-line (point)))) | |
361 | ||
362 | (defadvice find-tag (after pulse-advice activate) | |
363 | "After going to a tag, pulse the line the cursor lands on." | |
364 | (when (and pulse-command-advice-flag (interactive-p)) | |
365 | (pulse-momentary-highlight-one-line (point)))) | |
366 | ||
367 | (defadvice tags-search (after pulse-advice activate) | |
368 | "After going to a hit, pulse the line the cursor lands on." | |
369 | (when (and pulse-command-advice-flag (interactive-p)) | |
370 | (pulse-momentary-highlight-one-line (point)))) | |
371 | ||
372 | (defadvice tags-loop-continue (after pulse-advice activate) | |
373 | "After going to a hit, pulse the line the cursor lands on." | |
374 | (when (and pulse-command-advice-flag (interactive-p)) | |
375 | (pulse-momentary-highlight-one-line (point)))) | |
376 | ||
377 | (defadvice pop-tag-mark (after pulse-advice activate) | |
378 | "After going to a hit, pulse the line the cursor lands on." | |
379 | (when (and pulse-command-advice-flag (interactive-p)) | |
380 | (pulse-momentary-highlight-one-line (point)))) | |
381 | ||
382 | (defadvice imenu-default-goto-function (after pulse-advice activate) | |
383 | "After going to a tag, pulse the line the cursor lands on." | |
384 | (when pulse-command-advice-flag | |
385 | (pulse-momentary-highlight-one-line (point)))) | |
386 | ||
387 | (defun pulse-line-hook-function () | |
388 | "Function used in hooks to pulse the current line. | |
389 | Only pulses the line if `pulse-command-advice-flag' is non-nil." | |
390 | (when pulse-command-advice-flag | |
391 | (pulse-momentary-highlight-one-line (point)))) | |
392 | ||
393 | (add-hook 'next-error-hook 'pulse-line-hook-function) | |
394 | ||
395 | (provide 'pulse) | |
396 | ||
397 | ;;; pulse.el ends here |