Commit | Line | Data |
---|---|---|
f1e586e6 | 1 | ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens. |
7a0e7d33 CY |
2 | |
3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009 | |
4 | ;;; Free Software Foundation, Inc. | |
5 | ||
6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
7 | ;; Keywords: syntax | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
13 | ;; the Free Software Foundation, either version 3 of the License, or | |
14 | ;; (at your option) any later version. | |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | ;;; Commentary: | |
25 | ;; | |
26 | ;; Text representing a semantic tag is wrapped in an overlay. | |
27 | ;; This overlay can be used for highlighting, or setting other | |
28 | ;; editing properties on a tag, such as "read only." | |
29 | ;; | |
30 | ||
31 | (require 'semantic) | |
32 | (require 'pulse) | |
33 | ||
34 | ;;; Code: | |
35 | ||
36 | ;;; Highlighting Basics | |
37 | (defun semantic-highlight-tag (tag &optional face) | |
38 | "Specify that TAG should be highlighted. | |
39 | Optional FACE specifies the face to use." | |
40 | (let ((o (semantic-tag-overlay tag))) | |
41 | (semantic-overlay-put o 'old-face | |
42 | (cons (semantic-overlay-get o 'face) | |
43 | (semantic-overlay-get o 'old-face))) | |
44 | (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face)) | |
45 | )) | |
46 | ||
47 | (defun semantic-unhighlight-tag (tag) | |
48 | "Unhighlight TAG, restoring it's previous face." | |
49 | (let ((o (semantic-tag-overlay tag))) | |
50 | (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face))) | |
51 | (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face))) | |
52 | )) | |
53 | ||
54 | ;;; Momentary Highlighting - One line | |
55 | (defun semantic-momentary-highlight-one-tag-line (tag &optional face) | |
56 | "Highlight the first line of TAG, unhighlighting before next command. | |
57 | Optional argument FACE specifies the face to do the highlighting." | |
58 | (save-excursion | |
59 | ;; Go to first line in tag | |
60 | (semantic-go-to-tag tag) | |
61 | (pulse-momentary-highlight-one-line (point)))) | |
62 | ||
63 | ;;; Momentary Highlighting - Whole Tag | |
64 | (defun semantic-momentary-highlight-tag (tag &optional face) | |
65 | "Highlight TAG, removing highlighting when the user hits a key. | |
66 | Optional argument FACE is the face to use for highlighting. | |
67 | If FACE is not specified, then `highlight' will be used." | |
68 | (when (semantic-tag-with-position-p tag) | |
69 | (if (not (semantic-overlay-p (semantic-tag-overlay tag))) | |
70 | ;; No overlay, but a position. Highlight the first line only. | |
71 | (semantic-momentary-highlight-one-tag-line tag face) | |
72 | ;; The tag has an overlay, highlight the whole thing | |
73 | (pulse-momentary-highlight-overlay (semantic-tag-overlay tag) | |
74 | face) | |
75 | ))) | |
76 | ||
77 | (defun semantic-set-tag-face (tag face) | |
78 | "Specify that TAG should use FACE for display." | |
79 | (semantic-overlay-put (semantic-tag-overlay tag) 'face face)) | |
80 | ||
81 | (defun semantic-set-tag-invisible (tag &optional visible) | |
82 | "Enable the text in TAG to be made invisible. | |
83 | If VISIBLE is non-nil, make the text visible." | |
84 | (semantic-overlay-put (semantic-tag-overlay tag) 'invisible | |
85 | (not visible))) | |
86 | ||
87 | (defun semantic-tag-invisible-p (tag) | |
88 | "Return non-nil if TAG is invisible." | |
89 | (semantic-overlay-get (semantic-tag-overlay tag) 'invisible)) | |
90 | ||
91 | (defun semantic-set-tag-intangible (tag &optional tangible) | |
92 | "Enable the text in TAG to be made intangible. | |
93 | If TANGIBLE is non-nil, make the text visible. | |
94 | This function does not have meaning in XEmacs because it seems that | |
95 | the extent 'intangible' property does not exist." | |
96 | (semantic-overlay-put (semantic-tag-overlay tag) 'intangible | |
97 | (not tangible))) | |
98 | ||
99 | (defun semantic-tag-intangible-p (tag) | |
100 | "Return non-nil if TAG is intangible. | |
101 | This function does not have meaning in XEmacs because it seems that | |
102 | the extent 'intangible' property does not exist." | |
103 | (semantic-overlay-get (semantic-tag-overlay tag) 'intangible)) | |
104 | ||
105 | (defun semantic-overlay-signal-read-only | |
106 | (overlay after start end &optional len) | |
107 | "Hook used in modification hooks to prevent modification. | |
108 | Allows deletion of the entire text. | |
109 | Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system." | |
110 | ;; Stolen blithly from cpp.el in Emacs 21.1 | |
111 | (if (and (not after) | |
112 | (or (< (semantic-overlay-start overlay) start) | |
113 | (> (semantic-overlay-end overlay) end))) | |
114 | (error "This text is read only"))) | |
115 | ||
116 | (defun semantic-set-tag-read-only (tag &optional writable) | |
117 | "Enable the text in TAG to be made read-only. | |
118 | Optional argument WRITABLE should be non-nil to make the text writable | |
119 | instead of read-only." | |
120 | (let ((o (semantic-tag-overlay tag)) | |
121 | (hook (if writable nil '(semantic-overlay-signal-read-only)))) | |
122 | (if (featurep 'xemacs) | |
123 | ;; XEmacs extents have a 'read-only' property. | |
124 | (semantic-overlay-put o 'read-only (not writable)) | |
125 | (semantic-overlay-put o 'modification-hooks hook) | |
126 | (semantic-overlay-put o 'insert-in-front-hooks hook) | |
127 | (semantic-overlay-put o 'insert-behind-hooks hook)))) | |
128 | ||
129 | (defun semantic-tag-read-only-p (tag) | |
130 | "Return non-nil if the current TAG is marked read only." | |
131 | (let ((o (semantic-tag-overlay tag))) | |
132 | (if (featurep 'xemacs) | |
133 | ;; XEmacs extents have a 'read-only' property. | |
134 | (semantic-overlay-get o 'read-only) | |
135 | (member 'semantic-overlay-signal-read-only | |
136 | (semantic-overlay-get o 'modification-hooks))))) | |
137 | ||
7a0e7d33 CY |
138 | ;;; Secondary overlays |
139 | ;; | |
140 | ;; Some types of decoration require a second overlay to be made. | |
141 | ;; It could be for images, arrows, or whatever. | |
142 | ;; We need a way to create such an overlay, and make sure it | |
143 | ;; gets whacked, but doesn't show up in the master list | |
144 | ;; of overlays used for searching. | |
145 | (defun semantic-tag-secondary-overlays (tag) | |
146 | "Return a list of secondary overlays active on TAG." | |
147 | (semantic--tag-get-property tag 'secondary-overlays)) | |
148 | ||
149 | (defun semantic-tag-create-secondary-overlay (tag &optional link-hook) | |
150 | "Create a secondary overlay for TAG. | |
151 | Returns an overlay. The overlay is also saved in TAG. | |
152 | LINK-HOOK is a function called whenever TAG is to be linked into | |
153 | a buffer. It should take TAG and OVERLAY as arguments. | |
154 | The LINK-HOOK should be used to position and set properties on the | |
155 | generated secondary overlay." | |
156 | (if (not (semantic-tag-overlay tag)) | |
157 | ;; do nothing if there is no overlay | |
158 | nil | |
159 | (let* ((os (semantic-tag-start tag)) | |
160 | (oe (semantic-tag-end tag)) | |
161 | (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t)) | |
162 | (attr (semantic-tag-secondary-overlays tag)) | |
163 | ) | |
164 | (semantic--tag-put-property tag 'secondary-overlays (cons o attr)) | |
165 | (semantic-overlay-put o 'semantic-secondary t) | |
166 | (semantic-overlay-put o 'semantic-link-hook link-hook) | |
167 | (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) | |
168 | (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) | |
169 | (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) | |
170 | (run-hook-with-args link-hook tag o) | |
171 | o))) | |
172 | ||
173 | (defun semantic-tag-get-secondary-overlay (tag property) | |
174 | "Return secondary overlays from TAG with PROPERTY. | |
175 | PROPERTY is a symbol and all overlays with that symbol are returned.." | |
176 | (let* ((olsearch (semantic-tag-secondary-overlays tag)) | |
177 | (o nil)) | |
178 | (while olsearch | |
179 | (when (semantic-overlay-get (car olsearch) property) | |
180 | (setq o (cons (car olsearch) o))) | |
181 | (setq olsearch (cdr olsearch))) | |
182 | o)) | |
183 | ||
184 | (defun semantic-tag-delete-secondary-overlay (tag overlay-or-property) | |
185 | "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY. | |
186 | If OVERLAY-OR-PROPERTY is an overlay, delete that overlay. | |
187 | If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property." | |
188 | (let* ((o overlay-or-property)) | |
189 | (if (semantic-overlay-p o) | |
190 | (setq o (list o)) | |
191 | (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property))) | |
192 | (while (semantic-overlay-p (car o)) | |
193 | ;; We don't really need to worry about the hooks. | |
194 | ;; They will clean themselves up eventually ?? | |
195 | (semantic--tag-put-property | |
196 | tag 'secondary-overlays | |
197 | (delete (car o) (semantic-tag-secondary-overlays tag))) | |
198 | (semantic-overlay-delete (car o)) | |
199 | (setq o (cdr o))))) | |
200 | ||
201 | (defun semantic--tag-unlink-copy-secondary-overlays (tag) | |
202 | "Unlink secondary overlays from TAG which is a copy. | |
203 | This means we don't destroy the overlays, only remove reference | |
204 | from them in TAG." | |
205 | (let ((ol (semantic-tag-secondary-overlays tag))) | |
206 | (while ol | |
207 | ;; Else, remove all traces of ourself from the tag | |
208 | ;; Note to self: Does this prevent multiple types of secondary | |
209 | ;; overlays per tag? | |
210 | (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) | |
211 | (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) | |
212 | (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) | |
213 | ;; Next! | |
214 | (setq ol (cdr ol))) | |
215 | (semantic--tag-put-property tag 'secondary-overlays nil) | |
216 | )) | |
217 | ||
218 | (defun semantic--tag-unlink-secondary-overlays (tag) | |
219 | "Unlink secondary overlays from TAG." | |
220 | (let ((ol (semantic-tag-secondary-overlays tag)) | |
221 | (nl nil)) | |
222 | (while ol | |
223 | (if (semantic-overlay-get (car ol) 'semantic-link-hook) | |
224 | ;; Only put in a proxy if there is a link-hook. If there is no link-hook | |
225 | ;; the decorating mode must know when tags are unlinked on its own. | |
226 | (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook) | |
227 | nl)) | |
228 | ;; Else, remove all traces of ourself from the tag | |
229 | ;; Note to self: Does this prevent multiple types of secondary | |
230 | ;; overlays per tag? | |
231 | (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) | |
232 | (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) | |
233 | (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) | |
234 | ) | |
235 | (semantic-overlay-delete (car ol)) | |
236 | (setq ol (cdr ol))) | |
237 | (semantic--tag-put-property tag 'secondary-overlays (nreverse nl)) | |
238 | )) | |
239 | ||
240 | (defun semantic--tag-link-secondary-overlays (tag) | |
241 | "Unlink secondary overlays from TAG." | |
242 | (let ((ol (semantic-tag-secondary-overlays tag))) | |
243 | ;; Wipe out old values. | |
244 | (semantic--tag-put-property tag 'secondary-overlays nil) | |
245 | ;; Run all the link hooks. | |
246 | (while ol | |
247 | (semantic-tag-create-secondary-overlay tag (car ol)) | |
248 | (setq ol (cdr ol))) | |
249 | )) | |
250 | ||
251 | ;;; Secondary Overlay Uses | |
252 | ;; | |
253 | ;; States to put on tags that depend on a secondary overlay. | |
254 | (defun semantic-set-tag-folded (tag &optional folded) | |
255 | "Fold TAG, such that only the first line of text is shown. | |
256 | Optional argument FOLDED should be non-nil to fold the tag. | |
257 | nil implies the tag should be fully shown." | |
258 | ;; If they are different, do the deed. | |
259 | (let ((o (semantic-tag-folded-p tag))) | |
260 | (if (not folded) | |
261 | ;; We unfold. | |
262 | (when o | |
263 | (semantic-tag-delete-secondary-overlay tag 'semantic-folded)) | |
264 | (unless o | |
265 | ;; Add the foldn | |
266 | (setq o (semantic-tag-create-secondary-overlay tag)) | |
267 | ;; mark as folded | |
268 | (semantic-overlay-put o 'semantic-folded t) | |
269 | ;; Move to cover end of tag | |
270 | (save-excursion | |
271 | (goto-char (semantic-tag-start tag)) | |
272 | (end-of-line) | |
273 | (semantic-overlay-move o (point) (semantic-tag-end tag))) | |
274 | ;; We need to modify the invisibility spec for this to | |
275 | ;; work. | |
276 | (if (or (eq buffer-invisibility-spec t) | |
277 | (not (assoc 'semantic-fold buffer-invisibility-spec))) | |
278 | (add-to-invisibility-spec '(semantic-fold . t))) | |
279 | (semantic-overlay-put o 'invisible 'semantic-fold) | |
280 | (overlay-put o 'isearch-open-invisible | |
281 | 'semantic-set-tag-folded-isearch))) | |
282 | )) | |
283 | ||
978c25c6 CY |
284 | (declare-function semantic-current-tag "semantic/find") |
285 | ||
7a0e7d33 CY |
286 | (defun semantic-set-tag-folded-isearch (overlay) |
287 | "Called by isearch if it discovers text in the folded region. | |
288 | OVERLAY is passed in by isearch." | |
289 | (semantic-set-tag-folded (semantic-current-tag) nil) | |
290 | ) | |
291 | ||
292 | (defun semantic-tag-folded-p (tag) | |
293 | "Non-nil if TAG is currently folded." | |
294 | (semantic-tag-get-secondary-overlay tag 'semantic-folded) | |
295 | ) | |
296 | ||
297 | (provide 'semantic/decorate) | |
298 | ||
3999968a | 299 | ;; arch-tag: 30e5b6cb-dba0-41cd-920a-bc1dce267ad8 |
f1e586e6 | 300 | ;;; semantic/decorate.el ends here |