lisp/cedet/semantic/decorate/mode.el

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