cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-decorate.el

   1 ;;; semantic-decorate.el --- Utilities for decorating/highlighting tokens.
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: syntax
   7 ;; X-RCS: $Id: semantic-decorate.el,v 1.1 2007-11-26 15:10:35 michaels Exp $
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; Semantic 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 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This software 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; Text representing a semantic tag is wrapped in an overlay.
  29 ;; This overlay can be used for highlighting, or setting other
  30 ;; editing properties on a tag, such as "read only."
  31 ;;
  32
  33 (require 'semantic)
  34
  35 ;;; Code:
  36 (defface semantic-tag-highlight-start-face
  37   '((((class color) (background dark))
  38      (:background "#AAAA33"))
  39     (((class color) (background light))
  40      (:background "#FFFFAA")))
  41   "*Face used to show long tags in.
  42 Face used for temporary highlighting of tags for effect."
  43   :group 'semantic-faces)
  44
  45 (defface semantic-tag-highlight-face
  46   '((((class color) (background dark))
  47      (:background "#AAAA33"))
  48     (((class color) (background light))
  49      (:background "#FFFFAA")))
  50   "*Face used to show long tags in.
  51 Face used for temporary highlighting of tags for effect.
  52 This face will have it's color changed for special effects."
  53   :group 'semantic-faces)
  54
  55 ;;; Pulsing Code
  56 ;;
  57 (defun semantic-decorate-int-to-hex (int &optional nb-digits)
  58   "Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
  59 Each X in the output string is a hexadecimal digit.
  60 NB-DIGITS is the number of hex digits.  If INT is too large to be
  61 represented with NB-DIGITS, then the result is truncated from the
  62 left.  So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
  63 the hex equivalent of 256 decimal is 100, which is more than 2 digits.
  64
  65 This function was blindly copied from hexrgb.el by Drew Adams.
  66 http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
  67   (setq nb-digits (or nb-digits 4))
  68   (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
  69
  70 (defun semantic-color-values-to-hex (values)
  71   "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
  72 Each X in the string is a hexadecimal digit.
  73 Input VALUES is as for the output of `x-color-values'.
  74
  75 This function was blindly copied from hexrgb.el by Drew Adams.
  76 http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
  77   (concat "#"
  78           (semantic-decorate-int-to-hex (nth 0 values) 4) ; red
  79           (semantic-decorate-int-to-hex (nth 1 values) 4) ; green
  80           (semantic-decorate-int-to-hex (nth 2 values) 4))) ; blue
  81
  82 (defcustom semantic-pulse-iterations 30
  83   "Number of iterations in a puls operation."
  84   :group 'semantic
  85   :type 'number)
  86
  87 (defun semantic-lighten-highlight ()
  88   "Lighten the lighlight face by 1/10 toward the background color.
  89 Return t if there is more drift to do, nil if completed."
  90   (if (>= (get 'semantic-tag-highlight-face :iteration) semantic-pulse-iterations)
  91       nil
  92     (let* ((frame (color-values (face-background 'default)))
  93            (start (color-values (face-background 'semantic-tag-highlight-start-face)))
  94            (frac  (list (/ (- (nth 0 frame) (nth 0 start)) semantic-pulse-iterations)
  95                         (/ (- (nth 1 frame) (nth 1 start)) semantic-pulse-iterations)
  96                         (/ (- (nth 2 frame) (nth 2 start)) semantic-pulse-iterations)))
  97            (it (get 'semantic-tag-highlight-face :iteration))
  98            )
  99       (set-face-background 'semantic-tag-highlight-face
 100                            (semantic-color-values-to-hex
 101                             (list
 102                              (+ (nth 0 start) (* (nth 0 frac) it))
 103                              (+ (nth 1 start) (* (nth 1 frac) it))
 104                              (+ (nth 2 start) (* (nth 2 frac) it)))))
 105       (put 'semantic-tag-highlight-face :iteration (1+ it))
 106       (if (>= (1+ it) semantic-pulse-iterations)
 107           nil
 108         t))))
 109
 110 (defun semantic-highlight-reset-face ()
 111   "Reset the semantic highlighting face."
 112   (set-face-background 'semantic-tag-highlight-face
 113                        (face-background 'semantic-tag-highlight-start-face))
 114   (put 'semantic-tag-highlight-face :iteration 0))
 115
 116 (defun semantic-decorate-pulse ()
 117   "Pulse the colors on our highlight face."
 118   (unwind-protect
 119       (progn
 120         (semantic-highlight-reset-face)
 121         (while (and (semantic-lighten-highlight)
 122                     (sit-for .01))
 123           nil))
 124     (semantic-highlight-reset-face)))
 125
 126 (defun semantic-decorate-test-pulse ()
 127   "Test the lightening function for semantic decorator."
 128   (interactive)
 129   (let ((tag (semantic-current-tag)))
 130     (unwind-protect
 131         (progn
 132           (semantic-highlight-tag tag)
 133           (semantic-decorate-pulse)
 134           )
 135       (semantic-unhighlight-tag tag))))
 136
 137 ;;; Highlighting Basics
 138 ;;
 139 ;;;###autoload
 140 (defun semantic-highlight-tag (tag &optional face)
 141   "Specify that TAG should be highlighted.
 142 Optional FACE specifies the face to use."
 143   (let ((o (semantic-tag-overlay tag)))
 144     (semantic-overlay-put o 'old-face
 145                           (cons (semantic-overlay-get o 'face)
 146                                 (semantic-overlay-get o 'old-face)))
 147     (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face))
 148     ))
 149
 150 ;;;###autoload
 151 (defun semantic-unhighlight-tag (tag)
 152   "Unhighlight TAG, restoring it's previous face."
 153   (let ((o (semantic-tag-overlay tag)))
 154     (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face)))
 155     (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face)))
 156     ))
 157
 158 (defcustom semantic-momentary-highlight-pulse-flag
 159   (condition-case nil
 160       (let ((v (color-values (face-background 'default))))
 161         (numberp (car-safe v)))
 162     (error nil))
 163   "*Non-nil means to pulse the overlay face for momentary tag highlighting.
 164 Pulsing involves a bright highlight that slowly shifts to the background
 165 color."
 166   :group 'semantic
 167   :type 'boolean)
 168
 169 (defun semantic-momentary-highlight-one-tag-line (tag &optional face)
 170   "Highlight the first line of TAG, unhighlighting before next command.
 171 Optional argument FACE specifies the face to do the highlighting."
 172   (save-excursion
 173     ;; Go to first line in tag
 174     (semantic-go-to-tag tag)
 175     (beginning-of-line)
 176     (let ((o (semantic-make-overlay (save-excursion (beginning-of-line) (point))
 177                                     (save-excursion (end-of-line)
 178                                                     (forward-char 1)
 179                                                     (point)))))
 180       (semantic--tag-put-property tag 'line-highlight o)
 181       (if (or face (not semantic-momentary-highlight-pulse-flag))
 182           ;; Provide a face... clear on next command
 183           (progn
 184             (semantic-overlay-put o 'face face)
 185             (add-hook 'pre-command-hook
 186                       `(lambda () (semantic-momentary-unhighlight-one-tag-line ',tag))))
 187         ;; pulse it.
 188         (unwind-protect
 189             (progn
 190               (semantic-overlay-put o 'face 'semantic-tag-highlight-face)
 191               (semantic-decorate-pulse))
 192           (semantic-momentary-unhighlight-one-tag-line tag))
 193         ) )))
 194
 195 (defun semantic-momentary-unhighlight-one-tag-line (tag)
 196   "Unhighlight a TAG that has only one line highlighted."
 197   (let ((o (semantic--tag-get-property tag 'line-highlight)))
 198     (if o
 199         (progn
 200           (semantic-overlay-delete o)
 201           (semantic--tag-put-property tag 'line-highlight nil))))
 202   (remove-hook 'pre-command-hook
 203                `(lambda () (semantic-momentary-unhighlight-one-tag-line ',tag))))
 204
 205 (defun semantic-momentary-unhighlight-tag (tag)
 206   "Unhighlight TAG, restoring it's previous face."
 207   (semantic-unhighlight-tag tag)
 208   (remove-hook 'pre-command-hook
 209                `(lambda () (semantic-momentary-unhighlight-tag ',tag))))
 210
 211 ;;;###autoload
 212 (defun semantic-momentary-highlight-tag (tag &optional face)
 213   "Highlight TAG, removing highlighting when the user hits a key.
 214 Optional argument FACE is the face to use for highlighting.
 215 If FACE is not specified, then `highlight' will be used."
 216   (when (semantic-tag-with-position-p tag)
 217     (if (not (semantic-overlay-p (semantic-tag-overlay tag)))
 218         ;; No overlay, but a position.  Highlight the first line only.
 219         (semantic-momentary-highlight-one-tag-line tag face)
 220       ;; The tag has an overlay, highlight the whole thing
 221       (if (or face (not semantic-momentary-highlight-pulse-flag))
 222           ;; Provide a face -- delete face on next command
 223           (progn
 224             (semantic-highlight-tag tag face)
 225             (add-hook 'pre-command-hook
 226                       `(lambda () (semantic-momentary-unhighlight-tag ',tag))))
 227         ;; Default face.. pulse it!
 228         (unwind-protect
 229             (progn
 230               (semantic-highlight-tag tag)
 231               (semantic-decorate-pulse))
 232           (semantic-unhighlight-tag tag))
 233         ))))
 234
 235 ;;;###autoload
 236 (defun semantic-set-tag-face (tag face)
 237   "Specify that TAG should use FACE for display."
 238   (semantic-overlay-put (semantic-tag-overlay tag) 'face face))
 239
 240 ;;;###autoload
 241 (defun semantic-set-tag-invisible (tag &optional visible)
 242   "Enable the text in TAG to be made invisible.
 243 If VISIBLE is non-nil, make the text visible."
 244   (semantic-overlay-put (semantic-tag-overlay tag) 'invisible
 245                         (not visible)))
 246
 247 ;;;###autoload
 248 (defun semantic-tag-invisible-p (tag)
 249   "Return non-nil if TAG is invisible."
 250   (semantic-overlay-get (semantic-tag-overlay tag) 'invisible))
 251
 252 ;;;###autoload
 253 (defun semantic-set-tag-intangible (tag &optional tangible)
 254   "Enable the text in TAG to be made intangible.
 255 If TANGIBLE is non-nil, make the text visible.
 256 This function does not have meaning in XEmacs because it seems that
 257 the extent 'intangible' property does not exist."
 258   (semantic-overlay-put (semantic-tag-overlay tag) 'intangible
 259                         (not tangible)))
 260
 261 ;;;###autoload
 262 (defun semantic-tag-intangible-p (tag)
 263   "Return non-nil if TAG is intangible.
 264 This function does not have meaning in XEmacs because it seems that
 265 the extent 'intangible' property does not exist."
 266   (semantic-overlay-get (semantic-tag-overlay tag) 'intangible))
 267
 268 (defun semantic-overlay-signal-read-only
 269   (overlay after start end &optional len)
 270   "Hook used in modification hooks to prevent modification.
 271 Allows deletion of the entire text.
 272 Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
 273   ;; Stolen blithly from cpp.el in Emacs 21.1
 274   (if (and (not after)
 275            (or (< (semantic-overlay-start overlay) start)
 276                (> (semantic-overlay-end overlay) end)))
 277       (error "This text is read only")))
 278
 279 ;;;###autoload
 280 (defun semantic-set-tag-read-only (tag &optional writable)
 281   "Enable the text in TAG to be made read-only.
 282 Optional argument WRITABLE should be non-nil to make the text writable
 283 instead of read-only."
 284   (let ((o (semantic-tag-overlay tag))
 285         (hook (if writable nil '(semantic-overlay-signal-read-only))))
 286     (if (featurep 'xemacs)
 287         ;; XEmacs extents have a 'read-only' property.
 288         (semantic-overlay-put o 'read-only (not writable))
 289       (semantic-overlay-put o 'modification-hooks hook)
 290       (semantic-overlay-put o 'insert-in-front-hooks hook)
 291       (semantic-overlay-put o 'insert-behind-hooks hook))))
 292
 293 ;;;###autoload
 294 (defun semantic-tag-read-only-p (tag)
 295   "Return non-nil if the current TAG is marked read only."
 296   (let ((o (semantic-tag-overlay tag)))
 297     (if (featurep 'xemacs)
 298         ;; XEmacs extents have a 'read-only' property.
 299         (semantic-overlay-get o 'read-only)
 300       (member 'semantic-overlay-signal-read-only
 301               (semantic-overlay-get o 'modification-hooks)))))
 302
 303 ;;; backwards compatability
 304
 305 ;;;###autoload
 306 (semantic-alias-obsolete 'semantic-highlight-token
 307                          'semantic-highlight-tag)
 308 ;;;###autoload
 309 (semantic-alias-obsolete 'semantic-unhighlight-token
 310                          'semantic-unhighlight-tag)
 311 ;;;###autoload
 312 (semantic-alias-obsolete 'semantic-momentary-unhighlight-token
 313                          'semantic-momentary-unhighlight-tag)
 314 ;;;###autoload
 315 (semantic-alias-obsolete 'semantic-momentary-highlight-token
 316                          'semantic-momentary-highlight-tag)
 317 ;;;###autoload
 318 (semantic-alias-obsolete 'semantic-set-token-face
 319                          'semantic-set-tag-face)
 320 ;;;###autoload
 321 (semantic-alias-obsolete 'semantic-set-token-invisible
 322                          'semantic-set-tag-invisible)
 323 ;;;###autoload
 324 (semantic-alias-obsolete 'semantic-token-invisible-p
 325                          'semantic-tag-invisible-p)
 326 ;;;###autoload
 327 (semantic-alias-obsolete 'semantic-set-token-intangible
 328                          'semantic-set-tag-intangible)
 329 ;;;###autoload
 330 (semantic-alias-obsolete 'semantic-token-intangible-p
 331                          'semantic-tag-intangible-p)
 332 ;;;###autoload
 333 (semantic-alias-obsolete 'semantic-set-token-read-only
 334                          'semantic-set-tag-read-only)
 335 ;;;###autoload
 336 (semantic-alias-obsolete 'semantic-token-read-only-p
 337                          'semantic-tag-read-only-p)
 338
 339 ;;; Secondary overlays
 340 ;;
 341 ;; Some types of decoration require a second overlay to be made.
 342 ;; It could be for images, arrows, or whatever.
 343 ;; We need a way to create such an overlay, and make sure it
 344 ;; gets whacked, but doesn't show up in the master list
 345 ;; of overlays used for searching.
 346 ;;;###autoload
 347 (defun semantic-tag-secondary-overlays (tag)
 348   "Return a list of secondary overlays active on TAG."
 349   (semantic--tag-get-property tag 'secondary-overlays))
 350
 351 ;;;###autoload
 352 (defun semantic-tag-create-secondary-overlay (tag &optional link-hook)
 353   "Create a secondary overlay for TAG.
 354 Returns an overlay.  The overlay is also saved in TAG.
 355 LINK-HOOK is a function called whenever TAG is to be linked into
 356 a buffer.  It should take TAG and OVERLAY as arguments.
 357 The LINK-HOOK should be used to position and set properties on the
 358 generated secondary overlay."
 359   (if (not (semantic-tag-overlay tag))
 360       ;; do nothing if there is no overlay
 361       nil
 362     (let* ((os (semantic-tag-start tag))
 363            (oe (semantic-tag-end tag))
 364            (to (semantic-tag-overlay tag))
 365            (o (semantic-make-overlay os oe (semantic-tag-buffer tag)))
 366            (attr (semantic-tag-secondary-overlays tag))
 367            )
 368       (semantic--tag-put-property tag 'secondary-overlays (cons o attr))
 369       (semantic-overlay-put o 'semantic-secondary t)
 370       (semantic-overlay-put o 'semantic-link-hook link-hook)
 371       (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 372       (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 373       (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 374       (run-hook-with-args link-hook tag o)
 375       o)))
 376
 377 ;;;###autoload
 378 (defun semantic-tag-get-secondary-overlay (tag property)
 379   "Return secondary overlays from TAG with PROPERTY.
 380 PROPERTY is a symbol and all overlays with that symbol are returned.."
 381   (let* ((olsearch (semantic-tag-secondary-overlays tag))
 382          (o nil))
 383     (while olsearch
 384       (when (semantic-overlay-get (car olsearch) property)
 385         (setq o (cons (car olsearch) o)))
 386       (setq olsearch (cdr olsearch)))
 387     o))
 388
 389 ;;;###autoload
 390 (defun semantic-tag-delete-secondary-overlay (tag overlay-or-property)
 391   "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY.
 392 If OVERLAY-OR-PROPERTY is an overlay, delete that overlay.
 393 If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property."
 394   (let* ((o overlay-or-property))
 395     (if (semantic-overlay-p o)
 396         (setq o (list o))
 397       (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property)))
 398     (while (semantic-overlay-p (car o))
 399       ;; We don't really need to worry about the hooks.
 400       ;; They will clean themselves up eventually ??
 401       (semantic--tag-put-property
 402        tag 'secondary-overlays
 403        (delete (car o) (semantic-tag-secondary-overlays tag)))
 404       (semantic-overlay-delete (car o))
 405       (setq o (cdr o)))))
 406
 407 (defun semantic--tag-unlink-copy-secondary-overlays (tag)
 408   "Unlink secondary overlays from TAG which is a copy.
 409 This means we don't destroy the overlays, only remove reference
 410 from them in TAG."
 411   (let ((ol (semantic-tag-secondary-overlays tag)))
 412     (while ol
 413       ;; Else, remove all  traces of ourself from the tag
 414       ;; Note to self: Does this prevent multiple types of secondary
 415       ;; overlays per tag?
 416       (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 417       (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 418       (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 419       ;; Next!
 420       (setq ol (cdr ol)))
 421     (semantic--tag-put-property tag 'secondary-overlays nil)
 422     ))
 423
 424 (defun semantic--tag-unlink-secondary-overlays (tag)
 425   "Unlink secondary overlays from TAG."
 426   (let ((ol (semantic-tag-secondary-overlays tag))
 427         (nl nil))
 428     (while ol
 429       (if (semantic-overlay-get (car ol) 'semantic-link-hook)
 430           ;; Only put in a proxy if there is a link-hook.  If there is no link-hook
 431           ;; the decorating mode must know when tags are unlinked on its own.
 432           (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook)
 433                          nl))
 434         ;; Else, remove all  traces of ourself from the tag
 435         ;; Note to self: Does this prevent multiple types of secondary
 436         ;; overlays per tag?
 437         (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
 438         (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
 439         (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
 440         )
 441       (semantic-overlay-delete (car ol))
 442       (setq ol (cdr ol)))
 443     (semantic--tag-put-property tag 'secondary-overlays (nreverse nl))
 444     ))
 445
 446 (defun semantic--tag-link-secondary-overlays (tag)
 447   "Unlink secondary overlays from TAG."
 448   (let ((ol (semantic-tag-secondary-overlays tag)))
 449     ;; Wipe out old values.
 450     (semantic--tag-put-property tag 'secondary-overlays nil)
 451     ;; Run all the link hooks.
 452     (while ol
 453       (semantic-tag-create-secondary-overlay tag (car ol))
 454       (setq ol (cdr ol)))
 455     ))
 456
 457 ;;; Secondary Overlay Uses
 458 ;;
 459 ;; States to put on tags that depend on a secondary overlay.
 460 ;;;###autoload
 461 (defun semantic-set-tag-folded (tag &optional folded)
 462   "Fold TAG, such that only the first line of text is shown.
 463 Optional argument FOLDED should be non-nil to fold the tag.
 464 nil implies the tag should be fully shown."
 465     ;; If they are different, do the deed.
 466     (let ((o (semantic-tag-folded-p tag)))
 467       (if (not folded)
 468           ;; We unfold.
 469           (when o
 470             (semantic-tag-delete-secondary-overlay tag 'semantic-folded))
 471         (unless o
 472           ;; Add the foldn
 473           (setq o (semantic-tag-create-secondary-overlay tag))
 474           ;; mark as folded
 475           (semantic-overlay-put o 'semantic-folded t)
 476           ;; Move to cover end of tag
 477           (save-excursion
 478             (goto-char (semantic-tag-start tag))
 479             (end-of-line)
 480             (semantic-overlay-move o (point) (semantic-tag-end tag)))
 481           ;; We need to modify the invisibility spec for this to
 482           ;; work.
 483           (if (or (eq buffer-invisibility-spec t)
 484                   (not (assoc 'semantic-fold buffer-invisibility-spec)))
 485               (add-to-invisibility-spec '(semantic-fold . t)))
 486           (semantic-overlay-put o 'invisible 'semantic-fold)
 487           (overlay-put o 'isearch-open-invisible
 488                        'semantic-set-tag-folded-isearch)))
 489           ))
 490
 491 (defun semantic-set-tag-folded-isearch (overlay)
 492   "Called by isearch if it discovers text in the folded region.
 493 OVERLAY is passed in by isearch."
 494   (semantic-set-tag-folded (semantic-current-tag) nil)
 495   )
 496
 497 ;;;###autoload
 498 (defun semantic-tag-folded-p (tag)
 499   "Non-nil if TAG is currently folded."
 500   (semantic-tag-get-secondary-overlay tag 'semantic-folded)
 501   )
 502
 503 (provide 'semantic-decorate)
 504
 505 ;;; semantic-decorate.el ends here