| 1 | ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens. |
| 2 | |
| 3 | ;;; Copyright (C) 1999-2003, 2005-2007, 2009-2011 |
| 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 its 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 | |
| 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 | |
| 284 | (declare-function semantic-current-tag "semantic/find") |
| 285 | |
| 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 | |
| 299 | ;;; semantic/decorate.el ends here |