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

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