code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/decorate/mode.el

   1 ;;; semantic/decorate/mode.el --- Minor mode for decorating tags
   2
   3 ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008
   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 ;; A minor mode for use in decorating tags.
  27 ;;
  28 ;; There are two types of decorations that can be performed on a tag.
  29 ;; You can either highlight the full tag, or you can add an
  30 ;; independent decoration on some part of the tag body.
  31 ;;
  32 ;; For independent decoration in particular, managing them so that they
  33 ;; do not get corrupted is challenging.  This major mode and
  34 ;; corresponding macros will make handling those types of decorations
  35 ;; easier.
  36 ;;
  37
  38 ;;; Code:
  39 (require 'semantic)
  40 (require 'semantic/decorate)
  41 (require 'semantic/tag-ls)
  42 (require 'semantic/util-modes)
  43 (eval-when-compile (require 'cl))
  44
  45 ;;; Styles List
  46 ;;
  47 (defcustom semantic-decoration-styles nil
  48   "*List of active decoration styles.
  49 It is an alist of \(NAME . FLAG) elements, where NAME is a style name
  50 and FLAG is non-nil if the style is enabled.
  51 See also `define-semantic-decoration-style' which will automatically
  52 add items to this list."
  53   :group 'semantic
  54   :type '(repeat (cons (string :tag "Decoration Name")
  55                        (boolean :tag "Enabled")))
  56   )
  57
  58 ;;; Misc.
  59 ;;
  60 (defsubst semantic-decorate-style-predicate (style)
  61   "Return the STYLE's predicate function."
  62   (intern (format "%s-p" style)))
  63
  64 (defsubst semantic-decorate-style-highlighter (style)
  65   "Return the STYLE's highlighter function."
  66   (intern (format "%s-highlight" style)))
  67
  68 ;;; Base decoration API
  69 ;;
  70 (defsubst semantic-decoration-p (object)
  71   "Return non-nil if OBJECT is a tag decoration."
  72   (and (semantic-overlay-p object)
  73        (semantic-overlay-get object 'semantic-decoration)))
  74
  75 (defsubst semantic-decoration-set-property (deco property value)
  76   "Set the DECO decoration's PROPERTY to VALUE.
  77 Return DECO."
  78   (assert (semantic-decoration-p deco))
  79   (semantic-overlay-put deco property value)
  80   deco)
  81
  82 (defsubst semantic-decoration-get-property (deco property)
  83   "Return the DECO decoration's PROPERTY value."
  84   (assert (semantic-decoration-p deco))
  85   (semantic-overlay-get deco property))
  86
  87 (defsubst semantic-decoration-set-face (deco face)
  88   "Set the face of the decoration DECO to FACE.
  89 Return DECO."
  90   (semantic-decoration-set-property deco 'face face))
  91
  92 (defsubst semantic-decoration-face (deco)
  93   "Return the face of the decoration DECO."
  94   (semantic-decoration-get-property deco 'face))
  95
  96 (defsubst semantic-decoration-set-priority (deco priority)
  97   "Set the priority of the decoration DECO to PRIORITY.
  98 Return DECO."
  99   (assert (natnump priority))
 100   (semantic-decoration-set-property deco 'priority priority))
 101
 102 (defsubst semantic-decoration-priority (deco)
 103   "Return the priority of the decoration DECO."
 104   (semantic-decoration-get-property deco 'priority))
 105
 106 (defsubst semantic-decoration-move (deco begin end)
 107   "Move the decoration DECO on the region between BEGIN and END.
 108 Return DECO."
 109   (assert (semantic-decoration-p deco))
 110   (semantic-overlay-move deco begin end)
 111   deco)
 112 \f
 113 ;;; Tag decoration
 114 ;;
 115 (defun semantic-decorate-tag (tag begin end &optional face)
 116   "Add a new decoration on TAG on the region between BEGIN and END.
 117 If optional argument FACE is non-nil, set the decoration's face to
 118 FACE.
 119 Return the overlay that makes up the new decoration."
 120   (let ((deco (semantic-tag-create-secondary-overlay tag)))
 121     ;; We do not use the unlink property because we do not want to
 122     ;; save the highlighting information in the DB.
 123     (semantic-overlay-put deco 'semantic-decoration t)
 124     (semantic-decoration-move deco begin end)
 125     (semantic-decoration-set-face deco face)
 126     deco))
 127
 128 (defun semantic-decorate-clear-tag (tag &optional deco)
 129   "Remove decorations from TAG.
 130 If optional argument DECO is non-nil, remove only that decoration."
 131   (assert (or (null deco) (semantic-decoration-p deco)))
 132   ;; Clear primary decorations.
 133   ;; For now, just unhighlight the tag.  How to deal with other
 134   ;; primary decorations like invisibility, etc. ?  Maybe just
 135   ;; restoring default values will suffice?
 136   (semantic-unhighlight-tag tag)
 137   (semantic-tag-delete-secondary-overlay
 138    tag (or deco 'semantic-decoration)))
 139
 140 (defun semantic-decorate-tag-decoration (tag)
 141   "Return decoration found on TAG."
 142   (semantic-tag-get-secondary-overlay tag 'semantic-decoration))
 143 \f
 144 ;;; Global setup of active decorations
 145 ;;
 146 (defun semantic-decorate-flush-decorations (&optional buffer)
 147   "Flush decorations found in BUFFER.
 148 BUFFER defaults to the current buffer.
 149 Should be used to flush decorations that might remain in BUFFER, for
 150 example, after tags have been refreshed."
 151   (with-current-buffer (or buffer (current-buffer))
 152     (dolist (o (semantic-overlays-in (point-min) (point-max)))
 153       (and (semantic-decoration-p o)
 154            (semantic-overlay-delete o)))))
 155
 156 (defun semantic-decorate-clear-decorations (tag-list)
 157   "Remove decorations found in tags in TAG-LIST."
 158   (dolist (tag tag-list)
 159     (semantic-decorate-clear-tag tag)
 160     ;; recurse over children
 161     (semantic-decorate-clear-decorations
 162      (semantic-tag-components-with-overlays tag))))
 163
 164 (defun semantic-decorate-add-decorations (tag-list)
 165   "Add decorations to tags in TAG-LIST.
 166 Also make sure old decorations in the area are completely flushed."
 167   (dolist (tag tag-list)
 168     ;; Cleanup old decorations.
 169     (when (semantic-decorate-tag-decoration tag)
 170       ;; Note on below comment.   This happens more as decorations are refreshed
 171       ;; mid-way through their use.  Remove the message.
 172
 173       ;; It would be nice if this never happened, but it still does
 174       ;; once in a while.  Print a message to help flush these
 175       ;; situations
 176       ;;(message "Decorations still on %s" (semantic-format-tag-name tag))
 177       (semantic-decorate-clear-tag tag))
 178     ;; Add new decorations.
 179     (dolist (style semantic-decoration-styles)
 180       (let ((pred (semantic-decorate-style-predicate   (car style)))
 181             (high (semantic-decorate-style-highlighter (car style))))
 182         (and (cdr style)
 183              (fboundp pred)
 184              (funcall pred tag)
 185              (fboundp high)
 186              (funcall high tag))))
 187     ;; Recurse on the children of all tags
 188     (semantic-decorate-add-decorations
 189      (semantic-tag-components-with-overlays tag))))
 190 \f
 191 ;;; PENDING DECORATIONS
 192 ;;
 193 ;; Activities in Emacs may cause a decoration to change state.  Any
 194 ;; such identified change ought to be setup as PENDING.  This means
 195 ;; that the next idle step will do the decoration change, but at the
 196 ;; time of the state change, minimal work would be done.
 197 (defvar semantic-decorate-pending-decoration-hook nil
 198   "Normal hook run to perform pending decoration changes.")
 199
 200 (semantic-varalias-obsolete 'semantic-decorate-pending-decoration-hooks
 201                             'semantic-decorate-pending-decoration-hook)
 202
 203 (defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
 204   "Add a pending decoration change represented by FCN.
 205 Applies only to the current BUFFER.
 206 The setting of FCN will be removed after it is run."
 207   (save-excursion
 208     (when buffer (set-buffer buffer))
 209     (semantic-make-local-hook 'semantic-decorate-flush-pending-decorations)
 210     (add-hook 'semantic-decorate-pending-decoration-hook fcn nil t)))
 211
 212 ;;;;###autoload
 213 (defun semantic-decorate-flush-pending-decorations (&optional buffer)
 214   "Flush any pending decorations for BUFFER.
 215 Flush functions from `semantic-decorate-pending-decoration-hook'."
 216   (save-excursion
 217     (when buffer (set-buffer buffer))
 218     (run-hooks 'semantic-decorate-pending-decoration-hook)
 219     ;; Always reset the hooks
 220     (setq semantic-decorate-pending-decoration-hook nil)))
 221
 222 \f
 223 ;;; DECORATION MODE
 224 ;;
 225 ;; Generic mode for handling basic highlighting and decorations.
 226 ;;
 227
 228 (defcustom global-semantic-decoration-mode nil
 229   "*If non-nil, enable global use of command `semantic-decoration-mode'.
 230 When this mode is activated, decorations specified by
 231 `semantic-decoration-styles'."
 232   :group 'semantic
 233   :group 'semantic-modes
 234   :type 'boolean
 235   :require 'semantic/decorate/mode
 236   :initialize 'custom-initialize-default
 237   :set (lambda (sym val)
 238          (global-semantic-decoration-mode (if val 1 -1))))
 239
 240 ;;;###autoload
 241 (defun global-semantic-decoration-mode (&optional arg)
 242   "Toggle global use of option `semantic-decoration-mode'.
 243 Decoration mode turns on all active decorations as specified
 244 by `semantic-decoration-styles'.
 245 If ARG is positive, enable, if it is negative, disable.
 246 If ARG is nil, then toggle."
 247   (interactive "P")
 248   (setq global-semantic-decoration-mode
 249         (semantic-toggle-minor-mode-globally
 250          'semantic-decoration-mode arg)))
 251
 252 (defcustom semantic-decoration-mode-hook nil
 253   "*Hook run at the end of function `semantic-decoration-mode'."
 254   :group 'semantic
 255   :type 'hook)
 256
 257 ;;;;###autoload
 258 (defvar semantic-decoration-mode nil
 259   "Non-nil if command `semantic-decoration-mode' is enabled.
 260 Use the command `semantic-decoration-mode' to change this variable.")
 261 (make-variable-buffer-local 'semantic-decoration-mode)
 262
 263 (defun semantic-decoration-mode-setup ()
 264   "Setup the `semantic-decoration-mode' minor mode.
 265 The minor mode can be turned on only if the semantic feature is available
 266 and the current buffer was set up for parsing.  Return non-nil if the
 267 minor mode is enabled."
 268   (if semantic-decoration-mode
 269       (if (not (and (featurep 'semantic) (semantic-active-p)))
 270           (progn
 271             ;; Disable minor mode if semantic stuff not available
 272             (setq semantic-decoration-mode nil)
 273             (error "Buffer %s was not set up for parsing"
 274                    (buffer-name)))
 275         ;; Add hooks
 276         (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
 277         (add-hook 'semantic-after-partial-cache-change-hook
 278                   'semantic-decorate-tags-after-partial-reparse nil t)
 279         (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
 280         (add-hook 'semantic-after-toplevel-cache-change-hook
 281                   'semantic-decorate-tags-after-full-reparse nil t)
 282         ;; Add decorations to available tags.  The above hooks ensure
 283         ;; that new tags will be decorated when they become available.
 284         (semantic-decorate-add-decorations (semantic-fetch-available-tags))
 285         )
 286     ;; Remove decorations from available tags.
 287     (semantic-decorate-clear-decorations (semantic-fetch-available-tags))
 288     ;; Cleanup any leftover crap too.
 289     (semantic-decorate-flush-decorations)
 290     ;; Remove hooks
 291     (remove-hook 'semantic-after-partial-cache-change-hook
 292                  'semantic-decorate-tags-after-partial-reparse t)
 293     (remove-hook 'semantic-after-toplevel-cache-change-hook
 294                  'semantic-decorate-tags-after-full-reparse t)
 295     )
 296   semantic-decoration-mode)
 297
 298 ;;;;###autoload
 299 (defun semantic-decoration-mode (&optional arg)
 300   "Minor mode for decorating tags.
 301 Decorations are specified in `semantic-decoration-styles'.
 302 You can define new decoration styles with
 303 `define-semantic-decoration-style'.
 304 With prefix argument ARG, turn on if positive, otherwise off.  The
 305 minor mode can be turned on only if semantic feature is available and
 306 the current buffer was set up for parsing.  Return non-nil if the
 307 minor mode is enabled."
 308 ;;
 309 ;;\\{semantic-decoration-map}"
 310   (interactive
 311    (list (or current-prefix-arg
 312              (if semantic-decoration-mode 0 1))))
 313   (setq semantic-decoration-mode
 314         (if arg
 315             (>
 316              (prefix-numeric-value arg)
 317              0)
 318           (not semantic-decoration-mode)))
 319   (semantic-decoration-mode-setup)
 320   (run-hooks 'semantic-decoration-mode-hook)
 321   (if (interactive-p)
 322       (message "decoration-mode minor mode %sabled"
 323                (if semantic-decoration-mode "en" "dis")))
 324   (semantic-mode-line-update)
 325   semantic-decoration-mode)
 326
 327 (semantic-add-minor-mode 'semantic-decoration-mode
 328                          ""
 329                          nil)
 330
 331 (defun semantic-decorate-tags-after-full-reparse (tag-list)
 332   "Add decorations after a complete reparse of the current buffer.
 333 TAG-LIST is the list of tags recently parsed.
 334 Flush all existing decorations and call `semantic-decorate-add-decorations' to
 335 add decorations.
 336 Called from `semantic-after-toplevel-cache-change-hook'."
 337   ;; Flush everything
 338   (semantic-decorate-flush-decorations)
 339   ;; Add it back on
 340   (semantic-decorate-add-decorations tag-list))
 341
 342 (defun semantic-decorate-tags-after-partial-reparse (tag-list)
 343   "Add decorations when new tags are created in the current buffer.
 344 TAG-LIST is the list of newly created tags.
 345 Call `semantic-decorate-add-decorations' to add decorations.
 346 Called from `semantic-after-partial-cache-change-hook'."
 347   (semantic-decorate-add-decorations tag-list))
 348
 349 \f
 350 ;;; Enable/Disable toggling
 351 ;;
 352 (defun semantic-decoration-style-enabled-p (style)
 353   "Return non-nil if STYLE is currently enabled.
 354 Return nil if the style is disabled, or does not exist."
 355   (let ((pair (assoc style semantic-decoration-styles)))
 356     (and pair (cdr pair))))
 357
 358 (defun semantic-toggle-decoration-style (name &optional arg)
 359   "Turn on/off the decoration style with NAME.
 360 Decorations are specified in `semantic-decoration-styles'.
 361 With prefix argument ARG, turn on if positive, otherwise off.
 362 Return non-nil if the decoration style is enabled."
 363   (interactive
 364    (list (completing-read "Decoration style: "
 365                           semantic-decoration-styles nil t)
 366          current-prefix-arg))
 367   (setq name (format "%s" name)) ;; Ensure NAME is a string.
 368   (unless (equal name "")
 369     (let* ((style (assoc name semantic-decoration-styles))
 370            (flag  (if arg
 371                       (> (prefix-numeric-value arg) 0)
 372                     (not (cdr style)))))
 373       (unless (eq (cdr style) flag)
 374         ;; Store the new flag.
 375         (setcdr style flag)
 376         ;; Refresh decorations is `semantic-decoration-mode' is on.
 377         (when semantic-decoration-mode
 378           (semantic-decoration-mode -1)
 379           (semantic-decoration-mode 1))
 380         (when (interactive-p)
 381           (message "Decoration style %s turned %s" (car style)
 382                    (if flag "on" "off"))))
 383       flag)))
 384
 385 (defvar semantic-decoration-menu-cache nil
 386   "Cache of the decoration menu.")
 387
 388 (defun semantic-decoration-build-style-menu (style)
 389   "Build a menu item for controlling a specific decoration STYLE."
 390   (vector (car style)
 391           `(lambda () (interactive)
 392              (semantic-toggle-decoration-style
 393               ,(car style)))
 394           :style 'toggle
 395           :selected `(semantic-decoration-style-enabled-p ,(car style))
 396           ))
 397
 398 ;;;;###autoload
 399 (defun semantic-build-decoration-mode-menu (&rest ignore)
 400   "Create a menu listing all the known decorations for toggling.
 401 IGNORE any input arguments."
 402   (or semantic-decoration-menu-cache
 403       (setq semantic-decoration-menu-cache
 404             (mapcar 'semantic-decoration-build-style-menu
 405                     (reverse semantic-decoration-styles))
 406             )))
 407
 408 \f
 409 ;;; Defining decoration styles
 410 ;;
 411 (defmacro define-semantic-decoration-style (name doc &rest flags)
 412   "Define a new decoration style with NAME.
 413 DOC is a documentation string describing the decoration style NAME.
 414 It is appended to auto-generated doc strings.
 415 An Optional list of FLAGS can also be specified.  Flags are:
 416   :enabled <value>  - specify the default enabled value for NAME.
 417
 418
 419 This defines two new overload functions respectively called `NAME-p'
 420 and `NAME-highlight', for which you must provide a default
 421 implementation in respectively the functions `NAME-p-default' and
 422 `NAME-highlight-default'.  Those functions are passed a tag.  `NAME-p'
 423 must return non-nil to indicate that the tag should be decorated by
 424 `NAME-highlight'.
 425
 426 To put primary decorations on a tag `NAME-highlight' must use
 427 functions like `semantic-set-tag-face', `semantic-set-tag-intangible',
 428 etc., found in the semantic-decorate library.
 429
 430 To add other kind of decorations on a tag, `NAME-highlight' must use
 431 `semantic-decorate-tag', and other functions of the semantic
 432 decoration API found in this library."
 433   (let ((predicate   (semantic-decorate-style-predicate   name))
 434         (highlighter (semantic-decorate-style-highlighter name))
 435         (defaultenable (if (plist-member flags :enabled)
 436                            (plist-get flags :enabled)
 437                          t))
 438         )
 439     `(progn
 440        ;; Clear the menu cache so that new items are added when
 441        ;; needed.
 442        (setq semantic-decoration-menu-cache nil)
 443        ;; Create an override method to specify if a given tag belongs
 444        ;; to this type of decoration
 445        (define-overloadable-function ,predicate (tag)
 446          ,(format "Return non-nil to decorate TAG with `%s' style.\n%s"
 447                   name doc))
 448        ;; Create an override method that will perform the highlight
 449        ;; operation if the -p method returns non-nil.
 450        (define-overloadable-function ,highlighter (tag)
 451          ,(format "Decorate TAG with `%s' style.\n%s"
 452                   name doc))
 453        ;; Add this to the list of primary decoration modes.
 454        (add-to-list 'semantic-decoration-styles
 455                     (cons ',(symbol-name name)
 456                           ,defaultenable))
 457        )))
 458 \f
 459 ;;; Predefined decoration styles
 460 ;;
 461
 462 ;;; Tag boundaries highlighting
 463 ;;
 464 (define-semantic-decoration-style semantic-tag-boundary
 465   "Place an overline in front of each long tag.
 466 Does not provide overlines for prototypes.")
 467
 468 (defface semantic-tag-boundary-face
 469   '((((class color) (background dark))
 470      (:overline "cyan"))
 471     (((class color) (background light))
 472      (:overline "blue")))
 473   "*Face used to show long tags in.
 474 Used by decoration style: `semantic-tag-boundary'."
 475   :group 'semantic-faces)
 476
 477 (defun semantic-tag-boundary-p-default (tag)
 478   "Return non-nil if TAG is a type, or a non-prototype function."
 479   (let ((c (semantic-tag-class tag)))
 480     (and
 481      (or
 482       ;; All types get a line?
 483       (eq c 'type)
 484       ;; Functions which aren't prototypes get a line.
 485       (and (eq c 'function)
 486            (not (semantic-tag-get-attribute tag :prototype-flag)))
 487       )
 488      ;; Note: The below restriction confused users.
 489      ;;
 490      ;; Nothing smaller than a few lines
 491      ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
 492      ;; Random truth
 493      t)
 494     ))
 495
 496 (defun semantic-tag-boundary-highlight-default (tag)
 497   "Highlight the first line of TAG as a boundary."
 498   (when (bufferp (semantic-tag-buffer tag))
 499     (with-current-buffer (semantic-tag-buffer tag)
 500       (semantic-decorate-tag
 501        tag
 502        (semantic-tag-start tag)
 503        (save-excursion
 504          (goto-char (semantic-tag-start tag))
 505          (end-of-line)
 506          (forward-char 1)
 507          (point))
 508        'semantic-tag-boundary-face))
 509     ))
 510
 511 ;;; Private member highlighting
 512 ;;
 513 (define-semantic-decoration-style semantic-decoration-on-private-members
 514   "Highlight class members that are designated as PRIVATE access."
 515   :enabled nil)
 516
 517 (defface semantic-decoration-on-private-members-face
 518   '((((class color) (background dark))
 519      (:background "#200000"))
 520     (((class color) (background light))
 521      (:background "#8fffff")))
 522   "*Face used to show privately scoped tags in.
 523 Used by the decoration style: `semantic-decoration-on-private-members'."
 524   :group 'semantic-faces)
 525
 526 (defun semantic-decoration-on-private-members-highlight-default (tag)
 527   "Highlight TAG as designated to have PRIVATE access.
 528 Use a primary decoration."
 529   (semantic-set-tag-face
 530    tag 'semantic-decoration-on-private-members-face))
 531
 532 (defun semantic-decoration-on-private-members-p-default (tag)
 533   "Return non-nil if TAG has PRIVATE access."
 534   (and (member (semantic-tag-class tag) '(function variable))
 535        (eq (semantic-tag-protection tag) 'private)))
 536
 537 ;;; Protected member highlighting
 538 ;;
 539 (defface semantic-decoration-on-protected-members-face
 540   '((((class color) (background dark))
 541      (:background "#000020"))
 542     (((class color) (background light))
 543      (:background "#fffff8")))
 544   "*Face used to show protected scoped tags in.
 545 Used by the decoration style: `semantic-decoration-on-protected-members'."
 546   :group 'semantic-faces)
 547
 548 (define-semantic-decoration-style semantic-decoration-on-protected-members
 549   "Highlight class members that are designated as PROTECTED access."
 550   :enabled nil)
 551
 552 (defun semantic-decoration-on-protected-members-p-default (tag)
 553   "Return non-nil if TAG has PROTECTED access."
 554   (and (member (semantic-tag-class tag) '(function variable))
 555        (eq (semantic-tag-protection tag) 'protected)))
 556
 557 (defun semantic-decoration-on-protected-members-highlight-default (tag)
 558   "Highlight TAG as designated to have PROTECTED access.
 559 Use a primary decoration."
 560   (semantic-set-tag-face
 561    tag 'semantic-decoration-on-protected-members-face))
 562
 563 (provide 'semantic/decorate/mode)
 564
 565 ;; Local variables:
 566 ;; generated-autoload-file: "../loaddefs.el"
 567 ;; generated-autoload-feature: semantic/loaddefs
 568 ;; generated-autoload-load-name: "semantic/decorate/mode"
 569 ;; End:
 570
 571 ;;; semantic/decorate/mode.el ends here