mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-21 5ddac8bd2392ec5b64392e8750d725029bf5aa79
commit | author | age
5cb5f7 1 ;;; volatile-highlights.el --- Minor mode for visual feedback on some operations.
C 2
3 ;; Copyright (C) 2001, 2010-2016 K-talo Miyazaki, all rights reserved.
4
5 ;; Author: K-talo Miyazaki <Keitaro dot Miyazaki at gmail dot com>
6 ;; Created: 03 October 2001. (as utility functions in my `.emacs' file.)
7 ;;          14 March   2010. (re-written as library `volatile-highlights.el')
8 ;; Keywords: emulations convenience wp
9 ;; Package-Version: 20160612.155
10 ;; Revision: $Id: cb468976642bf1d30cbb2070ee846c4736ee077d $
11 ;; URL: http://www.emacswiki.org/emacs/download/volatile-highlights.el
12 ;; GitHub: http://github.com/k-talo/volatile-highlights.el
13 ;; Version: 1.15
14 ;; Contributed by: Ryan Thompson and Le Wang.
15
16 ;; This file is not part of GNU Emacs.
17
18 ;; This program is free software: you can redistribute it and/or modify
19 ;; it under the terms of the GNU General Public License as published by
20 ;; the Free Software Foundation, either version 3 of the License, or
21 ;; (at your option) any later version.
22
23 ;; This program is distributed in the hope that it will be useful,
24 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
26 ;; GNU General Public License for more details.
27
28 ;; You should have received a copy of the GNU General Public License
29 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
30
31 ;;; Commentary:
32 ;;
33 ;; Overview
34 ;; ========
35 ;; This library provides minor mode `volatile-highlights-mode', which
36 ;; brings visual feedback to some operations by highlighting portions
37 ;; relating to the operations.
38 ;;
39 ;; All of highlights made by this library will be removed
40 ;; when any new operation is executed.
41 ;;
42 ;;
43 ;; INSTALLING
44 ;; ==========
45 ;; To install this library, save this file to a directory in your
46 ;; `load-path' (you can view the current `load-path' using "C-h v
47 ;; load-path" within Emacs), then add the following line to your
48 ;; .emacs start up file:
49 ;;
50 ;;    (require 'volatile-highlights)
51 ;;    (volatile-highlights-mode t)
52 ;;
53 ;;
54 ;; USING
55 ;; =====
56 ;; To toggle volatile highlighting, type `M-x volatile-highlights-mode <RET>'.
57 ;;
58 ;; While this minor mode is on, a string `VHL' will be displayed on the modeline.
59 ;;
60 ;; Currently, operations listed below will be highlighted While the minor mode
61 ;; `volatile-highlights-mode' is on:
62 ;;
63 ;;    - `undo':
64 ;;      Volatile highlights will be put on the text inserted by `undo'.
65 ;;
66 ;;    - `yank' and `yank-pop':
67 ;;      Volatile highlights will be put on the text inserted by `yank'
68 ;;      or `yank-pop'.
69 ;;
70 ;;    - `kill-region', `kill-line', any other killing function:
71 ;;      Volatile highlights will be put at the positions where the
72 ;;      killed text used to be.
73 ;;
74 ;;    - `delete-region':
75 ;;      Same as `kill-region', but not as reliable since
76 ;;      `delete-region' is an inline function.
77 ;;
78 ;;    - `find-tag':
79 ;;      Volatile highlights will be put on the tag name which was found
80 ;;      by `find-tag'.
81 ;;
82 ;;    - `occur-mode-goto-occurrence' and `occur-mode-display-occurrence':
83 ;;      Volatile highlights will be put on the occurrence which is selected
84 ;;      by `occur-mode-goto-occurrence' or `occur-mode-display-occurrence'.
85 ;;
86 ;;    - Non incremental search operations:
87 ;;      Volatile highlights will be put on the the text found by
88 ;;      commands listed below:
89 ;;
90 ;;        `nonincremental-search-forward'
91 ;;        `nonincremental-search-backward'
92 ;;        `nonincremental-re-search-forward'
93 ;;        `nonincremental-re-search-backward'
94 ;;        `nonincremental-repeat-search-forward'
95 ;;        `nonincremental-repeat-search-backwar'
96 ;;
97 ;; Highlighting support for each operations can be turned on/off individually
98 ;; via customization. Also check out the customization group
99 ;;
100 ;;   `M-x customize-group RET volatile-highlights RET'
101 ;;
102 ;;
103 ;; EXAMPLE SNIPPETS FOR USING VOLATILE HIGHLIGHTS WITH OTHER PACKAGES
104 ;; ==================================================================
105 ;;
106 ;; - vip-mode
107 ;;
108 ;;   (vhl/define-extension 'vip 'vip-yank)
109 ;;   (vhl/install-extension 'vip)
110 ;;   
111 ;; - evil-mode
112 ;;
113 ;;   (vhl/define-extension 'evil 'evil-paste-after 'evil-paste-before
114 ;;                         'evil-paste-pop 'evil-move)
115 ;;   (vhl/install-extension 'evil)
116 ;;
117 ;; - undo-tree
118 ;;
119 ;;   (vhl/define-extension 'undo-tree 'undo-tree-yank 'undo-tree-move)
120 ;;   (vhl/install-extension 'undo-tree)
121
122
123 ;;; Change Log:
124 ;;
125 ;; v1.15 Sun Jun 12 10:40:31 2016 JST
126 ;;   - Update documents, example snippets for other packages,
127 ;;     regarding #14.
128 ;;
129 ;; v1.14 Sun Jun 12 10:12:30 2016 JST
130 ;;   - Update documents, especially supporting `evil-mode',
131 ;;     regarding #13.
132 ;;   - Fixed a bug #14, an extension won't be loaded properly
133 ;;     when it was installed by `vhl/install-extension'.
134 ;;
135 ;; v1.13 Sat May 21 11:02:36 2016 JST
136 ;;   - Fixed a bug that highlighting was not working with nested volatile
137 ;;     highlighting aware operations like `yak-pop'.
138 ;;
139 ;; v1.12  Sun Feb 21 19:09:29 2016 JST
140 ;;   - Added autoload cookie.
141 ;;
142 ;; v1.11  Sun Oct  5 13:05:38 2014 JST
143 ;;   - Fixed an error "Symbol's function definition is void: return",
144 ;;     that occurs when highlight being created with `hideshow' commands.
145 ;;
146 ;; v1.10  Thu Mar 21 22:37:27 2013 JST
147 ;;   - Use inherit in face definition when detected.
148 ;;   - Suppress compiler warnings regarding to emacs/xemacs private
149 ;;     functions by file local variable.
150 ;;
151 ;; v1.9  Tue Mar  5 00:52:35 2013 JST
152 ;;   - Fixed errors in shell caused by dummy functions.
153 ;;
154 ;; v1.8  Wed Feb 15 00:08:14 2012 JST
155 ;;   - Added "Contributed by: " line in header.
156 ;;   - Added extension for hideshow.
157 ;;
158 ;; v1.7  Mon Feb 13 23:31:18 2012 JST
159 ;;   - Fixed a bug required features are not loaded.
160 ;;
161 ;; v1.6  Thu Feb  2 06:59:48 2012 JST
162 ;;   - Removed extensions for non standard features.
163 ;;   - Suppress compiler warning "function `vhl/.make-list-string'
164 ;;     defined multiple times".
165 ;;   - Fixed compiler error "Symbol's function definition is void:
166 ;;     vhl/.make-list-string".
167 ;;
168 ;;  v1.5  Tue Jan 31 22:19:04 2012 JST
169 ;;   - Added extension for highlighting the position where text was
170 ;;     killed from.
171 ;;   - Added extension for highlighting the position where text was
172 ;;     deleted from.
173 ;;   - Provide a macro `vhl/define-extension' for easily defining new
174 ;;     simple extensions with a single line of code. For usage
175 ;;     examples, see the definitions of the undo, yank, kill, and
176 ;;     delete extensions.
177 ;;
178 ;;  v1.4  Sun Jan 15 20:23:58 2012 JST
179 ;;   - Suppress compiler warnings regarding to emacs/xemacs private
180 ;;     functions.
181 ;;   - Fixed bugs which occurs to xemacs.
182 ;;
183 ;;  v1.3, Sat Dec 18 16:44:14 2010 JST
184 ;;   - Added extension for non-incremental search operations.
185 ;;   - Fixed a bug that highlights won't be appear when
186 ;;     occurrences is in folded line.
187 ;;
188 ;;  v1.2, Tue Nov 30 01:07:48 2010 JST
189 ;;   - In `vhl/ext/occur', highlight all occurrences.
190 ;;
191 ;;  v1.1, Tue Nov  9 20:36:09 2010 JST
192 ;;   - Fixed a bug that mode toggling feature was not working.
193
194 ;;; Code:
195
196 (defconst vhl/version "1.8")
197
198 (eval-when-compile
199   (require 'cl)
200   (require 'easy-mmode)
201   (require 'advice))
202
203 (provide 'volatile-highlights)
204
205
206 ;;;============================================================================
207 ;;;
208 ;;;  Private Variables.
209 ;;;
210 ;;;============================================================================
211
212 (eval-and-compile
213   (defconst vhl/.xemacsp (string-match "XEmacs" emacs-version)
214     "A flag if the emacs is xemacs or not."))
215
216 (defvar vhl/.hl-lst nil
217   "List of volatile highlights.")
218
219
220 ;;;============================================================================
221 ;;;
222 ;;;  Faces.
223 ;;;
224 ;;;============================================================================
225
226 (defgroup volatile-highlights nil
227   "Visual feedback on operations."
228   :group 'editing)
229
230
231 ;; Borrowed from `slime.el'.
232 (defun vhl/.face-inheritance-possible-p ()
233   "Return true if the :inherit face attribute is supported."
234   (assq :inherit custom-face-attributes))
235
236 (defface vhl/default-face
237   (cond
238    ((or vhl/.xemacsp
239         (not (vhl/.face-inheritance-possible-p)))
240     '((((class color) (background light))
241        (:background "yellow1"))
242       (((class color) (background dark))
243        (:background "SkyBlue4"))
244       (t :inverse-video t)))
245    (t
246     '((t
247        :inherit secondary-selection
248        ))))
249     "Face used for volatile highlights."
250     :group 'volatile-highlights)
251
252
253 ;;;============================================================================
254 ;;;
255 ;;;  Minor Mode Definition.
256 ;;;
257 ;;;============================================================================
258 ;;;###autoload
259 (easy-mmode-define-minor-mode
260  volatile-highlights-mode "Minor mode for visual feedback on some operations."
261  :global t
262  :init-value nil
263  :lighter " VHl"
264  (if volatile-highlights-mode
265      (vhl/load-extensions)
266    (vhl/unload-extensions)))
267
268
269 (defcustom Vhl/highlight-zero-width-ranges nil
270   "If t, highlight the positions of zero-width ranges.
271
272 For example, if a deletion is highlighted, then the position
273 where the deleted text used to be would be highlighted."
274   :type 'boolean
275   :group 'volatile-highlights)
276
277
278 ;;;============================================================================
279 ;;;
280 ;;;  Public Functions/Commands.
281 ;;;
282 ;;;============================================================================
283
284 ;;-----------------------------------------------------------------------------
285 ;; (vhl/add-range BEG END &OPTIONAL BUF FACE) => VOID
286 ;;-----------------------------------------------------------------------------
287 (defun vhl/add-range (beg end &optional buf face)
288   "Add a volatile highlight to the buffer `BUF' at the position
289 specified by `BEG' and `END' using the face `FACE'.
290
291 When the buffer `BUF' is not specified or its value is `nil',
292 volatile highlight will be added to current buffer.
293
294 When the face `FACE' is not specified or its value is `nil',
295 the default face `vhl/default-face' will
296 be used as the value."
297   (let* ((face (or face 'vhl/default-face))
298          (hl (vhl/.make-hl beg end buf face)))
299     (setq vhl/.hl-lst
300           (cons hl vhl/.hl-lst))
301     (add-hook 'pre-command-hook 'vhl/clear-all)))
302 (define-obsolete-function-alias 'vhl/add 'vhl/add-range "1.5")
303
304 ;;-----------------------------------------------------------------------------
305 ;; (vhl/add-position POS &OPTIONAL BUF FACE) => VOID
306 ;;-----------------------------------------------------------------------------
307 (defun vhl/add-position (pos &rest other-args)
308   "Highlight buffer position POS as a change.
309
310 If Vhl/highlight-zero-width-ranges is nil, do nothing.
311
312 Optional args are the same as `vhl/add-range'."
313   (when (and Vhl/highlight-zero-width-ranges (not (zerop (buffer-size))))
314     (when (> pos (buffer-size))
315         (setq pos (- pos 1)))
316     (apply 'vhl/add-range pos (+ pos 1) other-args)))
317
318 ;;-----------------------------------------------------------------------------
319 ;; (vhl/clear-all) => VOID
320 ;;-----------------------------------------------------------------------------
321 (defun vhl/clear-all ()
322   "Clear all volatile highlights."
323   (interactive)
324   (while vhl/.hl-lst
325     (vhl/.clear-hl (car vhl/.hl-lst))
326     (setq vhl/.hl-lst
327           (cdr vhl/.hl-lst)))
328       (remove-hook 'pre-command-hook 'vhl/clear-all))
329
330 ;;-----------------------------------------------------------------------------
331 ;; (vhl/force-clear-all) => VOID
332 ;;-----------------------------------------------------------------------------
333 (defun vhl/force-clear-all ()
334   "Force clear all volatile highlights in current buffer."
335   (interactive)
336   (vhl/.force-clear-all-hl))
337
338
339 ;;;============================================================================
340 ;;;
341 ;;;  Private Functions.
342 ;;;
343 ;;;============================================================================
344
345 ;;-----------------------------------------------------------------------------
346 ;; (vhl/.make-hl BEG END BUF FACE) => HIGHLIGHT
347 ;;-----------------------------------------------------------------------------
348 (defun vhl/.make-hl (beg end buf face)
349   "Make a volatile highlight at the position specified by `BEG' and `END'."
350   (let (hl)
351     (cond
352      (vhl/.xemacsp
353       ;; XEmacs
354       (setq hl (make-extent beg end buf))
355       (set-extent-face hl face)
356       (highlight-extent hl t)
357       (set-extent-property hl 'volatile-highlights t))
358      (t
359       ;; GNU Emacs
360       (setq hl (make-overlay beg end buf))
361       (overlay-put hl 'face face)
362       (overlay-put hl 'priority 1)
363       (overlay-put hl 'volatile-highlights t)))
364      hl))
365
366 ;;-----------------------------------------------------------------------------
367 ;; (vhl/.clear-hl HIGHLIGHT) => VOID
368 ;;-----------------------------------------------------------------------------
369 (defun vhl/.clear-hl (hl)
370   "Clear one highlight."
371   (cond
372    ;; XEmacs (not tested!)
373    (vhl/.xemacsp
374     (and (extentp hl)
375          (delete-extent hl)))
376    ;; GNU Emacs
377    (t
378     (and (overlayp hl)
379          (delete-overlay hl)))))
380
381 ;;-----------------------------------------------------------------------------
382 ;; (vhl/.force-clear-all-hl) => VOID
383 ;;-----------------------------------------------------------------------------
384 (defun vhl/.force-clear-all-hl ()
385   "Force clear all volatile highlights in current buffer."
386   (cond
387    ;; XEmacs (not tested!)
388    (vhl/.xemacsp
389       (map-extents (lambda (hl maparg)
390                      (and (extent-property hl 'volatile-highlights)
391                           (vhl/.clear-hl hl)))))
392    ;; GNU Emacs
393    (t
394     (save-restriction
395       (widen)
396       (mapcar (lambda (hl)
397                 (and (overlay-get hl 'volatile-highlights)
398                      (vhl/.clear-hl hl)))
399               (overlays-in (point-min) (point-max)))))))
400
401
402 ;;;============================================================================
403 ;;;
404 ;;;  Functions to manage extensions.
405 ;;;
406 ;;;============================================================================
407 (defvar vhl/.installed-extensions nil)
408
409 (defun vhl/install-extension (sym)
410   (let ((fn-on  (intern (format "vhl/ext/%s/on" sym)))
411         (fn-off (intern (format "vhl/ext/%s/off" sym)))
412         (cust-name (intern (format "vhl/use-%s-extension-p" sym))))
413     (pushnew sym vhl/.installed-extensions)
414     (eval `(defcustom ,cust-name t
415              ,(format "A flag if highlighting support for `%s' is on or not." sym)
416              :type 'boolean
417              :group 'volatile-highlights
418              :set (lambda (sym-to-set val)
419                     (set-default sym-to-set val)
420                     (if val
421                         (when volatile-highlights-mode
422                           (vhl/load-extension (quote ,sym)))
423                       (vhl/unload-extension (quote ,sym))))))))
424
425 (defun vhl/load-extension (sym)
426   (let ((fn-on  (intern (format "vhl/ext/%s/on" sym)))
427         (cust-name (intern (format "vhl/use-%s-extension-p" sym))))
428     (if (functionp fn-on)
429         (when (and (boundp cust-name)
430                    (eval cust-name))
431           (apply fn-on nil))
432       (message "[vhl] No load function for extension  `%s'" sym))))
433
434 (defun vhl/unload-extension (sym)
435   (let ((fn-off (intern (format "vhl/ext/%s/off" sym))))
436     (if (functionp fn-off)
437         (apply fn-off nil)
438       (message "[vhl] No unload function for extension  `%s'" sym))))
439
440 (defun vhl/load-extensions ()
441   (dolist (sym vhl/.installed-extensions)
442     (vhl/load-extension sym)))
443
444 (defun vhl/unload-extensions ()
445   (dolist (sym vhl/.installed-extensions)
446     (vhl/unload-extension sym)))
447
448
449 ;;;============================================================================
450 ;;;
451 ;;;  Utility functions/macros for extensions.
452 ;;;
453 ;;;============================================================================
454 (defvar vhl/.after-change-hook-depth 0)
455
456 (defun vhl/.push-to-after-change-hook (fn-name)
457   ;; Debug
458   ;; (if (zerop vhl/.after-change-hook-depth)
459   ;;     (message "vlh: push: %s" fn-name)
460   ;;   (message "vlh: skip push: %s" fn-name))
461   (when (zerop vhl/.after-change-hook-depth)
462     (add-hook 'after-change-functions
463               'vhl/.make-vhl-on-change))
464   (setq vhl/.after-change-hook-depth
465         (1+ vhl/.after-change-hook-depth)))
466
467 (defun vhl/.pop-from-after-change-hook (fn-name)
468   (setq vhl/.after-change-hook-depth
469         (1- vhl/.after-change-hook-depth))
470   ;; Debug
471   ;; (if (zerop vhl/.after-change-hook-depth)
472   ;;     (message "vlh: pop: %s" fn-name)
473   ;;   (message "vlh: skip pop: %s" fn-name))
474   (when (zerop vhl/.after-change-hook-depth)
475     (remove-hook 'after-change-functions
476                  'vhl/.make-vhl-on-change)))
477
478 (defun vhl/advice-defined-p (fn-name class ad-name)
479   (and (ad-is-advised fn-name)
480        (assq ad-name
481              (ad-get-advice-info-field fn-name class))))
482
483 (defun vhl/disable-advice-if-defined (fn-name class ad-name)
484   (when (vhl/advice-defined-p fn-name class ad-name)
485     (ad-disable-advice fn-name class ad-name)
486     (ad-activate fn-name)))
487
488 (defun vhl/.make-vhl-on-change (beg end len-removed)
489   (let ((insert-p (zerop len-removed)))
490     (if insert-p
491         ;; Highlight the insertion
492         (vhl/add-range beg end)
493       ;; Highlight the position of the deletion
494       (vhl/add-position beg))))
495
496 (defmacro vhl/give-advice-to-make-vhl-on-changes (fn-name)
497   (let* ((ad-name (intern (concat "vhl/make-vhl-on-"
498                                  (format "%s" fn-name)))))
499     (or (symbolp fn-name)
500         (error "vhl/give-advice-to-make-vhl-on-changes: `%s' is not type of symbol." fn-name))
501     `(progn
502        (defadvice ,fn-name (around
503                               ,ad-name
504                               (&rest args))
505          (vhl/.push-to-after-change-hook (quote ,fn-name))
506          (unwind-protect
507              ad-do-it
508            (vhl/.pop-from-after-change-hook (quote ,fn-name))))
509        ;; Enable advice.
510        (ad-enable-advice (quote ,fn-name) 'around (quote ,ad-name))
511        (ad-activate (quote ,fn-name)))))
512
513 (defmacro vhl/cancel-advice-to-make-vhl-on-changes (fn-name)
514   (let ((ad-name (intern (concat "vhl/make-vhl-on-"
515                                  (format "%s" fn-name)))))
516     `(vhl/disable-advice-if-defined (quote ,fn-name) 'around (quote ,ad-name))))
517
518 (defun vhl/require-noerror (feature &optional filename)
519   (condition-case c
520       (require feature)
521     (file-error nil)))
522
523 (eval-and-compile
524 ;; Utility function by Ryan Thompson.
525 (defun vhl/.make-list-string (items)
526   "Makes an English-style list from a list of strings.
527
528 Converts a list of strings into a string that lists the items
529 separated by commas, as well as the word `and' before the last
530 item. In other words, returns a string of the way those items
531 would be listed in english.
532
533 This is included as a private support function for generating
534 lists of symbols to be included docstrings of auto-generated
535 extensions."
536   (assert (listp items))
537   (cond ((null items)
538          ;; Zero items
539          "")
540         ((null (cdr items))
541          ;; One item
542          (assert (stringp (first items)))
543          (format "%s" (first items)))
544         ((null (cddr items))
545          ;; Two items
546          (assert (stringp (first items)))
547          (assert (stringp (second items)))
548          (apply 'format "%s and %s" items))
549         ((null (cdddr items))
550          ;; Three items
551          (assert (stringp (first items)))
552          (assert (stringp (second items)))
553          (assert (stringp (third items)))
554          (apply 'format "%s, %s, and %s" items))
555         (t
556          ;; 4 or more items
557          (format "%s, %s" (first items) (vhl/.make-list-string (rest items)))))))
558
559 ;; The following makes it trivial to define simple vhl extensions
560 (defmacro vhl/define-extension (name &rest functions)
561   "Define a VHL extension called NAME that applies standard VHL
562   advice to each of FUNCTIONS."
563   (assert (first functions))
564   (let* ((name-string (symbol-name (eval name)))
565          (function-list-string (vhl/.make-list-string
566                                 (mapcar (lambda (f) (format "`%s'" (symbol-name (eval f))))
567                                         functions)))
568          (on-function-name (intern (format "vhl/ext/%s/on" name-string)))
569          (on-body-form (cons
570                         'progn
571                         (mapcar (lambda (f)
572                                   `(vhl/give-advice-to-make-vhl-on-changes ,(eval f)))
573                                 functions)))
574          (on-doc-string (format "Turn on volatile highlighting for %s." function-list-string))
575
576          (off-function-name (intern (format "vhl/ext/%s/off" name-string)))
577          (off-body-form (cons
578                          'progn
579                          (mapcar (lambda (f)
580                                    `(vhl/cancel-advice-to-make-vhl-on-changes ,(eval f)))
581                                  functions)))
582          (off-doc-string (format "Turn off volatile highlighting for %s." function-list-string)))
583     `(progn
584        (defun ,on-function-name ()
585          ,on-doc-string
586          (interactive)
587          ,on-body-form)
588        (defun ,off-function-name ()
589          ,off-doc-string
590          (interactive)
591          ,off-body-form)
592        nil)))
593
594
595 ;;;============================================================================
596 ;;;
597 ;;;  Extensions.
598 ;;;
599 ;;;============================================================================
600
601 ;;-----------------------------------------------------------------------------
602 ;; Extension for supporting undo.
603 ;;   -- Put volatile highlights on the text inserted by `undo'.
604 ;;      (and may be `redo'...)
605 ;;-----------------------------------------------------------------------------
606
607 (vhl/define-extension 'undo 'primitive-undo)
608 (vhl/install-extension 'undo)
609
610
611 ;;-----------------------------------------------------------------------------
612 ;; Extension for supporting yank/yank-pop.
613 ;;   -- Put volatile highlights on the text inserted by `yank' or `yank-pop'.
614 ;;-----------------------------------------------------------------------------
615
616 (vhl/define-extension 'yank 'yank 'yank-pop)
617 (vhl/install-extension 'yank)
618
619 ;;-----------------------------------------------------------------------------
620 ;; Extension for supporting kill.
621 ;;   -- Put volatile highlights on the positions where killed text
622 ;;      used to be.
623 ;;-----------------------------------------------------------------------------
624
625 (vhl/define-extension 'kill 'kill-region)
626 (vhl/install-extension 'kill)
627
628 ;;-----------------------------------------------------------------------------
629 ;; Extension for supporting `delete-region'.
630 ;;   -- Put volatile highlights on the positions where deleted text
631 ;;      used to be. This is not so reliable since `delete-region' is
632 ;;      an inline function and is pre-compiled sans advice into many
633 ;;      other deletion functions.
634 ;;-----------------------------------------------------------------------------
635
636 (vhl/define-extension 'delete 'delete-region)
637 (vhl/install-extension 'delete)
638
639
640 ;;-----------------------------------------------------------------------------
641 ;; Extension for supporting etags.
642 ;;   -- Put volatile highlights on the tag name which was found by `find-tag'.
643 ;;-----------------------------------------------------------------------------
644 (defun vhl/ext/etags/on ()
645   "Turn on volatile highlighting for `etags'."
646   (interactive)
647   (require 'etags)
648
649   (defadvice find-tag (after vhl/ext/etags/make-vhl-after-find-tag (tagname &optional next-p regexp-p))
650     (let ((pos (point))
651           (len (length tagname)))
652       (save-excursion
653         (search-forward tagname)
654         (vhl/add-range (- (point) len) (point)))))
655   (ad-activate 'find-tag))
656
657 (defun vhl/ext/etags/off ()
658   "Turn off volatile highlighting for `etags'."
659   (interactive)
660   (vhl/disable-advice-if-defined
661    'find-tag 'after 'vhl/ext/etags/make-vhl-after-find-tag))
662
663 (vhl/install-extension 'etags)
664
665
666 ;;-----------------------------------------------------------------------------
667 ;; Extension for supporting occur.
668 ;;   -- Put volatile highlights on occurrence which is selected by
669 ;;      `occur-mode-goto-occurrence' or `occur-mode-display-occurrence'.
670 ;;-----------------------------------------------------------------------------
671 (defun vhl/ext/occur/on ()
672   "Turn on volatile highlighting for `occur'."
673   (interactive)
674
675   (lexical-let ((*occur-str* nil)) ;; Text in current line.
676     (defun vhl/ext/occur/.pre-hook-fn ()
677       (save-excursion
678         (let* ((bol (progn (beginning-of-line) (point)))
679                (eol (progn (end-of-line) (point)))
680                (bos (text-property-any bol eol 'occur-match t)))
681           (setq *occur-str* (and bos eol
682                                  (buffer-substring bos eol))))))
683
684     (defun vhl/ext/occur/.post-hook-fn ()
685       (let ((marker (and *occur-str*
686                          (get-text-property 0 'occur-target *occur-str*)))
687             (len (length *occur-str*))
688             (ptr 0)
689             (be-lst nil))
690         (when marker
691           ;; Detect position of each occurrence by scanning face
692           ;; `list-matching-lines-face' put on them.
693           (while (and ptr
694                       (setq ptr (text-property-any ptr len
695                                                    'face
696                                                    list-matching-lines-face
697                                                    *occur-str*)))
698             (let ((beg ptr)
699                   (end (or (setq ptr
700                                  (next-single-property-change
701                                   ptr 'face *occur-str*))
702                            ;; Occurrence ends at eol.
703                            len)))
704               (push (list beg end)
705                     be-lst)))
706           ;; Put volatile highlights on occurrences.
707           (with-current-buffer (marker-buffer marker)
708             (let* ((bol (marker-position marker)))
709               (dolist (be be-lst)
710                 (let ((pt-beg (+ bol (nth 0 be)))
711                       (pt-end (+ bol (nth 1 be))))
712                   ;; When the occurrence is in folded line,
713                   ;; put highlight over whole line which
714                   ;; contains folded part.
715                   (dolist (ov (overlays-at pt-beg))
716                     (when (overlay-get ov 'invisible)
717                       ;;(message "INVISIBLE: %s" ov)
718                       (save-excursion
719                         (goto-char (overlay-start ov))
720                         (beginning-of-line)
721                         (setq pt-beg (min pt-beg (point)))
722                         (goto-char (overlay-end ov))
723                         (end-of-line)
724                         (setq pt-end (max pt-end (point))))))
725
726                   (vhl/add-range pt-beg
727                                  pt-end
728                                  nil
729                                  list-matching-lines-face))))))))
730
731
732     (defadvice occur-mode-goto-occurrence (before vhl/ext/occur/pre-hook (&optional event))
733       (vhl/ext/occur/.pre-hook-fn))
734     (defadvice occur-mode-goto-occurrence (after vhl/ext/occur/post-hook (&optional event))
735       (vhl/ext/occur/.post-hook-fn))
736
737     (defadvice occur-mode-display-occurrence (before vhl/ext/occur/pre-hook ())
738       (vhl/ext/occur/.pre-hook-fn))
739     (defadvice occur-mode-display-occurrence (after vhl/ext/occur/post-hook ())
740       (vhl/ext/occur/.post-hook-fn))
741
742     (defadvice occur-mode-goto-occurrence-other-window (before vhl/ext/occur/pre-hook ())
743       (vhl/ext/occur/.pre-hook-fn))
744     (defadvice occur-mode-goto-occurrence-other-window (after vhl/ext/occur/post-hook ())
745       (vhl/ext/occur/.post-hook-fn))
746
747     (ad-activate 'occur-mode-goto-occurrence)
748     (ad-activate 'occur-mode-display-occurrence)
749     (ad-activate 'occur-mode-goto-occurrence-other-window)))
750
751 (defun vhl/ext/occur/off ()
752   "Turn off volatile highlighting for `occur'."
753   (interactive)
754
755   (vhl/disable-advice-if-defined
756    'occur-mode-goto-occurrence 'before 'vhl/ext/occur/pre-hook)
757   (vhl/disable-advice-if-defined
758    'occur-mode-goto-occurrence 'after 'vhl/ext/occur/post-hook)
759
760   (vhl/disable-advice-if-defined
761    'occur-mode-display-occurrence 'before 'vhl/ext/occur/pre-hook)
762   (vhl/disable-advice-if-defined
763    'occur-mode-display-occurrence 'after 'vhl/ext/occur/post-hook)
764
765   (vhl/disable-advice-if-defined
766    'occur-mode-goto-occurrence-other-window 'before 'vhl/ext/occur/pre-hook)
767   (vhl/disable-advice-if-defined
768    'occur-mode-goto-occurrence-other-window 'after 'vhl/ext/occur/post-hook))
769
770 (vhl/install-extension 'occur)
771
772
773 ;;-----------------------------------------------------------------------------
774 ;; Extension for non-incremental search operations.
775 ;;   -- Put volatile highlights on the text found by non-incremental search
776 ;;      operations.
777 ;;-----------------------------------------------------------------------------
778
779 (defmacro vhl/ext/nonincremental-search/.advice-to-vhl (fn)
780   `(when (fboundp (quote ,fn))
781       (defadvice ,fn (after
782                       ,(intern (format "vhl/ext/nonincremental-search/%s"
783                                        fn))
784                       (&rest args))
785         (when ad-return-value
786           (vhl/add-range (match-beginning 0) (match-end 0) nil 'match)))
787       (ad-activate (quote ,fn))))
788
789 (defmacro vhl/ext/nonincremental-search/.disable-advice-to-vhl (fn)
790   `(vhl/disable-advice-if-defined
791     (quote ,fn)
792     'after
793     (quote ,(intern (format "vhl/ext/nonincremental-search/%s" fn)))))
794
795 (defun vhl/ext/nonincremental-search/on ()
796   "Turn on volatile highlighting for non-incremental search operations."
797   (interactive)
798   (when (vhl/require-noerror 'menu-bar nil)
799     (vhl/ext/nonincremental-search/.advice-to-vhl nonincremental-search-forward)
800     (vhl/ext/nonincremental-search/.advice-to-vhl nonincremental-search-backward)
801     (vhl/ext/nonincremental-search/.advice-to-vhl nonincremental-re-search-forward)
802     (vhl/ext/nonincremental-search/.advice-to-vhl nonincremental-re-search-backward)
803     (vhl/ext/nonincremental-search/.advice-to-vhl nonincremental-repeat-search-forward)
804     (vhl/ext/nonincremental-search/.advice-to-vhl nonincremental-repeat-search-backward)))
805
806 (defun vhl/ext/nonincremental-search/off ()
807   "Turn off volatile highlighting for  non-incremental search operations."
808   (interactive)
809   (when (vhl/require-noerror 'menu-bar nil)
810     (vhl/ext/nonincremental-search/.disable-advice-to-vhl nonincremental-search-forward)
811     (vhl/ext/nonincremental-search/.disable-advice-to-vhl nonincremental-search-backward)
812     (vhl/ext/nonincremental-search/.disable-advice-to-vhl nonincremental-re-search-forward)
813     (vhl/ext/nonincremental-search/.disable-advice-to-vhl nonincremental-re-search-backward)
814     (vhl/ext/nonincremental-search/.disable-advice-to-vhl nonincremental-repeat-search-forward)
815     (vhl/ext/nonincremental-search/.disable-advice-to-vhl nonincremental-repeat-search-backward)))
816
817 (vhl/install-extension 'nonincremental-search)
818
819
820 ;;-----------------------------------------------------------------------------
821 ;; Extension for hideshow.
822 ;;   -- Put volatile highlights on the text blocks which are shown/hidden
823 ;;      by hideshow.
824 ;;-----------------------------------------------------------------------------
825
826 (defun vhl/ext/hideshow/.activate ()
827   (defadvice hs-show-block (around vhl/ext/hideshow/vhl/around-hook (&optional end))
828     (let* ((bol (save-excursion (progn (beginning-of-line) (point))))
829            (eol (save-excursion (progn (end-of-line) (point))))
830            (ov-folded (car (delq nil 
831                                  (mapcar #'(lambda (ov)
832                                              (and (overlay-get ov 'hs)
833                                                   ov))
834                                          (overlays-in bol (1+ eol))))))
835            (boov (and ov-folded (overlay-start ov-folded)))
836            (eoov (and ov-folded (overlay-end ov-folded))))
837     
838       ad-do-it
839     
840       (when (and boov eoov)
841         (vhl/add-range boov eoov))))
842   (ad-activate 'hs-show-block))
843
844 (defun vhl/ext/hideshow/on ()
845   "Turn on volatile highlighting for `hideshow'."
846   (interactive)
847   
848   (cond
849    ((featurep 'hideshow)
850     (vhl/ext/hideshow/.activate))
851    (t
852     (eval-after-load "hideshow" '(vhl/ext/hideshow/.activate)))))
853
854 (defun vhl/ext/hideshow/off ()
855   (vhl/disable-advice-if-defined 'hs-show-block
856                                  'after
857                                  'vhl/ext/hideshow/vhl/around-hook))
858
859 (vhl/install-extension 'hideshow)
860
861
862 ;;;============================================================================
863 ;;;
864 ;;;  Suppress compiler warnings regarding to emacs/xemacs private functions.
865 ;;;
866 ;;;============================================================================
867
868 ;; Local variables:
869 ;; byte-compile-warnings: (not unresolved)
870 ;; End:
871
872 ;;; volatile-highlights.el ends here