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