.emacs.d.git - Gitblit

Chizi123

2018-11-21 e75a20334813452c6912c090d70a0de2c805f94d

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