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 ;;   2009, 2010, 2011, 2012  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 (eval-when-compile (require 'cl))
  40 (require 'semantic)
  41 (require 'semantic/decorate)
  42 (require 'semantic/tag-ls)
  43 (require 'semantic/util-modes)
  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 "23.2")
 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 (defun semantic-decorate-flush-pending-decorations (&optional buffer)
 213   "Flush any pending decorations for BUFFER.
 214 Flush functions from `semantic-decorate-pending-decoration-hook'."
 215   (save-excursion
 216     (when buffer (set-buffer buffer))
 217     (run-hooks 'semantic-decorate-pending-decoration-hook)
 218     ;; Always reset the hooks
 219     (setq semantic-decorate-pending-decoration-hook nil)))
 220
 221 \f
 222 ;;; DECORATION MODE
 223 ;;
 224 ;; Generic mode for handling basic highlighting and decorations.
 225 ;;
 226
 227 (defcustom global-semantic-decoration-mode nil
 228   "*If non-nil, enable global use of command `semantic-decoration-mode'.
 229 When this mode is activated, decorations specified by
 230 `semantic-decoration-styles'."
 231   :group 'semantic
 232   :group 'semantic-modes
 233   :type 'boolean
 234   :require 'semantic/decorate/mode
 235   :initialize 'custom-initialize-default
 236   :set (lambda (sym val)
 237          (global-semantic-decoration-mode (if val 1 -1))))
 238
 239 ;;;###autoload
 240 (defun global-semantic-decoration-mode (&optional arg)
 241   "Toggle global use of option `semantic-decoration-mode'.
 242 Decoration mode turns on all active decorations as specified
 243 by `semantic-decoration-styles'.
 244 If ARG is positive, enable, if it is negative, disable.
 245 If ARG is nil, then toggle."
 246   (interactive "P")
 247   (setq global-semantic-decoration-mode
 248         (semantic-toggle-minor-mode-globally
 249          'semantic-decoration-mode arg)))
 250
 251 (defcustom semantic-decoration-mode-hook nil
 252   "Hook run at the end of function `semantic-decoration-mode'."
 253   :group 'semantic
 254   :type 'hook)
 255
 256 ;;;;###autoload
 257 (defvar semantic-decoration-mode nil
 258   "Non-nil if command `semantic-decoration-mode' is enabled.
 259 Use the command `semantic-decoration-mode' to change this variable.")
 260 (make-variable-buffer-local 'semantic-decoration-mode)
 261
 262 (defun semantic-decoration-mode-setup ()
 263   "Setup the `semantic-decoration-mode' minor mode.
 264 The minor mode can be turned on only if the semantic feature is available
 265 and the current buffer was set up for parsing.  Return non-nil if the
 266 minor mode is enabled."
 267   (if semantic-decoration-mode
 268       (if (not (and (featurep 'semantic) (semantic-active-p)))
 269           (progn
 270             ;; Disable minor mode if semantic stuff not available
 271             (setq semantic-decoration-mode nil)
 272             (error "Buffer %s was not set up for parsing"
 273                    (buffer-name)))
 274         ;; Add hooks
 275         (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
 276         (add-hook 'semantic-after-partial-cache-change-hook
 277                   'semantic-decorate-tags-after-partial-reparse nil t)
 278         (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
 279         (add-hook 'semantic-after-toplevel-cache-change-hook
 280                   'semantic-decorate-tags-after-full-reparse nil t)
 281         ;; Add decorations to available tags.  The above hooks ensure
 282         ;; that new tags will be decorated when they become available.
 283         (semantic-decorate-add-decorations (semantic-fetch-available-tags))
 284         )
 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-decoration-mode)
 296
 297 (defun semantic-decoration-mode (&optional arg)
 298   "Minor mode for decorating tags.
 299 Decorations are specified in `semantic-decoration-styles'.
 300 You can define new decoration styles with
 301 `define-semantic-decoration-style'.
 302 With prefix argument ARG, turn on if positive, otherwise off.  The
 303 minor mode can be turned on only if semantic feature is available and
 304 the current buffer was set up for parsing.  Return non-nil if the
 305 minor mode is enabled."
 306 ;;
 307 ;;\\{semantic-decoration-map}"
 308   (interactive
 309    (list (or current-prefix-arg
 310              (if semantic-decoration-mode 0 1))))
 311   (setq semantic-decoration-mode
 312         (if arg
 313             (>
 314              (prefix-numeric-value arg)
 315              0)
 316           (not semantic-decoration-mode)))
 317   (semantic-decoration-mode-setup)
 318   (run-hooks 'semantic-decoration-mode-hook)
 319   (if (called-interactively-p 'interactive)
 320       (message "decoration-mode minor mode %sabled"
 321                (if semantic-decoration-mode "en" "dis")))
 322   (semantic-mode-line-update)
 323   semantic-decoration-mode)
 324
 325 (semantic-add-minor-mode 'semantic-decoration-mode
 326                          ""
 327                          nil)
 328
 329 (defun semantic-decorate-tags-after-full-reparse (tag-list)
 330   "Add decorations after a complete reparse of the current buffer.
 331 TAG-LIST is the list of tags recently parsed.
 332 Flush all existing decorations and call `semantic-decorate-add-decorations' to
 333 add decorations.
 334 Called from `semantic-after-toplevel-cache-change-hook'."
 335   ;; Flush everything
 336   (semantic-decorate-flush-decorations)
 337   ;; Add it back on
 338   (semantic-decorate-add-decorations tag-list))
 339
 340 (defun semantic-decorate-tags-after-partial-reparse (tag-list)
 341   "Add decorations when new tags are created in the current buffer.
 342 TAG-LIST is the list of newly created tags.
 343 Call `semantic-decorate-add-decorations' to add decorations.
 344 Called from `semantic-after-partial-cache-change-hook'."
 345   (semantic-decorate-add-decorations tag-list))
 346
 347 \f
 348 ;;; Enable/Disable toggling
 349 ;;
 350 (defun semantic-decoration-style-enabled-p (style)
 351   "Return non-nil if STYLE is currently enabled.
 352 Return nil if the style is disabled, or does not exist."
 353   (let ((pair (assoc style semantic-decoration-styles)))
 354     (and pair (cdr pair))))
 355
 356 (defun semantic-toggle-decoration-style (name &optional arg)
 357   "Turn on/off the decoration style with NAME.
 358 Decorations are specified in `semantic-decoration-styles'.
 359 With prefix argument ARG, turn on if positive, otherwise off.
 360 Return non-nil if the decoration style is enabled."
 361   (interactive
 362    (list (completing-read "Decoration style: "
 363                           semantic-decoration-styles nil t)
 364          current-prefix-arg))
 365   (setq name (format "%s" name)) ;; Ensure NAME is a string.
 366   (unless (equal name "")
 367     (let* ((style (assoc name semantic-decoration-styles))
 368            (flag  (if arg
 369                       (> (prefix-numeric-value arg) 0)
 370                     (not (cdr style)))))
 371       (unless (eq (cdr style) flag)
 372         ;; Store the new flag.
 373         (setcdr style flag)
 374         ;; Refresh decorations is `semantic-decoration-mode' is on.
 375         (when semantic-decoration-mode
 376           (semantic-decoration-mode -1)
 377           (semantic-decoration-mode 1))
 378         (when (called-interactively-p 'interactive)
 379           (message "Decoration style %s turned %s" (car style)
 380                    (if flag "on" "off"))))
 381       flag)))
 382
 383 (defvar semantic-decoration-menu-cache nil
 384   "Cache of the decoration menu.")
 385
 386 (defun semantic-decoration-build-style-menu (style)
 387   "Build a menu item for controlling a specific decoration STYLE."
 388   (vector (car style)
 389           `(lambda () (interactive)
 390              (semantic-toggle-decoration-style
 391               ,(car style)))
 392           :style 'toggle
 393           :selected `(semantic-decoration-style-enabled-p ,(car style))
 394           ))
 395
 396 (defun semantic-build-decoration-mode-menu (&rest ignore)
 397   "Create a menu listing all the known decorations for toggling.
 398 IGNORE any input arguments."
 399   (or semantic-decoration-menu-cache
 400       (setq semantic-decoration-menu-cache
 401             (mapcar 'semantic-decoration-build-style-menu
 402                     (reverse semantic-decoration-styles))
 403             )))
 404
 405 \f
 406 ;;; Defining decoration styles
 407 ;;
 408 (defmacro define-semantic-decoration-style (name doc &rest flags)
 409   "Define a new decoration style with NAME.
 410 DOC is a documentation string describing the decoration style NAME.
 411 It is appended to auto-generated doc strings.
 412 An Optional list of FLAGS can also be specified.  Flags are:
 413   :enabled <value>  - specify the default enabled value for NAME.
 414
 415
 416 This defines two new overload functions respectively called `NAME-p'
 417 and `NAME-highlight', for which you must provide a default
 418 implementation in respectively the functions `NAME-p-default' and
 419 `NAME-highlight-default'.  Those functions are passed a tag.  `NAME-p'
 420 must return non-nil to indicate that the tag should be decorated by
 421 `NAME-highlight'.
 422
 423 To put primary decorations on a tag `NAME-highlight' must use
 424 functions like `semantic-set-tag-face', `semantic-set-tag-intangible',
 425 etc., found in the semantic-decorate library.
 426
 427 To add other kind of decorations on a tag, `NAME-highlight' must use
 428 `semantic-decorate-tag', and other functions of the semantic
 429 decoration API found in this library."
 430   (let ((predicate   (semantic-decorate-style-predicate   name))
 431         (highlighter (semantic-decorate-style-highlighter name))
 432         (defaultenable (if (plist-member flags :enabled)
 433                            (plist-get flags :enabled)
 434                          t))
 435         )
 436     `(progn
 437        ;; Clear the menu cache so that new items are added when
 438        ;; needed.
 439        (setq semantic-decoration-menu-cache nil)
 440        ;; Create an override method to specify if a given tag belongs
 441        ;; to this type of decoration
 442        (define-overloadable-function ,predicate (tag)
 443          ,(format "Return non-nil to decorate TAG with `%s' style.\n%s"
 444                   name doc))
 445        ;; Create an override method that will perform the highlight
 446        ;; operation if the -p method returns non-nil.
 447        (define-overloadable-function ,highlighter (tag)
 448          ,(format "Decorate TAG with `%s' style.\n%s"
 449                   name doc))
 450        ;; Add this to the list of primary decoration modes.
 451        (add-to-list 'semantic-decoration-styles
 452                     (cons ',(symbol-name name)
 453                           ,defaultenable))
 454        )))
 455 \f
 456 ;;; Predefined decoration styles
 457 ;;
 458
 459 ;;; Tag boundaries highlighting
 460 ;;
 461 (define-semantic-decoration-style semantic-tag-boundary
 462   "Place an overline in front of each long tag.
 463 Does not provide overlines for prototypes.")
 464
 465 (defface semantic-tag-boundary-face
 466   '((((class color) (background dark))
 467      (:overline "cyan"))
 468     (((class color) (background light))
 469      (:overline "blue")))
 470   "*Face used to show long tags in.
 471 Used by decoration style: `semantic-tag-boundary'."
 472   :group 'semantic-faces)
 473
 474 (defun semantic-tag-boundary-p-default (tag)
 475   "Return non-nil if TAG is a type, or a non-prototype function."
 476   (let ((c (semantic-tag-class tag)))
 477     (and
 478      (or
 479       ;; All types get a line?
 480       (eq c 'type)
 481       ;; Functions which aren't prototypes get a line.
 482       (and (eq c 'function)
 483            (not (semantic-tag-get-attribute tag :prototype-flag)))
 484       )
 485      ;; Note: The below restriction confused users.
 486      ;;
 487      ;; Nothing smaller than a few lines
 488      ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
 489      ;; Random truth
 490      t)
 491     ))
 492
 493 (defun semantic-tag-boundary-highlight-default (tag)
 494   "Highlight the first line of TAG as a boundary."
 495   (when (bufferp (semantic-tag-buffer tag))
 496     (with-current-buffer (semantic-tag-buffer tag)
 497       (semantic-decorate-tag
 498        tag
 499        (semantic-tag-start tag)
 500        (save-excursion
 501          (goto-char (semantic-tag-start tag))
 502          (end-of-line)
 503          (forward-char 1)
 504          (point))
 505        'semantic-tag-boundary-face))
 506     ))
 507
 508 ;;; Private member highlighting
 509 ;;
 510 (define-semantic-decoration-style semantic-decoration-on-private-members
 511   "Highlight class members that are designated as PRIVATE access."
 512   :enabled nil)
 513
 514 (defface semantic-decoration-on-private-members-face
 515   '((((class color) (background dark))
 516      (:background "#200000"))
 517     (((class color) (background light))
 518      (:background "#8fffff")))
 519   "*Face used to show privately scoped tags in.
 520 Used by the decoration style: `semantic-decoration-on-private-members'."
 521   :group 'semantic-faces)
 522
 523 (defun semantic-decoration-on-private-members-highlight-default (tag)
 524   "Highlight TAG as designated to have PRIVATE access.
 525 Use a primary decoration."
 526   (semantic-set-tag-face
 527    tag 'semantic-decoration-on-private-members-face))
 528
 529 (defun semantic-decoration-on-private-members-p-default (tag)
 530   "Return non-nil if TAG has PRIVATE access."
 531   (and (member (semantic-tag-class tag) '(function variable))
 532        (eq (semantic-tag-protection tag) 'private)))
 533
 534 ;;; Protected member highlighting
 535 ;;
 536 (defface semantic-decoration-on-protected-members-face
 537   '((((class color) (background dark))
 538      (:background "#000020"))
 539     (((class color) (background light))
 540      (:background "#fffff8")))
 541   "*Face used to show protected scoped tags in.
 542 Used by the decoration style: `semantic-decoration-on-protected-members'."
 543   :group 'semantic-faces)
 544
 545 (define-semantic-decoration-style semantic-decoration-on-protected-members
 546   "Highlight class members that are designated as PROTECTED access."
 547   :enabled nil)
 548
 549 (defun semantic-decoration-on-protected-members-p-default (tag)
 550   "Return non-nil if TAG has PROTECTED access."
 551   (and (member (semantic-tag-class tag) '(function variable))
 552        (eq (semantic-tag-protection tag) 'protected)))
 553
 554 (defun semantic-decoration-on-protected-members-highlight-default (tag)
 555   "Highlight TAG as designated to have PROTECTED access.
 556 Use a primary decoration."
 557   (semantic-set-tag-face
 558    tag 'semantic-decoration-on-protected-members-face))
 559
 560 (provide 'semantic/decorate/mode)
 561
 562 ;; Local variables:
 563 ;; generated-autoload-file: "../loaddefs.el"
 564 ;; generated-autoload-load-name: "semantic/decorate/mode"
 565 ;; End:
 566
 567 ;; arch-tag: c1ac7888-e323-4467-96d6-18eb2820ed58
 568 ;;; semantic/decorate/mode.el ends here