lisp/cedet/semantic/decorate.el

   1 ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
   2
   3 ;;; Copyright (C) 1999-2003, 2005-2007, 2009-2014 Free Software
   4 ;;; 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 blithely 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