lisp/cedet/semantic/decorate.el

   1 ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
   2
   3 ;;; Copyright (C) 1999-2003, 2005-2007, 2009-2017 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-overlay-signal-read-only
  92   (overlay after start end &optional len)
  93   "Hook used in modification hooks to prevent modification.
  94 Allows deletion of the entire text.
  95 Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
  96   ;; Stolen blithely from cpp.el in Emacs 21.1
  97   (if (and (not after)
  98            (or (< (semantic-overlay-start overlay) start)
  99                (> (semantic-overlay-end overlay) end)))
 100       (error "This text is read only")))
 101
 102 (defun semantic-set-tag-read-only (tag &optional writable)
 103   "Enable the text in TAG to be made read-only.
 104 Optional argument WRITABLE should be non-nil to make the text writable
 105 instead of read-only."
 106   (let ((o (semantic-tag-overlay tag))
 107         (hook (if writable nil '(semantic-overlay-signal-read-only))))
 108     (if (featurep 'xemacs)
 109         ;; XEmacs extents have a 'read-only' property.
 110         (semantic-overlay-put o 'read-only (not writable))
 111       (semantic-overlay-put o 'modification-hooks hook)
 112       (semantic-overlay-put o 'insert-in-front-hooks hook)
 113       (semantic-overlay-put o 'insert-behind-hooks hook))))
 114
 115 (defun semantic-tag-read-only-p (tag)
 116   "Return non-nil if the current TAG is marked read only."
 117   (let ((o (semantic-tag-overlay tag)))
 118     (if (featurep 'xemacs)
 119         ;; XEmacs extents have a 'read-only' property.
 120         (semantic-overlay-get o 'read-only)
 121       (member 'semantic-overlay-signal-read-only
 122               (semantic-overlay-get o 'modification-hooks)))))
 123
 124 ;;; Secondary overlays
 125 ;;
 126 ;; Some types of decoration require a second overlay to be made.
 127 ;; It could be for images, arrows, or whatever.
 128 ;; We need a way to create such an overlay, and make sure it
 129 ;; gets whacked, but doesn't show up in the master list
 130 ;; of overlays used for searching.
 131 (defun semantic-tag-secondary-overlays (tag)
 132   "Return a list of secondary overlays active on TAG."
 133   (semantic--tag-get-property tag 'secondary-overlays))
 134
 135 (defun semantic-tag-create-secondary-overlay (tag &optional link-hook)
 136   "Create a secondary overlay for TAG.
 137 Returns an overlay.  The overlay is also saved in TAG.
 138 LINK-HOOK is a function called whenever TAG is to be linked into
 139 a buffer.  It should take TAG and OVERLAY as arguments.
 140 The LINK-HOOK should be used to position and set properties on the
 141 generated secondary overlay."
 142   (if (not (semantic-tag-overlay tag))
 143       ;; do nothing if there is no overlay
 144       nil
 145     (let* ((os (semantic-tag-start tag))
 146            (oe (semantic-tag-end tag))
 147            (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t))
 148            (attr (semantic-tag-secondary-overlays tag))
 149            )
 150       (semantic--tag-put-property tag 'secondary-overlays (cons o attr))
 151       (semantic-overlay-put o 'semantic-secondary t)
 152       (semantic-overlay-put o 'semantic-link-hook link-hook)
 153       (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 154       (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 155       (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 156       (run-hook-with-args link-hook tag o)
 157       o)))
 158
 159 (defun semantic-tag-get-secondary-overlay (tag property)
 160   "Return secondary overlays from TAG with PROPERTY.
 161 PROPERTY is a symbol and all overlays with that symbol are returned.."
 162   (let* ((olsearch (semantic-tag-secondary-overlays tag))
 163          (o nil))
 164     (while olsearch
 165       (when (semantic-overlay-get (car olsearch) property)
 166         (setq o (cons (car olsearch) o)))
 167       (setq olsearch (cdr olsearch)))
 168     o))
 169
 170 (defun semantic-tag-delete-secondary-overlay (tag overlay-or-property)
 171   "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY.
 172 If OVERLAY-OR-PROPERTY is an overlay, delete that overlay.
 173 If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property."
 174   (let* ((o overlay-or-property))
 175     (if (semantic-overlay-p o)
 176         (setq o (list o))
 177       (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property)))
 178     (while (semantic-overlay-p (car o))
 179       ;; We don't really need to worry about the hooks.
 180       ;; They will clean themselves up eventually ??
 181       (semantic--tag-put-property
 182        tag 'secondary-overlays
 183        (delete (car o) (semantic-tag-secondary-overlays tag)))
 184       (semantic-overlay-delete (car o))
 185       (setq o (cdr o)))))
 186
 187 (defun semantic--tag-unlink-copy-secondary-overlays (tag)
 188   "Unlink secondary overlays from TAG which is a copy.
 189 This means we don't destroy the overlays, only remove reference
 190 from them in TAG."
 191   (let ((ol (semantic-tag-secondary-overlays tag)))
 192     (while ol
 193       ;; Else, remove all  traces of ourself from the tag
 194       ;; Note to self: Does this prevent multiple types of secondary
 195       ;; overlays per tag?
 196       (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 197       (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 198       (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 199       ;; Next!
 200       (setq ol (cdr ol)))
 201     (semantic--tag-put-property tag 'secondary-overlays nil)
 202     ))
 203
 204 (defun semantic--tag-unlink-secondary-overlays (tag)
 205   "Unlink secondary overlays from TAG."
 206   (let ((ol (semantic-tag-secondary-overlays tag))
 207         (nl nil))
 208     (while ol
 209       (if (semantic-overlay-get (car ol) 'semantic-link-hook)
 210           ;; Only put in a proxy if there is a link-hook.  If there is no link-hook
 211           ;; the decorating mode must know when tags are unlinked on its own.
 212           (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook)
 213                          nl))
 214         ;; Else, remove all  traces of ourself from the tag
 215         ;; Note to self: Does this prevent multiple types of secondary
 216         ;; overlays per tag?
 217         (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 218         (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 219         (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 220         )
 221       (semantic-overlay-delete (car ol))
 222       (setq ol (cdr ol)))
 223     (semantic--tag-put-property tag 'secondary-overlays (nreverse nl))
 224     ))
 225
 226 (defun semantic--tag-link-secondary-overlays (tag)
 227   "Unlink secondary overlays from TAG."
 228   (let ((ol (semantic-tag-secondary-overlays tag)))
 229     ;; Wipe out old values.
 230     (semantic--tag-put-property tag 'secondary-overlays nil)
 231     ;; Run all the link hooks.
 232     (while ol
 233       (semantic-tag-create-secondary-overlay tag (car ol))
 234       (setq ol (cdr ol)))
 235     ))
 236
 237 ;;; Secondary Overlay Uses
 238 ;;
 239 ;; States to put on tags that depend on a secondary overlay.
 240 (defun semantic-set-tag-folded (tag &optional folded)
 241   "Fold TAG, such that only the first line of text is shown.
 242 Optional argument FOLDED should be non-nil to fold the tag.
 243 nil implies the tag should be fully shown."
 244     ;; If they are different, do the deed.
 245     (let ((o (semantic-tag-folded-p tag)))
 246       (if (not folded)
 247           ;; We unfold.
 248           (when o
 249             (semantic-tag-delete-secondary-overlay tag 'semantic-folded))
 250         (unless o
 251           ;; Add the foldn
 252           (setq o (semantic-tag-create-secondary-overlay tag))
 253           ;; mark as folded
 254           (semantic-overlay-put o 'semantic-folded t)
 255           ;; Move to cover end of tag
 256           (save-excursion
 257             (goto-char (semantic-tag-start tag))
 258             (end-of-line)
 259             (semantic-overlay-move o (point) (semantic-tag-end tag)))
 260           ;; We need to modify the invisibility spec for this to
 261           ;; work.
 262           (if (or (eq buffer-invisibility-spec t)
 263                   (not (assoc 'semantic-fold buffer-invisibility-spec)))
 264               (add-to-invisibility-spec '(semantic-fold . t)))
 265           (semantic-overlay-put o 'invisible 'semantic-fold)
 266           (overlay-put o 'isearch-open-invisible
 267                        'semantic-set-tag-folded-isearch)))
 268           ))
 269
 270 (declare-function semantic-current-tag "semantic/find")
 271
 272 (defun semantic-set-tag-folded-isearch (overlay)
 273   "Called by isearch if it discovers text in the folded region.
 274 OVERLAY is passed in by isearch."
 275   (semantic-set-tag-folded (semantic-current-tag) nil)
 276   )
 277
 278 (defun semantic-tag-folded-p (tag)
 279   "Non-nil if TAG is currently folded."
 280   (semantic-tag-get-secondary-overlay tag 'semantic-folded)
 281   )
 282
 283 (provide 'semantic/decorate)
 284
 285 ;;; semantic/decorate.el ends here