lisp/cedet/semantic/decorate.el

   1 ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
   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
 138 ;;; backwards compatability
 139
 140 (semantic-alias-obsolete 'semantic-highlight-token
 141                          'semantic-highlight-tag)
 142 (semantic-alias-obsolete 'semantic-unhighlight-token
 143                          'semantic-unhighlight-tag)
 144 (semantic-alias-obsolete 'semantic-momentary-highlight-token
 145                          'semantic-momentary-highlight-tag)
 146 (semantic-alias-obsolete 'semantic-set-token-face
 147                          'semantic-set-tag-face)
 148 (semantic-alias-obsolete 'semantic-set-token-invisible
 149                          'semantic-set-tag-invisible)
 150 (semantic-alias-obsolete 'semantic-token-invisible-p
 151                          'semantic-tag-invisible-p)
 152 (semantic-alias-obsolete 'semantic-set-token-intangible
 153                          'semantic-set-tag-intangible)
 154 (semantic-alias-obsolete 'semantic-token-intangible-p
 155                          'semantic-tag-intangible-p)
 156 (semantic-alias-obsolete 'semantic-set-token-read-only
 157                          'semantic-set-tag-read-only)
 158 (semantic-alias-obsolete 'semantic-token-read-only-p
 159                          'semantic-tag-read-only-p)
 160
 161 ;;; Secondary overlays
 162 ;;
 163 ;; Some types of decoration require a second overlay to be made.
 164 ;; It could be for images, arrows, or whatever.
 165 ;; We need a way to create such an overlay, and make sure it
 166 ;; gets whacked, but doesn't show up in the master list
 167 ;; of overlays used for searching.
 168 (defun semantic-tag-secondary-overlays (tag)
 169   "Return a list of secondary overlays active on TAG."
 170   (semantic--tag-get-property tag 'secondary-overlays))
 171
 172 (defun semantic-tag-create-secondary-overlay (tag &optional link-hook)
 173   "Create a secondary overlay for TAG.
 174 Returns an overlay.  The overlay is also saved in TAG.
 175 LINK-HOOK is a function called whenever TAG is to be linked into
 176 a buffer.  It should take TAG and OVERLAY as arguments.
 177 The LINK-HOOK should be used to position and set properties on the
 178 generated secondary overlay."
 179   (if (not (semantic-tag-overlay tag))
 180       ;; do nothing if there is no overlay
 181       nil
 182     (let* ((os (semantic-tag-start tag))
 183            (oe (semantic-tag-end tag))
 184            (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t))
 185            (attr (semantic-tag-secondary-overlays tag))
 186            )
 187       (semantic--tag-put-property tag 'secondary-overlays (cons o attr))
 188       (semantic-overlay-put o 'semantic-secondary t)
 189       (semantic-overlay-put o 'semantic-link-hook link-hook)
 190       (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 191       (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 192       (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 193       (run-hook-with-args link-hook tag o)
 194       o)))
 195
 196 (defun semantic-tag-get-secondary-overlay (tag property)
 197   "Return secondary overlays from TAG with PROPERTY.
 198 PROPERTY is a symbol and all overlays with that symbol are returned.."
 199   (let* ((olsearch (semantic-tag-secondary-overlays tag))
 200          (o nil))
 201     (while olsearch
 202       (when (semantic-overlay-get (car olsearch) property)
 203         (setq o (cons (car olsearch) o)))
 204       (setq olsearch (cdr olsearch)))
 205     o))
 206
 207 (defun semantic-tag-delete-secondary-overlay (tag overlay-or-property)
 208   "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY.
 209 If OVERLAY-OR-PROPERTY is an overlay, delete that overlay.
 210 If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property."
 211   (let* ((o overlay-or-property))
 212     (if (semantic-overlay-p o)
 213         (setq o (list o))
 214       (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property)))
 215     (while (semantic-overlay-p (car o))
 216       ;; We don't really need to worry about the hooks.
 217       ;; They will clean themselves up eventually ??
 218       (semantic--tag-put-property
 219        tag 'secondary-overlays
 220        (delete (car o) (semantic-tag-secondary-overlays tag)))
 221       (semantic-overlay-delete (car o))
 222       (setq o (cdr o)))))
 223
 224 (defun semantic--tag-unlink-copy-secondary-overlays (tag)
 225   "Unlink secondary overlays from TAG which is a copy.
 226 This means we don't destroy the overlays, only remove reference
 227 from them in TAG."
 228   (let ((ol (semantic-tag-secondary-overlays tag)))
 229     (while ol
 230       ;; Else, remove all  traces of ourself from the tag
 231       ;; Note to self: Does this prevent multiple types of secondary
 232       ;; overlays per tag?
 233       (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 234       (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 235       (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 236       ;; Next!
 237       (setq ol (cdr ol)))
 238     (semantic--tag-put-property tag 'secondary-overlays nil)
 239     ))
 240
 241 (defun semantic--tag-unlink-secondary-overlays (tag)
 242   "Unlink secondary overlays from TAG."
 243   (let ((ol (semantic-tag-secondary-overlays tag))
 244         (nl nil))
 245     (while ol
 246       (if (semantic-overlay-get (car ol) 'semantic-link-hook)
 247           ;; Only put in a proxy if there is a link-hook.  If there is no link-hook
 248           ;; the decorating mode must know when tags are unlinked on its own.
 249           (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook)
 250                          nl))
 251         ;; Else, remove all  traces of ourself from the tag
 252         ;; Note to self: Does this prevent multiple types of secondary
 253         ;; overlays per tag?
 254         (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 255         (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 256         (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 257         )
 258       (semantic-overlay-delete (car ol))
 259       (setq ol (cdr ol)))
 260     (semantic--tag-put-property tag 'secondary-overlays (nreverse nl))
 261     ))
 262
 263 (defun semantic--tag-link-secondary-overlays (tag)
 264   "Unlink secondary overlays from TAG."
 265   (let ((ol (semantic-tag-secondary-overlays tag)))
 266     ;; Wipe out old values.
 267     (semantic--tag-put-property tag 'secondary-overlays nil)
 268     ;; Run all the link hooks.
 269     (while ol
 270       (semantic-tag-create-secondary-overlay tag (car ol))
 271       (setq ol (cdr ol)))
 272     ))
 273
 274 ;;; Secondary Overlay Uses
 275 ;;
 276 ;; States to put on tags that depend on a secondary overlay.
 277 (defun semantic-set-tag-folded (tag &optional folded)
 278   "Fold TAG, such that only the first line of text is shown.
 279 Optional argument FOLDED should be non-nil to fold the tag.
 280 nil implies the tag should be fully shown."
 281     ;; If they are different, do the deed.
 282     (let ((o (semantic-tag-folded-p tag)))
 283       (if (not folded)
 284           ;; We unfold.
 285           (when o
 286             (semantic-tag-delete-secondary-overlay tag 'semantic-folded))
 287         (unless o
 288           ;; Add the foldn
 289           (setq o (semantic-tag-create-secondary-overlay tag))
 290           ;; mark as folded
 291           (semantic-overlay-put o 'semantic-folded t)
 292           ;; Move to cover end of tag
 293           (save-excursion
 294             (goto-char (semantic-tag-start tag))
 295             (end-of-line)
 296             (semantic-overlay-move o (point) (semantic-tag-end tag)))
 297           ;; We need to modify the invisibility spec for this to
 298           ;; work.
 299           (if (or (eq buffer-invisibility-spec t)
 300                   (not (assoc 'semantic-fold buffer-invisibility-spec)))
 301               (add-to-invisibility-spec '(semantic-fold . t)))
 302           (semantic-overlay-put o 'invisible 'semantic-fold)
 303           (overlay-put o 'isearch-open-invisible
 304                        'semantic-set-tag-folded-isearch)))
 305           ))
 306
 307 (declare-function semantic-current-tag "semantic/find")
 308
 309 (defun semantic-set-tag-folded-isearch (overlay)
 310   "Called by isearch if it discovers text in the folded region.
 311 OVERLAY is passed in by isearch."
 312   (semantic-set-tag-folded (semantic-current-tag) nil)
 313   )
 314
 315 (defun semantic-tag-folded-p (tag)
 316   "Non-nil if TAG is currently folded."
 317   (semantic-tag-get-secondary-overlay tag 'semantic-folded)
 318   )
 319
 320 (provide 'semantic/decorate)
 321
 322 ;;; semantic/decorate.el ends here