1 ;;; semantic/decorate/mode.el --- Minor mode for decorating tags
3 ;; Copyright (C) 2000-2005, 2007-2013 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; A minor mode for use in decorating tags.
27 ;; There are two types of decorations that can be performed on a tag.
28 ;; You can either highlight the full tag, or you can add an
29 ;; independent decoration on some part of the tag body.
31 ;; For independent decoration in particular, managing them so that they
32 ;; do not get corrupted is challenging. This major mode and
33 ;; corresponding macros will make handling those types of decorations
38 (eval-when-compile (require 'cl))
40 (require 'semantic/decorate)
41 (require 'semantic/tag-ls)
42 (require 'semantic/util-modes)
46 (defcustom semantic-decoration-styles nil
47 "List of active decoration styles.
48 It is an alist of \(NAME . FLAG) elements, where NAME is a style name
49 and FLAG is non-nil if the style is enabled.
50 See also `define-semantic-decoration-style' which will automatically
51 add items to this list."
53 :type '(repeat (cons (string :tag "Decoration Name")
54 (boolean :tag "Enabled")))
59 (defsubst semantic-decorate-style-predicate (style)
60 "Return the STYLE's predicate function."
61 (intern (format "%s-p" style)))
63 (defsubst semantic-decorate-style-highlighter (style)
64 "Return the STYLE's highlighter function."
65 (intern (format "%s-highlight" style)))
67 (defsubst semantic-decorate-style-predicate-default (style)
68 "Return the STYLE's predicate function."
69 (intern (format "%s-p-default" style)))
71 (defsubst semantic-decorate-style-highlighter-default (style)
72 "Return the STYLE's highlighter function."
73 (intern (format "%s-highlight-default" style)))
75 ;;; Base decoration API
77 (defsubst semantic-decoration-p (object)
78 "Return non-nil if OBJECT is a tag decoration."
79 (and (semantic-overlay-p object)
80 (semantic-overlay-get object 'semantic-decoration)))
82 (defsubst semantic-decoration-set-property (deco property value)
83 "Set the DECO decoration's PROPERTY to VALUE.
85 (assert (semantic-decoration-p deco))
86 (semantic-overlay-put deco property value)
89 (defsubst semantic-decoration-get-property (deco property)
90 "Return the DECO decoration's PROPERTY value."
91 (assert (semantic-decoration-p deco))
92 (semantic-overlay-get deco property))
94 (defsubst semantic-decoration-set-face (deco face)
95 "Set the face of the decoration DECO to FACE.
97 (semantic-decoration-set-property deco 'face face))
99 (defsubst semantic-decoration-face (deco)
100 "Return the face of the decoration DECO."
101 (semantic-decoration-get-property deco 'face))
103 (defsubst semantic-decoration-set-priority (deco priority)
104 "Set the priority of the decoration DECO to PRIORITY.
106 (assert (natnump priority))
107 (semantic-decoration-set-property deco 'priority priority))
109 (defsubst semantic-decoration-priority (deco)
110 "Return the priority of the decoration DECO."
111 (semantic-decoration-get-property deco 'priority))
113 (defsubst semantic-decoration-move (deco begin end)
114 "Move the decoration DECO on the region between BEGIN and END.
116 (assert (semantic-decoration-p deco))
117 (semantic-overlay-move deco begin end)
122 (defun semantic-decorate-tag (tag begin end &optional face)
123 "Add a new decoration on TAG on the region between BEGIN and END.
124 If optional argument FACE is non-nil, set the decoration's face to
126 Return the overlay that makes up the new decoration."
127 (let ((deco (semantic-tag-create-secondary-overlay tag)))
128 ;; We do not use the unlink property because we do not want to
129 ;; save the highlighting information in the DB.
130 (semantic-overlay-put deco 'semantic-decoration t)
131 (semantic-decoration-move deco begin end)
132 (semantic-decoration-set-face deco face)
135 (defun semantic-decorate-clear-tag (tag &optional deco)
136 "Remove decorations from TAG.
137 If optional argument DECO is non-nil, remove only that decoration."
138 (assert (or (null deco) (semantic-decoration-p deco)))
139 ;; Clear primary decorations.
140 ;; For now, just unhighlight the tag. How to deal with other
141 ;; primary decorations like invisibility, etc. ? Maybe just
142 ;; restoring default values will suffice?
143 (semantic-unhighlight-tag tag)
144 (semantic-tag-delete-secondary-overlay
145 tag (or deco 'semantic-decoration)))
147 (defun semantic-decorate-tag-decoration (tag)
148 "Return decoration found on TAG."
149 (semantic-tag-get-secondary-overlay tag 'semantic-decoration))
151 ;;; Global setup of active decorations
153 (defun semantic-decorate-flush-decorations (&optional buffer)
154 "Flush decorations found in BUFFER.
155 BUFFER defaults to the current buffer.
156 Should be used to flush decorations that might remain in BUFFER, for
157 example, after tags have been refreshed."
158 (with-current-buffer (or buffer (current-buffer))
159 (dolist (o (semantic-overlays-in (point-min) (point-max)))
160 (and (semantic-decoration-p o)
161 (semantic-overlay-delete o)))))
163 (defun semantic-decorate-clear-decorations (tag-list)
164 "Remove decorations found in tags in TAG-LIST."
165 (dolist (tag tag-list)
166 (semantic-decorate-clear-tag tag)
167 ;; recurse over children
168 (semantic-decorate-clear-decorations
169 (semantic-tag-components-with-overlays tag))))
171 (defun semantic-decorate-add-decorations (tag-list)
172 "Add decorations to tags in TAG-LIST.
173 Also make sure old decorations in the area are completely flushed."
174 (dolist (tag tag-list)
175 ;; Cleanup old decorations.
176 (when (semantic-decorate-tag-decoration tag)
177 ;; Note on below comment. This happens more as decorations are refreshed
178 ;; mid-way through their use. Remove the message.
180 ;; It would be nice if this never happened, but it still does
181 ;; once in a while. Print a message to help flush these
183 ;;(message "Decorations still on %s" (semantic-format-tag-name tag))
184 (semantic-decorate-clear-tag tag))
185 ;; Add new decorations.
186 (dolist (style semantic-decoration-styles)
187 (let ((pred (semantic-decorate-style-predicate (car style)))
188 (high (semantic-decorate-style-highlighter (car style))))
193 (funcall high tag))))
194 ;; Recurse on the children of all tags
195 (semantic-decorate-add-decorations
196 (semantic-tag-components-with-overlays tag))))
198 ;;; PENDING DECORATIONS
200 ;; Activities in Emacs may cause a decoration to change state. Any
201 ;; such identified change ought to be setup as PENDING. This means
202 ;; that the next idle step will do the decoration change, but at the
203 ;; time of the state change, minimal work would be done.
204 (defvar semantic-decorate-pending-decoration-hook nil
205 "Normal hook run to perform pending decoration changes.")
207 (semantic-varalias-obsolete 'semantic-decorate-pending-decoration-hooks
208 'semantic-decorate-pending-decoration-hook "23.2")
210 (defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
211 "Add a pending decoration change represented by FCN.
212 Applies only to the current BUFFER.
213 The setting of FCN will be removed after it is run."
215 (when buffer (set-buffer buffer))
216 (semantic-make-local-hook 'semantic-decorate-flush-pending-decorations)
217 (add-hook 'semantic-decorate-pending-decoration-hook fcn nil t)))
219 (defun semantic-decorate-flush-pending-decorations (&optional buffer)
220 "Flush any pending decorations for BUFFER.
221 Flush functions from `semantic-decorate-pending-decoration-hook'."
223 (when buffer (set-buffer buffer))
224 (run-hooks 'semantic-decorate-pending-decoration-hook)
225 ;; Always reset the hooks
226 (setq semantic-decorate-pending-decoration-hook nil)))
231 ;; Generic mode for handling basic highlighting and decorations.
235 (define-minor-mode global-semantic-decoration-mode
236 "Toggle global use of option `semantic-decoration-mode'.
237 Decoration mode turns on all active decorations as specified
238 by `semantic-decoration-styles'."
239 :global t :group 'semantic :group 'semantic-modes
240 ;; Not needed because it's autoloaded instead.
241 ;; :require 'semantic/decorate/mode
242 (semantic-toggle-minor-mode-globally
243 'semantic-decoration-mode (if global-semantic-decoration-mode 1 -1)))
245 (defcustom semantic-decoration-mode-hook nil
246 "Hook run at the end of function `semantic-decoration-mode'."
250 (define-minor-mode semantic-decoration-mode
251 "Minor mode for decorating tags.
252 Decorations are specified in `semantic-decoration-styles'.
253 You can define new decoration styles with
254 `define-semantic-decoration-style'.
255 With prefix argument ARG, turn on if positive, otherwise off. The
256 minor mode can be turned on only if semantic feature is available and
257 the current buffer was set up for parsing. Return non-nil if the
258 minor mode is enabled."
260 ;;\\{semantic-decoration-map}"
262 (if semantic-decoration-mode
263 (if (not (and (featurep 'semantic) (semantic-active-p)))
265 ;; Disable minor mode if semantic stuff not available
266 (setq semantic-decoration-mode nil)
267 (error "Buffer %s was not set up for parsing"
270 (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
271 (add-hook 'semantic-after-partial-cache-change-hook
272 'semantic-decorate-tags-after-partial-reparse nil t)
273 (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
274 (add-hook 'semantic-after-toplevel-cache-change-hook
275 'semantic-decorate-tags-after-full-reparse nil t)
276 ;; Add decorations to available tags. The above hooks ensure
277 ;; that new tags will be decorated when they become available.
278 (semantic-decorate-add-decorations (semantic-fetch-available-tags)))
279 ;; Remove decorations from available tags.
280 (semantic-decorate-clear-decorations (semantic-fetch-available-tags))
281 ;; Cleanup any leftover crap too.
282 (semantic-decorate-flush-decorations)
284 (remove-hook 'semantic-after-partial-cache-change-hook
285 'semantic-decorate-tags-after-partial-reparse t)
286 (remove-hook 'semantic-after-toplevel-cache-change-hook
287 'semantic-decorate-tags-after-full-reparse t)))
289 (semantic-add-minor-mode 'semantic-decoration-mode
292 (defun semantic-decorate-tags-after-full-reparse (tag-list)
293 "Add decorations after a complete reparse of the current buffer.
294 TAG-LIST is the list of tags recently parsed.
295 Flush all existing decorations and call `semantic-decorate-add-decorations' to
297 Called from `semantic-after-toplevel-cache-change-hook'."
299 (semantic-decorate-flush-decorations)
301 (semantic-decorate-add-decorations tag-list))
303 (defun semantic-decorate-tags-after-partial-reparse (tag-list)
304 "Add decorations when new tags are created in the current buffer.
305 TAG-LIST is the list of newly created tags.
306 Call `semantic-decorate-add-decorations' to add decorations.
307 Called from `semantic-after-partial-cache-change-hook'."
308 (semantic-decorate-add-decorations tag-list))
311 ;;; Enable/Disable toggling
313 (defun semantic-decoration-style-enabled-p (style)
314 "Return non-nil if STYLE is currently enabled.
315 Return nil if the style is disabled, or does not exist."
316 (let ((pair (assoc style semantic-decoration-styles)))
317 (and pair (cdr pair))))
319 (defun semantic-toggle-decoration-style (name &optional arg)
320 "Turn on/off the decoration style with NAME.
321 Decorations are specified in `semantic-decoration-styles'.
322 With prefix argument ARG, turn on if positive, otherwise off.
323 Return non-nil if the decoration style is enabled."
325 (list (completing-read "Decoration style: "
326 semantic-decoration-styles nil t)
328 (setq name (format "%s" name)) ;; Ensure NAME is a string.
329 (unless (equal name "")
330 (let* ((style (assoc name semantic-decoration-styles))
332 (> (prefix-numeric-value arg) 0)
335 (error "Unknown decoration style %s" name))
336 (unless (eq (cdr style) flag)
337 ;; Store the new flag.
339 ;; Refresh decorations is `semantic-decoration-mode' is on.
340 (when semantic-decoration-mode
341 (semantic-decoration-mode -1)
342 (semantic-decoration-mode 1))
343 (when (called-interactively-p 'interactive)
344 (message "Decoration style %s turned %s" (car style)
345 (if flag "on" "off"))))
348 (defvar semantic-decoration-menu-cache nil
349 "Cache of the decoration menu.")
351 (defun semantic-decoration-build-style-menu (style)
352 "Build a menu item for controlling a specific decoration STYLE."
354 `(lambda () (interactive)
355 (semantic-toggle-decoration-style
358 :selected `(semantic-decoration-style-enabled-p ,(car style))
361 (defun semantic-build-decoration-mode-menu (&rest ignore)
362 "Create a menu listing all the known decorations for toggling.
363 IGNORE any input arguments."
364 (or semantic-decoration-menu-cache
365 (setq semantic-decoration-menu-cache
366 (mapcar 'semantic-decoration-build-style-menu
367 (reverse semantic-decoration-styles))
371 ;;; Defining decoration styles
373 (defmacro define-semantic-decoration-style (name doc &rest flags)
374 "Define a new decoration style with NAME.
375 DOC is a documentation string describing the decoration style NAME.
376 It is appended to auto-generated doc strings.
377 An optional list of FLAGS can also be specified. Flags are:
378 :enabled <value> - specify the default enabled value for NAME.
379 :load <value> - specify a feature (as a string) with the rest of
380 the definition for decoration mode NAME.
382 This defines two new overload functions respectively called `NAME-p'
383 and `NAME-highlight', for which you must provide a default
384 implementation in respectively the functions `NAME-p-default' and
385 `NAME-highlight-default'. Those functions are passed a tag. `NAME-p'
386 must return non-nil to indicate that the tag should be decorated by
389 To put primary decorations on a tag `NAME-highlight' must use
390 functions like `semantic-set-tag-face', `semantic-set-tag-intangible',
391 etc., found in the semantic-decorate library.
393 To add other kind of decorations on a tag, `NAME-highlight' must use
394 `semantic-decorate-tag', and other functions of the semantic
395 decoration API found in this library."
396 (let ((predicate (semantic-decorate-style-predicate name))
397 (highlighter (semantic-decorate-style-highlighter name))
398 (predicatedef (semantic-decorate-style-predicate-default name))
399 (highlighterdef (semantic-decorate-style-highlighter-default name))
400 (defaultenable (if (plist-member flags :enabled)
401 (plist-get flags :enabled)
403 (loadfile (if (plist-member flags :load)
404 (plist-get flags :load)
408 ;; Clear the menu cache so that new items are added when
410 (setq semantic-decoration-menu-cache nil)
411 ;; Create an override method to specify if a given tag belongs
412 ;; to this type of decoration
413 (define-overloadable-function ,predicate (tag)
414 ,(format "Return non-nil to decorate TAG with `%s' style.\n%s"
416 ;; Create an override method that will perform the highlight
417 ;; operation if the -p method returns non-nil.
418 (define-overloadable-function ,highlighter (tag)
419 ,(format "Decorate TAG with `%s' style.\n%s"
421 ;; Add this to the list of primary decoration modes.
422 (add-to-list 'semantic-decoration-styles
423 (cons ',(symbol-name name)
425 ;; If there is a load file, then create the autoload tokens for
426 ;; those functions to load the token, but only if the fsym
427 ;; doesn't exist yet.
428 (when (stringp ,loadfile)
429 (unless (fboundp ',predicatedef)
430 (autoload ',predicatedef ',loadfile "Return non-nil to decorate TAG."
433 (unless (fboundp ',highlighterdef)
434 (autoload ',highlighterdef ',loadfile "Decorate TAG."))
438 ;;; Predefined decoration styles
441 ;;; Tag boundaries highlighting
443 (define-semantic-decoration-style semantic-tag-boundary
444 "Place an overline in front of each long tag.
445 Does not provide overlines for prototypes.")
447 (defface semantic-tag-boundary-face
448 '((((class color) (background dark))
450 (((class color) (background light))
452 "*Face used to show long tags in.
453 Used by decoration style: `semantic-tag-boundary'."
454 :group 'semantic-faces)
456 (defun semantic-tag-boundary-p-default (tag)
457 "Return non-nil if TAG is a type, or a non-prototype function."
458 (let ((c (semantic-tag-class tag)))
461 ;; All types get a line?
463 ;; Functions which aren't prototypes get a line.
464 (and (eq c 'function)
465 (not (semantic-tag-get-attribute tag :prototype-flag)))
467 ;; Note: The below restriction confused users.
469 ;; Nothing smaller than a few lines
470 ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
475 (defun semantic-tag-boundary-highlight-default (tag)
476 "Highlight the first line of TAG as a boundary."
477 (when (bufferp (semantic-tag-buffer tag))
478 (with-current-buffer (semantic-tag-buffer tag)
479 (semantic-decorate-tag
481 (semantic-tag-start tag)
483 (goto-char (semantic-tag-start tag))
487 'semantic-tag-boundary-face))
490 ;;; Private member highlighting
492 (define-semantic-decoration-style semantic-decoration-on-private-members
493 "Highlight class members that are designated as PRIVATE access."
496 (defface semantic-decoration-on-private-members-face
497 '((((class color) (background dark))
498 (:background "#200000"))
499 (((class color) (background light))
500 (:background "#8fffff")))
501 "*Face used to show privately scoped tags in.
502 Used by the decoration style: `semantic-decoration-on-private-members'."
503 :group 'semantic-faces)
505 (defun semantic-decoration-on-private-members-highlight-default (tag)
506 "Highlight TAG as designated to have PRIVATE access.
507 Use a primary decoration."
508 (semantic-set-tag-face
509 tag 'semantic-decoration-on-private-members-face))
511 (defun semantic-decoration-on-private-members-p-default (tag)
512 "Return non-nil if TAG has PRIVATE access."
513 (and (member (semantic-tag-class tag) '(function variable))
514 (eq (semantic-tag-protection tag) 'private)))
516 ;;; Protected member highlighting
518 (defface semantic-decoration-on-protected-members-face
519 '((((class color) (background dark))
520 (:background "#000020"))
521 (((class color) (background light))
522 (:background "#fffff8")))
523 "*Face used to show protected scoped tags in.
524 Used by the decoration style: `semantic-decoration-on-protected-members'."
525 :group 'semantic-faces)
527 (define-semantic-decoration-style semantic-decoration-on-protected-members
528 "Highlight class members that are designated as PROTECTED access."
531 (defun semantic-decoration-on-protected-members-p-default (tag)
532 "Return non-nil if TAG has PROTECTED access."
533 (and (member (semantic-tag-class tag) '(function variable))
534 (eq (semantic-tag-protection tag) 'protected)))
536 (defun semantic-decoration-on-protected-members-highlight-default (tag)
537 "Highlight TAG as designated to have PROTECTED access.
538 Use a primary decoration."
539 (semantic-set-tag-face
540 tag 'semantic-decoration-on-protected-members-face))
542 ;;; Decoration Modes in other files
544 (declare-function semantic-decoration-on-includes-p-default
545 "semantic/decorate/include")
546 (declare-function semantic-decoration-on-includes-highlight-default
547 "semantic/decorate/include")
548 (define-semantic-decoration-style semantic-decoration-on-includes
549 "Highlight class members that are includes.
550 This mode provides a nice context menu on the include statements."
552 :load "semantic/decorate/include")
556 (provide 'semantic/decorate/mode)
559 ;; generated-autoload-file: "../loaddefs.el"
560 ;; generated-autoload-load-name: "semantic/decorate/mode"
563 ;;; semantic/decorate/mode.el ends here