cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-util-modes.el

   1 ;;; semantic-util-modes.el --- Semantic minor modes
   2
   3 ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam
   4 ;;; Copyright (C) 2001 David Ponce
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7 ;; Author: David Ponce <david@dponce.com>
   8 ;; Keywords: syntax
   9 ;; X-RCS: $Id: semantic-util-modes.el,v 1.59 2007/02/19 02:54:37 zappo Exp $
  10
  11 ;; This file is not part of GNU Emacs.
  12
  13 ;; Semantic is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.:
  17
  18 ;; This software is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;;  Semantic utility minor modes.
  31 ;;
  32
  33 ;;; Code:
  34 (require 'working)
  35 (require 'semantic)
  36
  37 (eval-when-compile
  38   (require 'semantic-decorate)
  39   )
  40
  41 ;;; Compatibility
  42 (if (fboundp 'propertize)
  43     (defalias 'semantic-propertize 'propertize)
  44   (defsubst semantic-propertize (string &rest properties)
  45     "Return a copy of STRING with text properties added.
  46 Dummy implementation for compatibility which just return STRING and
  47 ignore PROPERTIES."
  48     string)
  49   )
  50
  51 ;;; Group for all semantic enhancing modes
  52 (defgroup semantic-modes nil
  53   "Minor modes associated with the Semantic architecture."
  54   :group 'semantic)
  55
  56 ;;;;
  57 ;;;; Semantic minor modes stuff
  58 ;;;;
  59 (defcustom semantic-update-mode-line t
  60   "*If non-nil, show enabled minor modes in the mode line.
  61 Only minor modes that are not turned on globally are shown in the mode
  62 line."
  63   :group 'semantic
  64   :type 'boolean
  65   :require 'semantic-util-modes
  66   :initialize 'custom-initialize-default
  67   :set (lambda (sym val)
  68          (set-default sym val)
  69          ;; Update status of all Semantic enabled buffers
  70          (semantic-map-buffers
  71           #'semantic-mode-line-update)))
  72
  73 (defcustom semantic-mode-line-prefix
  74   (semantic-propertize "S" 'face 'bold)
  75   "*Prefix added to minor mode indicators in the mode line."
  76   :group 'semantic
  77   :type 'string
  78   :require 'semantic-util-modes
  79   :initialize 'custom-initialize-default)
  80
  81 (defvar semantic-minor-modes-status nil
  82   "String showing Semantic minor modes which are locally enabled.
  83 It is displayed in the mode line.")
  84 (make-variable-buffer-local 'semantic-minor-modes-status)
  85
  86 (defvar semantic-minor-mode-alist nil
  87   "Alist saying how to show Semantic minor modes in the mode line.
  88 Like variable `minor-mode-alist'.")
  89
  90 (defun semantic-mode-line-update ()
  91   "Update display of Semantic minor modes in the mode line.
  92 Only minor modes that are locally enabled are shown in the mode line."
  93   (setq semantic-minor-modes-status nil)
  94   (if semantic-update-mode-line
  95       (let ((ml semantic-minor-mode-alist)
  96             mm ms see)
  97         (while ml
  98           (setq mm (car ml)
  99                 ms (cadr mm)
 100                 mm (car mm)
 101                 ml (cdr ml))
 102           (when (and (symbol-value mm)
 103                      ;; Only show local minor mode status
 104                      (not (memq mm semantic-init-hooks)))
 105             (and ms
 106                  (symbolp ms)
 107                  (setq ms (symbol-value ms)))
 108             (and (stringp ms)
 109                  (not (member ms see)) ;; Don't duplicate same status
 110                  (setq see (cons ms see)
 111                        ms (if (string-match "^[ ]*\\(.+\\)" ms)
 112                               (match-string 1 ms)))
 113                  (setq semantic-minor-modes-status
 114                        (if semantic-minor-modes-status
 115                            (concat semantic-minor-modes-status "/" ms)
 116                          ms)))))
 117         (if semantic-minor-modes-status
 118             (setq semantic-minor-modes-status
 119                   (concat
 120                    " "
 121                    (if (string-match "^[ ]*\\(.+\\)"
 122                                      semantic-mode-line-prefix)
 123                        (match-string 1 semantic-mode-line-prefix)
 124                      "S")
 125                    "/"
 126                    semantic-minor-modes-status)))))
 127   (working-mode-line-update))
 128
 129 (defun semantic-add-minor-mode (toggle name &optional keymap)
 130   "Register a new Semantic minor mode.
 131 TOGGLE is a symbol which is the name of a buffer-local variable that
 132 is toggled on or off to say whether the minor mode is active or not.
 133 It is also an interactive function to toggle the mode.
 134
 135 NAME specifies what will appear in the mode line when the minor mode
 136 is active.  NAME should be either a string starting with a space, or a
 137 symbol whose value is such a string.
 138
 139 Optional KEYMAP is the keymap for the minor mode that will be added to
 140 `minor-mode-map-alist'."
 141   ;; Add a dymmy semantic minor mode to display the status
 142   (or (assq 'semantic-minor-modes-status minor-mode-alist)
 143       (setq minor-mode-alist (cons (list 'semantic-minor-modes-status
 144                                          'semantic-minor-modes-status)
 145                                    minor-mode-alist)))
 146   (if (fboundp 'add-minor-mode)
 147       ;; Emacs 21 & XEmacs
 148       (add-minor-mode toggle "" keymap)
 149     ;; Emacs 20
 150     (or (assq toggle minor-mode-alist)
 151         (setq minor-mode-alist (cons (list toggle "") minor-mode-alist)))
 152     (or (not keymap)
 153         (assq toggle minor-mode-map-alist)
 154         (setq minor-mode-map-alist (cons (cons toggle keymap)
 155                                          minor-mode-map-alist))))
 156   ;; Record how to display this minor mode in the mode line
 157   (let ((mm (assq toggle semantic-minor-mode-alist)))
 158     (if mm
 159         (setcdr mm (list name))
 160       (setq semantic-minor-mode-alist (cons (list toggle name)
 161                                        semantic-minor-mode-alist)))))
 162
 163 (defun semantic-toggle-minor-mode-globally (mode &optional arg)
 164   "Toggle minor mode MODE in every Semantic enabled buffer.
 165 Return non-nil if MODE is turned on in every Semantic enabled buffer.
 166 If ARG is positive, enable, if it is negative, disable.  If ARG is
 167 nil, then toggle.  Otherwise do nothing.  MODE must be a valid minor
 168 mode defined in `minor-mode-alist' and must be too an interactive
 169 function used to toggle the mode."
 170   (or (and (fboundp mode) (assq mode minor-mode-alist))
 171       (error "Semantic minor mode %s not found" mode))
 172   (if (not arg)
 173       (if (memq mode semantic-init-hooks)
 174           (setq arg -1)
 175         (setq arg 1)))
 176   ;; Add or remove the MODE toggle function from
 177   ;; `semantic-init-hooks'.  Then turn MODE on or off in every
 178   ;; Semantic enabled buffer.
 179   (cond
 180    ;; Turn off if ARG < 0
 181    ((< arg 0)
 182     (remove-hook 'semantic-init-hooks mode)
 183     (semantic-map-buffers #'(lambda () (funcall mode -1)))
 184     nil)
 185    ;; Turn on if ARG > 0
 186    ((> arg 0)
 187     (add-hook 'semantic-init-hooks mode)
 188     (semantic-map-buffers #'(lambda () (funcall mode 1)))
 189     t)
 190    ;; Otherwise just check MODE state
 191    (t
 192     (memq mode semantic-init-hooks))
 193    ))
 194 \f
 195 ;;;;
 196 ;;;; Minor mode to highlight areas that a user edits.
 197 ;;;;
 198
 199 ;;;###autoload
 200 (defun global-semantic-highlight-edits-mode (&optional arg)
 201   "Toggle global use of option `semantic-highlight-edits-mode'.
 202 If ARG is positive, enable, if it is negative, disable.
 203 If ARG is nil, then toggle."
 204   (interactive "P")
 205   (setq global-semantic-highlight-edits-mode
 206         (semantic-toggle-minor-mode-globally
 207          'semantic-highlight-edits-mode arg)))
 208
 209 ;;;###autoload
 210 (defcustom global-semantic-highlight-edits-mode nil
 211   "*If non-nil enable global use of variable `semantic-highlight-edits-mode'.
 212 When this mode is enabled, changes made to a buffer are highlighted
 213 until the buffer is reparsed."
 214   :group 'semantic
 215   :group 'semantic-modes
 216   :type 'boolean
 217   :require 'semantic-util-modes
 218   :initialize 'custom-initialize-default
 219   :set (lambda (sym val)
 220          (global-semantic-highlight-edits-mode (if val 1 -1))))
 221
 222 (defcustom semantic-highlight-edits-mode-hook nil
 223   "*Hook run at the end of function `semantic-highlight-edits-mode'."
 224   :group 'semantic
 225   :type 'hook)
 226
 227 (defface semantic-highlight-edits-face
 228   '((((class color) (background dark))
 229      ;; Put this back to something closer to black later.
 230      (:background "gray20"))
 231     (((class color) (background light))
 232      (:background "gray90")))
 233   "*Face used to show dirty tokens in `semantic-highlight-edits-mode'."
 234   :group 'semantic)
 235
 236 (defun semantic-highlight-edits-new-change-hook-fcn (overlay)
 237   "Function set into `semantic-edits-new-change-hook'.
 238 Argument OVERLAY is the overlay created to mark the change.
 239 This function will set the face property on this overlay."
 240   (semantic-overlay-put overlay 'face 'semantic-highlight-edits-face))
 241
 242 (defvar semantic-highlight-edits-mode-map
 243   (let ((km (make-sparse-keymap)))
 244     km)
 245   "Keymap for highlight-edits minor mode.")
 246
 247 (defvar semantic-highlight-edits-mode nil
 248   "Non-nil if highlight-edits minor mode is enabled.
 249 Use the command `semantic-highlight-edits-mode' to change this variable.")
 250 (make-variable-buffer-local 'semantic-highlight-edits-mode)
 251
 252 (defun semantic-highlight-edits-mode-setup ()
 253   "Setup option `semantic-highlight-edits-mode'.
 254 The minor mode can be turned on only if semantic feature is available
 255 and the current buffer was set up for parsing.  When minor mode is
 256 enabled parse the current buffer if needed.  Return non-nil if the
 257 minor mode is enabled."
 258   (if semantic-highlight-edits-mode
 259       (if (not (and (featurep 'semantic) (semantic-active-p)))
 260           (progn
 261             ;; Disable minor mode if semantic stuff not available
 262             (setq semantic-highlight-edits-mode nil)
 263             (error "Buffer %s was not set up for parsing"
 264                    (buffer-name)))
 265         (semantic-make-local-hook 'semantic-edits-new-change-hooks)
 266         (add-hook 'semantic-edits-new-change-hooks
 267                   'semantic-highlight-edits-new-change-hook-fcn nil t)
 268         )
 269     ;; Remove hooks
 270     (remove-hook 'semantic-edits-new-change-hooks
 271                  'semantic-highlight-edits-new-change-hook-fcn t)
 272     )
 273   semantic-highlight-edits-mode)
 274
 275 ;;;###autoload
 276 (defun semantic-highlight-edits-mode (&optional arg)
 277   "Minor mode for highlighting changes made in a buffer.
 278 Changes are tracked by semantic so that the incremental parser can work
 279 properly.
 280 This mode will highlight those changes as they are made, and clear them
 281 when the incremental parser accounts for those edits.
 282 With prefix argument ARG, turn on if positive, otherwise off.  The
 283 minor mode can be turned on only if semantic feature is available and
 284 the current buffer was set up for parsing.  Return non-nil if the
 285 minor mode is enabled."
 286   (interactive
 287    (list (or current-prefix-arg
 288              (if semantic-highlight-edits-mode 0 1))))
 289   (setq semantic-highlight-edits-mode
 290         (if arg
 291             (>
 292              (prefix-numeric-value arg)
 293              0)
 294           (not semantic-highlight-edits-mode)))
 295   (semantic-highlight-edits-mode-setup)
 296   (run-hooks 'semantic-highlight-edits-mode-hook)
 297   (if (interactive-p)
 298       (message "highlight-edits minor mode %sabled"
 299                (if semantic-highlight-edits-mode "en" "dis")))
 300   (semantic-mode-line-update)
 301   semantic-highlight-edits-mode)
 302
 303 (semantic-add-minor-mode 'semantic-highlight-edits-mode
 304                          "e"
 305                          semantic-highlight-edits-mode-map)
 306
 307 \f
 308 ;;;;
 309 ;;;; Minor mode to show unmatched-syntax elements
 310 ;;;;
 311
 312 ;;;###autoload
 313 (defun global-semantic-show-unmatched-syntax-mode (&optional arg)
 314   "Toggle global use of option `semantic-show-unmatched-syntax-mode'.
 315 If ARG is positive, enable, if it is negative, disable.
 316 If ARG is nil, then toggle."
 317   (interactive "P")
 318   (setq global-semantic-show-unmatched-syntax-mode
 319         (semantic-toggle-minor-mode-globally
 320          'semantic-show-unmatched-syntax-mode arg)))
 321
 322 ;;;###autoload
 323 (defcustom global-semantic-show-unmatched-syntax-mode nil
 324   "*If non-nil, enable global use of `semantic-show-unmatched-syntax-mode'.
 325 When this mode is enabled, syntax in the current buffer which the
 326 semantic parser cannot match is highlighted with a red underline."
 327   :group 'semantic
 328   :group 'semantic-modes
 329   :type 'boolean
 330   :require 'semantic-util-modes
 331   :initialize 'custom-initialize-default
 332   :set (lambda (sym val)
 333          (global-semantic-show-unmatched-syntax-mode (if val 1 -1))))
 334
 335 (defcustom semantic-show-unmatched-syntax-mode-hook nil
 336   "*Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
 337   :group 'semantic
 338   :type 'hook)
 339
 340 (defface semantic-unmatched-syntax-face
 341   '((((class color) (background dark))
 342      (:underline "red"))
 343     (((class color) (background light))
 344      (:underline "red")))
 345   "*Face used to show unmatched syntax in.
 346 The face is used in  `semantic-show-unmatched-syntax-mode'."
 347   :group 'semantic)
 348
 349 (defsubst semantic-unmatched-syntax-overlay-p (overlay)
 350   "Return non-nil if OVERLAY is an unmatched syntax one."
 351   (eq (semantic-overlay-get overlay 'semantic) 'unmatched))
 352
 353 (defun semantic-showing-unmatched-syntax-p ()
 354   "Return non-nil if an unmatched syntax overlay was found in buffer."
 355   (let ((ol (semantic-overlays-in (point-min) (point-max)))
 356         found)
 357     (while (and ol (not found))
 358       (setq found (semantic-unmatched-syntax-overlay-p (car ol))
 359             ol    (cdr ol)))
 360     found))
 361
 362 (defun semantic-show-unmatched-lex-tokens-fetch ()
 363   "Fetch a list of unmatched lexical tokens from the current buffer.
 364 Uses the overlays which have accurate bounds, and rebuilds what was
 365 originally passed in."
 366   (let ((ol (semantic-overlays-in (point-min) (point-max)))
 367         (ustc nil))
 368     (while ol
 369       (if (semantic-unmatched-syntax-overlay-p (car ol))
 370           (setq ustc (cons (cons 'thing
 371                                  (cons (semantic-overlay-start (car ol))
 372                                        (semantic-overlay-end (car ol))))
 373                            ustc)))
 374       (setq ol (cdr ol)))
 375     (nreverse ustc))
 376   )
 377
 378 (defun semantic-clean-unmatched-syntax-in-region (beg end)
 379   "Remove all unmatched syntax overlays between BEG and END."
 380   (let ((ol (semantic-overlays-in beg end)))
 381     (while ol
 382       (if (semantic-unmatched-syntax-overlay-p (car ol))
 383           (semantic-overlay-delete (car ol)))
 384       (setq ol (cdr ol)))))
 385
 386 (defsubst semantic-clean-unmatched-syntax-in-buffer ()
 387   "Remove all unmatched syntax overlays found in current buffer."
 388   (semantic-clean-unmatched-syntax-in-region
 389    (point-min) (point-max)))
 390
 391 (defsubst semantic-clean-token-of-unmatched-syntax (token)
 392   "Clean the area covered by TOKEN of unmatched syntax markers."
 393   (semantic-clean-unmatched-syntax-in-region
 394    (semantic-tag-start token) (semantic-tag-end token)))
 395
 396 (defun semantic-show-unmatched-syntax (syntax)
 397   "Function set into `semantic-unmatched-syntax-hook'.
 398 This will highlight elements in SYNTAX as unmatched syntax."
 399   ;; This is called when `semantic-show-unmatched-syntax-mode' is
 400   ;; enabled.  Highlight the unmatched syntax, and then add a semantic
 401   ;; property to that overlay so we can add it to the official list of
 402   ;; semantic supported overlays.  This gets it cleaned up for errors,
 403   ;; buffer cleaning, and the like.
 404   (semantic-clean-unmatched-syntax-in-buffer) ;Clear previous highlighting
 405   (if syntax
 406       (let (o)
 407         (while syntax
 408           (setq o (semantic-make-overlay (semantic-lex-token-start (car syntax))
 409                                          (semantic-lex-token-end (car syntax))))
 410           (semantic-overlay-put o 'semantic 'unmatched)
 411           (semantic-overlay-put o 'face 'semantic-unmatched-syntax-face)
 412           (setq syntax (cdr syntax))))
 413     ))
 414
 415 (defun semantic-next-unmatched-syntax (point &optional bound)
 416   "Find the next overlay for unmatched syntax after POINT.
 417 Do not search past BOUND if non-nil."
 418   (save-excursion
 419     (goto-char point)
 420     (let ((os point) (ol nil))
 421       (while (and os (< os (or bound (point-max))) (not ol))
 422         (setq os (semantic-overlay-next-change os))
 423         (when os
 424           ;; Get overlays at position
 425           (setq ol (semantic-overlays-at os))
 426           ;; find the overlay that belongs to semantic
 427           ;; and starts at the found position.
 428           (while (and ol (listp ol))
 429             (and (semantic-unmatched-syntax-overlay-p (car ol))
 430                  (setq ol (car ol)))
 431             (if (listp ol)
 432                 (setq ol (cdr ol))))))
 433       ol)))
 434
 435 (defvar semantic-show-unmatched-syntax-mode-map
 436   (let ((km (make-sparse-keymap)))
 437     (define-key km "\C-c,`" 'semantic-show-unmatched-syntax-next)
 438     km)
 439   "Keymap for command `semantic-show-unmatched-syntax-mode'.")
 440
 441 (defvar semantic-show-unmatched-syntax-mode nil
 442   "Non-nil if show-unmatched-syntax minor mode is enabled.
 443 Use the command `semantic-show-unmatched-syntax-mode' to change this
 444 variable.")
 445 (make-variable-buffer-local 'semantic-show-unmatched-syntax-mode)
 446
 447 (defun semantic-show-unmatched-syntax-mode-setup ()
 448   "Setup the `semantic-show-unmatched-syntax' minor mode.
 449 The minor mode can be turned on only if semantic feature is available
 450 and the current buffer was set up for parsing.  When minor mode is
 451 enabled parse the current buffer if needed.  Return non-nil if the
 452 minor mode is enabled."
 453   (if semantic-show-unmatched-syntax-mode
 454       (if (not (and (featurep 'semantic) (semantic-active-p)))
 455           (progn
 456             ;; Disable minor mode if semantic stuff not available
 457             (setq semantic-show-unmatched-syntax-mode nil)
 458             (error "Buffer %s was not set up for parsing"
 459                    (buffer-name)))
 460         ;; Add hooks
 461         (semantic-make-local-hook 'semantic-unmatched-syntax-hook)
 462         (add-hook 'semantic-unmatched-syntax-hook
 463                   'semantic-show-unmatched-syntax nil t)
 464         (semantic-make-local-hook 'semantic-pre-clean-token-hooks)
 465         (add-hook 'semantic-pre-clean-token-hooks
 466                   'semantic-clean-token-of-unmatched-syntax nil t)
 467         ;; Show unmatched syntax elements
 468         (if (not (semantic--umatched-syntax-needs-refresh-p))
 469             (semantic-show-unmatched-syntax
 470              (semantic-unmatched-syntax-tokens))))
 471     ;; Remove hooks
 472     (remove-hook 'semantic-unmatched-syntax-hook
 473                  'semantic-show-unmatched-syntax t)
 474     (remove-hook 'semantic-pre-clean-token-hooks
 475                  'semantic-clean-token-of-unmatched-syntax t)
 476     ;; Cleanup unmatched-syntax highlighting
 477     (semantic-clean-unmatched-syntax-in-buffer))
 478   semantic-show-unmatched-syntax-mode)
 479
 480 ;;;###autoload
 481 (defun semantic-show-unmatched-syntax-mode (&optional arg)
 482   "Minor mode to highlight unmatched lexical syntax tokens.
 483 When a parser executes, some elements in the buffer may not match any
 484 parser rules.  These text characters are considered unmatched syntax.
 485 Often time, the display of unmatched syntax can expose coding
 486 problems before the compiler is run.
 487
 488 With prefix argument ARG, turn on if positive, otherwise off.  The
 489 minor mode can be turned on only if semantic feature is available and
 490 the current buffer was set up for parsing.  Return non-nil if the
 491 minor mode is enabled.
 492
 493 \\{semantic-show-unmatched-syntax-mode-map}"
 494   (interactive
 495    (list (or current-prefix-arg
 496              (if semantic-show-unmatched-syntax-mode 0 1))))
 497   (setq semantic-show-unmatched-syntax-mode
 498         (if arg
 499             (>
 500              (prefix-numeric-value arg)
 501              0)
 502           (not semantic-show-unmatched-syntax-mode)))
 503   (semantic-show-unmatched-syntax-mode-setup)
 504   (run-hooks 'semantic-show-unmatched-syntax-mode-hook)
 505   (if (interactive-p)
 506       (message "show-unmatched-syntax minor mode %sabled"
 507                (if semantic-show-unmatched-syntax-mode "en" "dis")))
 508   (semantic-mode-line-update)
 509   semantic-show-unmatched-syntax-mode)
 510
 511 (semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
 512                          "u"
 513                          semantic-show-unmatched-syntax-mode-map)
 514
 515 (defun semantic-show-unmatched-syntax-next ()
 516   "Move forward to the next occurrence of unmatched syntax."
 517   (interactive)
 518   (let ((o (semantic-next-unmatched-syntax (point))))
 519     (if o
 520         (goto-char (semantic-overlay-start o)))))
 521
 522 \f
 523 ;;;;
 524 ;;;; Minor mode to display the parser state in the modeline.
 525 ;;;;
 526
 527 ;;;###autoload
 528 (defcustom global-semantic-show-parser-state-mode nil
 529   "*If non-nil enable global use of `semantic-show-parser-state-mode'.
 530 When enabled, the current parse state of the current buffer is displayed
 531 in the mode line. See `semantic-show-parser-state-marker' for details
 532 on what is displayed."
 533   :group 'semantic
 534   :type 'boolean
 535   :require 'semantic-util-modes
 536   :initialize 'custom-initialize-default
 537   :set (lambda (sym val)
 538          (global-semantic-show-parser-state-mode (if val 1 -1))))
 539
 540 ;;;###autoload
 541 (defun global-semantic-show-parser-state-mode (&optional arg)
 542   "Toggle global use of option `semantic-show-parser-state-mode'.
 543 If ARG is positive, enable, if it is negative, disable.
 544 If ARG is nil, then toggle."
 545   (interactive "P")
 546   (setq global-semantic-show-parser-state-mode
 547         (semantic-toggle-minor-mode-globally
 548          'semantic-show-parser-state-mode arg)))
 549
 550 (defcustom semantic-show-parser-state-mode-hook nil
 551   "*Hook run at the end of function `semantic-show-parser-state-mode'."
 552   :group 'semantic
 553   :type 'hook)
 554
 555 (defvar semantic-show-parser-state-mode-map
 556   (let ((km (make-sparse-keymap)))
 557     km)
 558   "Keymap for show-parser-state minor mode.")
 559
 560 (defvar semantic-show-parser-state-mode nil
 561   "Non-nil if show-parser-state minor mode is enabled.
 562 Use the command `semantic-show-parser-state-mode' to change this variable.")
 563 (make-variable-buffer-local 'semantic-show-parser-state-mode)
 564
 565 (defun semantic-show-parser-state-mode-setup ()
 566   "Setup option `semantic-show-parser-state-mode'.
 567 The minor mode can be turned on only if semantic feature is available
 568 and the current buffer was set up for parsing.  When minor mode is
 569 enabled parse the current buffer if needed.  Return non-nil if the
 570 minor mode is enabled."
 571   (if semantic-show-parser-state-mode
 572       (if (not (and (featurep 'semantic) (semantic-active-p)))
 573           (progn
 574             ;; Disable minor mode if semantic stuff not available
 575             (setq semantic-show-parser-state-mode nil)
 576             (error "Buffer %s was not set up for parsing"
 577                    (buffer-name)))
 578         ;; Set up mode line
 579
 580         (when (not
 581                (memq 'semantic-show-parser-state-string mode-line-modified))
 582           (setq mode-line-modified
 583                 (append mode-line-modified
 584                         '(semantic-show-parser-state-string))))
 585         ;; Add hooks
 586         (semantic-make-local-hook 'semantic-edits-new-change-hooks)
 587         (add-hook 'semantic-edits-new-change-hooks
 588                   'semantic-show-parser-state-marker nil t)
 589         (semantic-make-local-hook 'semantic-edits-incremental-reparse-failed-hooks)
 590         (add-hook 'semantic-edits-incremental-reparse-failed-hooks
 591                   'semantic-show-parser-state-marker nil t)
 592         (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
 593         (add-hook 'semantic-after-partial-cache-change-hook
 594                   'semantic-show-parser-state-marker nil t)
 595         (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
 596         (add-hook 'semantic-after-toplevel-cache-change-hook
 597                   'semantic-show-parser-state-marker nil t)
 598         (semantic-show-parser-state-marker)
 599
 600         (semantic-make-local-hook 'semantic-before-auto-parse-hooks)
 601         (add-hook 'semantic-before-auto-parse-hooks
 602                   'semantic-show-parser-state-auto-marker nil t)
 603         (semantic-make-local-hook 'semantic-after-auto-parse-hooks)
 604         (add-hook 'semantic-after-auto-parse-hooks
 605                   'semantic-show-parser-state-marker nil t)
 606
 607         (semantic-make-local-hook 'semantic-before-idle-scheduler-reparse-hooks)
 608         (add-hook 'semantic-before-idle-scheduler-reparse-hooks
 609                   'semantic-show-parser-state-auto-marker nil t)
 610         (semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hooks)
 611         (add-hook 'semantic-after-idle-scheduler-reparse-hooks
 612                   'semantic-show-parser-state-marker nil t)
 613         )
 614     ;; Remove parts of mode line
 615     (setq mode-line-modified
 616           (delq 'semantic-show-parser-state-string mode-line-modified))
 617     ;; Remove hooks
 618     (remove-hook 'semantic-edits-new-change-hooks
 619                  'semantic-show-parser-state-marker t)
 620     (remove-hook 'semantic-edits-incremental-reparse-failed-hooks
 621                  'semantic-show-parser-state-marker t)
 622     (remove-hook 'semantic-after-partial-cache-change-hook
 623                  'semantic-show-parser-state-marker t)
 624     (remove-hook 'semantic-after-toplevel-cache-change-hook
 625                  'semantic-show-parser-state-marker t)
 626
 627     (remove-hook 'semantic-before-auto-parse-hooks
 628                  'semantic-show-parser-state-auto-marker t)
 629     (remove-hook 'semantic-after-auto-parse-hooks
 630                  'semantic-show-parser-state-marker t)
 631
 632     (remove-hook 'semantic-before-idle-scheduler-reparse-hooks
 633                  'semantic-show-parser-state-auto-marker t)
 634     (remove-hook 'semantic-after-idle-scheduler-reparse-hooks
 635                  'semantic-show-parser-state-marker t)
 636     )
 637   semantic-show-parser-state-mode)
 638
 639 ;;;###autoload
 640 (defun semantic-show-parser-state-mode (&optional arg)
 641   "Minor mode for displaying parser cache state in the modeline.
 642 The cache can be in one of three states.  They are
 643 Up to date, Partial reprase needed, and Full reparse needed.
 644 The state is indicated in the modeline with the following characters:
 645  `-'  ->  The cache is up to date.
 646  `!'  ->  The cache requires a full update.
 647  `~'  ->  The cache needs to be incrementally parsed.
 648  `%'  ->  The cache is not currently parseable.
 649  `@'  ->  Auto-parse in progress (not set here.)
 650 With prefix argument ARG, turn on if positive, otherwise off.  The
 651 minor mode can be turned on only if semantic feature is available and
 652 the current buffer was set up for parsing.  Return non-nil if the
 653 minor mode is enabled."
 654   (interactive
 655    (list (or current-prefix-arg
 656              (if semantic-show-parser-state-mode 0 1))))
 657   (setq semantic-show-parser-state-mode
 658         (if arg
 659             (>
 660              (prefix-numeric-value arg)
 661              0)
 662           (not semantic-show-parser-state-mode)))
 663   (semantic-show-parser-state-mode-setup)
 664   (run-hooks 'semantic-show-parser-state-mode-hook)
 665   (if (interactive-p)
 666       (message "show-parser-state minor mode %sabled"
 667                (if semantic-show-parser-state-mode "en" "dis")))
 668   (semantic-mode-line-update)
 669   semantic-show-parser-state-mode)
 670
 671 (semantic-add-minor-mode 'semantic-show-parser-state-mode
 672                          ""
 673                          semantic-show-parser-state-mode-map)
 674
 675 (defvar semantic-show-parser-state-string nil
 676   "String showing the parser state for this buffer.
 677 See `semantic-show-parser-state-marker' for details.")
 678 (make-variable-buffer-local 'semantic-show-parser-state-string)
 679
 680 (defun semantic-show-parser-state-marker (&rest ignore)
 681   "Set `semantic-show-parser-state-string' to indicate parser state.
 682 This marker is one of the following:
 683  `-'  ->  The cache is up to date.
 684  `!'  ->  The cache requires a full update.
 685  `~'  ->  The cache needs to be incrementally parsed.
 686  `%'  ->  The cache is not currently parseable.
 687  `@'  ->  Auto-parse in progress (not set here.)
 688 Arguments IGNORE are ignored, and accepted so this can be used as a hook
 689 in many situations."
 690   (setq semantic-show-parser-state-string
 691         (cond ((semantic-parse-tree-needs-rebuild-p)
 692                "!")
 693               ((semantic-parse-tree-needs-update-p)
 694                "^")
 695               ((semantic-parse-tree-unparseable-p)
 696                "%")
 697               (t
 698                "-")))
 699   ;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string)
 700   (semantic-mode-line-update))
 701
 702 (defun semantic-show-parser-state-auto-marker ()
 703   "Hook function run before an autoparse.
 704 Set up `semantic-show-parser-state-marker' to show `@'
 705 to indicate a parse in progress."
 706   (unless (semantic-parse-tree-up-to-date-p)
 707     (setq semantic-show-parser-state-string "@")
 708     (semantic-mode-line-update)
 709     ;; For testing.
 710     ;;(sit-for 1)
 711     ))
 712
 713 \f
 714 ;;;;
 715 ;;;; Minor mode to make function decls sticky.
 716 ;;;;
 717
 718 ;;;###autoload
 719 (defun global-semantic-stickyfunc-mode (&optional arg)
 720   "Toggle global use of option `semantic-stickyfunc-mode'.
 721 If ARG is positive, enable, if it is negative, disable.
 722 If ARG is nil, then toggle."
 723   (interactive "P")
 724   (setq global-semantic-stickyfunc-mode
 725         (semantic-toggle-minor-mode-globally
 726          'semantic-stickyfunc-mode arg)))
 727
 728 ;;;###autoload
 729 (defcustom global-semantic-stickyfunc-mode nil
 730   "*If non-nil, enable global use of `semantic-stickyfunc-mode'.
 731 This minor mode only works for Emacs 21 or later.
 732 When enabled, the header line is enabled, and the first line
 733 of the current function or method is displayed in it.
 734 This makes it appear that the first line of that tag is
 735 `sticky' to the top of the window."
 736   :group 'semantic
 737   :group 'semantic-modes
 738   :type 'boolean
 739   :require 'semantic-util-modes
 740   :initialize 'custom-initialize-default
 741   :set (lambda (sym val)
 742          (global-semantic-stickyfunc-mode (if val 1 -1))))
 743
 744 (defcustom semantic-stickyfunc-mode-hook nil
 745   "*Hook run at the end of function `semantic-stickyfunc-mode'."
 746   :group 'semantic
 747   :type 'hook)
 748
 749 (defvar semantic-stickyfunc-mode-map
 750   (let ((km (make-sparse-keymap)))
 751     (define-key km [ header-line down-mouse-1 ] 'semantic-stickyfunc-menu)
 752     km)
 753   "Keymap for stickyfunc minor mode.")
 754
 755 (defvar semantic-stickyfunc-popup-menu nil
 756   "Menu used if the user clicks on the header line used by stickyfunc mode.")
 757
 758 (easy-menu-define
 759   semantic-stickyfunc-popup-menu
 760   semantic-stickyfunc-mode-map
 761   "Stickyfunc Menu"
 762   '("Stickyfunc Mode"  :visible (progn nil)
 763     [ "Copy Headerline Tag" senator-copy-tag
 764       :active (semantic-current-tag)
 765       :help "Copy the current tag to the tag ring"]
 766     [ "Kill Headerline Tag" senator-kill-tag
 767       :active (semantic-current-tag)
 768       :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
 769       ]
 770     [ "Copy Headerline Tag to Register" senator-copy-tag-to-register
 771       :active (semantic-current-tag)
 772       :help "Copy the current tag to a register"
 773       ]
 774     [ "Narrow To Headerline Tag" senator-narrow-to-defun
 775       :active (semantic-current-tag)
 776       :help "Narrow to the bounds of the current tag."]
 777     [ "Fold Headerline Tag" senator-fold-tag-toggle
 778       :active (semantic-current-tag)
 779       :style toggle
 780       :selected (let ((tag (semantic-current-tag)))
 781                   (and tag (semantic-tag-folded-p tag)))
 782       :help "Fold the current tag to one line"
 783       ]
 784     "---"
 785     [ "About This Header Line"
 786       (lambda () (interactive)
 787         (describe-function 'semantic-stickyfunc-mode)) t])
 788   )
 789
 790 (defvar semantic-stickyfunc-mode nil
 791   "Non-nil if stickyfunc minor mode is enabled.
 792 Use the command `semantic-stickyfunc-mode' to change this variable.")
 793 (make-variable-buffer-local 'semantic-stickyfunc-mode)
 794
 795 (defcustom semantic-stickyfunc-indent-string
 796   (if (and window-system (not (featurep 'xemacs)))
 797       (concat
 798        (condition-case nil
 799            ;; Test scroll bar location
 800            (let ((charwidth (frame-char-width))
 801                  (scrollpos (frame-parameter (selected-frame)
 802                                              'vertical-scroll-bars))
 803                  )
 804              (if (or (eq scrollpos 'left)
 805                      ;; Now wait a minute.  If you turn scroll-bar-mode
 806                      ;; on, then off, the new value is t, not left.
 807                      ;; Will this mess up older emacs where the default
 808                      ;; was on the right?  I don't think so since they don't
 809                      ;; support a header line.
 810                      (eq scrollpos t))
 811                  (let ((w (when (boundp 'scroll-bar-width)
 812                             (symbol-value 'scroll-bar-width))))
 813
 814                    (if (not w)
 815                        (setq w (frame-parameter (selected-frame)
 816                                                 'scroll-bar-width)))
 817
 818                    ;; in 21.2, the frame parameter is sometimes empty
 819                    ;; so we need to get the value here.
 820                    (if (not w)
 821                        (setq w (+ (get 'scroll-bar-width 'x-frame-parameter)
 822                                   ;; In 21.4, or perhaps 22.1 the x-frame
 823                                   ;; parameter is different from the frame
 824                                   ;; parameter by only 1 pixel.
 825                                   1)))
 826
 827                    (if (not w)
 828                        "  "
 829                      (setq w (+ 2 w))   ; Some sort of border around
 830                                         ; the scrollbar.
 831                      (make-string (/ w charwidth) ? )))
 832                ""))
 833          (error ""))
 834        (condition-case nil
 835            ;; Test fringe size.
 836            (let* ((f (window-fringes))
 837                   (fw (car f))
 838                   (numspace (/ fw charwidth))
 839                   )
 840              (make-string numspace ? ))
 841          (error
 842           ;; Well, the fancy new Emacs functions failed.  Try older
 843           ;; tricks.
 844           (condition-case nil
 845               ;; I'm not so sure what's up with the 21.1-21.3 fringe.
 846               ;; It looks to be about 1 space wide.
 847               (if (get 'fringe 'face)
 848                   " "
 849                 "")
 850             (error ""))))
 851        )
 852     ;; Not Emacs or a window system means no scrollbar or fringe,
 853     ;; and perhaps not even a header line to worry about.
 854     "")
 855   "*String used to indent the stickyfunc header.
 856 Customize this string to match the space used by scrollbars and
 857 fringe so it does not appear that the code is moving left/right
 858 when it lands in the sticky line."
 859   :group 'semantic
 860   :type 'string)
 861
 862 (defvar semantic-stickyfunc-old-hlf nil
 863   "Value of the header line when entering sticky func mode.")
 864
 865 (defconst semantic-stickyfunc-header-line-format
 866   '(:eval (list semantic-stickyfunc-indent-string
 867                 (semantic-stickyfunc-fetch-stickyline)))
 868   "The header line format used by sticky func mode.")
 869
 870 (defun semantic-stickyfunc-mode-setup ()
 871   "Setup option `semantic-stickyfunc-mode'.
 872 For semantic enabled buffers, make the function declaration for the top most
 873 function \"sticky\".  This is accomplished by putting the first line of
 874 text for that function in Emacs 21's header line."
 875   (if semantic-stickyfunc-mode
 876       (progn
 877         (unless (and (featurep 'semantic) (semantic-active-p))
 878           ;; Disable minor mode if semantic stuff not available
 879           (setq semantic-stickyfunc-mode nil)
 880           (error "Buffer %s was not set up for parsing" (buffer-name)))
 881         (unless (boundp 'default-header-line-format)
 882           ;; Disable if there are no header lines to use.
 883           (setq semantic-stickyfunc-mode nil)
 884           (error "Sticky Function mode requires Emacs 21"))
 885         ;; Enable the mode
 886         ;; Save previous buffer local value of header line format.
 887         (when (and (local-variable-p 'header-line-format (current-buffer))
 888                    (not (eq header-line-format
 889                             semantic-stickyfunc-header-line-format)))
 890           (set (make-local-variable 'semantic-stickyfunc-old-hlf)
 891                header-line-format))
 892         (setq header-line-format semantic-stickyfunc-header-line-format)
 893         )
 894     ;; Disable sticky func mode
 895     ;; Restore previous buffer local value of header line format if
 896     ;; the current one is the sticky func one.
 897     (when (eq header-line-format semantic-stickyfunc-header-line-format)
 898       (kill-local-variable 'header-line-format)
 899       (when (local-variable-p 'semantic-stickyfunc-old-hlf (current-buffer))
 900         (setq header-line-format semantic-stickyfunc-old-hlf)
 901         (kill-local-variable 'semantic-stickyfunc-old-hlf))))
 902   semantic-stickyfunc-mode)
 903
 904 ;;;###autoload
 905 (defun semantic-stickyfunc-mode (&optional arg)
 906   "Minor mode to show the title of a tag in the header line.
 907 Enables/disables making the header line of functions sticky.
 908 A function (or other tag class specified by
 909 `semantic-stickyfunc-sticky-classes') has a header line, meaning the
 910 first line which describes the rest of the construct.  This first
 911 line is what is displayed in the Emacs 21 header line.
 912
 913 With prefix argument ARG, turn on if positive, otherwise off.  The
 914 minor mode can be turned on only if semantic feature is available and
 915 the current buffer was set up for parsing.  Return non-nil if the
 916 minor mode is enabled."
 917   (interactive
 918    (list (or current-prefix-arg
 919              (if semantic-stickyfunc-mode 0 1))))
 920   (setq semantic-stickyfunc-mode
 921         (if arg
 922             (>
 923              (prefix-numeric-value arg)
 924              0)
 925           (not semantic-stickyfunc-mode)))
 926   (semantic-stickyfunc-mode-setup)
 927   (run-hooks 'semantic-stickyfunc-mode-hook)
 928   (if (interactive-p)
 929       (message "Stickyfunc minor mode %sabled"
 930                (if semantic-stickyfunc-mode "en" "dis")))
 931   (semantic-mode-line-update)
 932   semantic-stickyfunc-mode)
 933
 934 (defvar semantic-stickyfunc-sticky-classes
 935   '(function type)
 936   "List of tag classes which sticky func will display in the header line.")
 937 (make-variable-buffer-local 'semantic-stickyfunc-sticky-classes)
 938
 939 (defun semantic-stickyfunc-fetch-stickyline ()
 940   "Make the function at the top of the current window sticky.
 941 Capture it's function declaration, and place it in the header line.
 942 If there is no function, disable the header line."
 943   (let ((str
 944          (save-excursion
 945            (goto-char (window-start (selected-window)))
 946            (forward-line -1)
 947            (end-of-line)
 948            ;; Capture this function
 949            (let* ((tags (nreverse (semantic-find-tag-by-overlay (point))))
 950                   (tag (progn
 951                          ;; Get rid of non-matching tags.
 952                          (while (and tags
 953                                      (not (member
 954                                            (semantic-tag-class (car tags))
 955                                            semantic-stickyfunc-sticky-classes))
 956                                      )
 957                            (setq tags (cdr tags)))
 958                          (car tags))))
 959              ;; TAG is nil if there was nothing of the apropriate type there.
 960              (if (not tag)
 961                  ;; Set it to be the text under the header line
 962                  (buffer-substring (point-at-bol) (point-at-eol))
 963                ;; Get it
 964                (goto-char (semantic-tag-start tag))
 965                ;; Klaus Berndl <klaus.berndl@sdm.de>:
 966                ;; goto the tag name; this is especially needed for languages
 967                ;; like c++ where a often used style is like:
 968                ;;     void
 969                ;;     ClassX::methodM(arg1...)
 970                ;;     {
 971                ;;       ...
 972                ;;     }
 973                ;; Without going to the tag-name we would get"void" in the
 974                ;; header line which is IMHO not really useful
 975                (search-forward (semantic-tag-name tag) nil t)
 976                (buffer-substring (point-at-bol) (point-at-eol))
 977                ))))
 978         (start 0))
 979     (while (string-match "%" str start)
 980       (setq str (replace-match "%%" t t str 0)
 981             start (1+ (match-end 0)))
 982       )
 983     ;; In 21.4 (or 22.1) the heder doesn't expand tabs.  Hmmmm.
 984     ;; We should replace them here.
 985     ;;
 986     ;; This hack assumes that tabs are kept smartly at tab boundaries
 987     ;; instead of in a tab boundary where it might only represent 4 spaces.
 988     (while (string-match "\t" str start)
 989       (setq str (replace-match "        " t t str 0)))
 990     str))
 991
 992 (defun semantic-stickyfunc-menu (event)
 993   "Popup a menu that can help a user understand stickyfunc-mode.
 994 Argument EVENT describes the event that caused this function to be called."
 995   (interactive "e")
 996   (let* ((startwin (selected-window))
 997          (win (car (car (cdr event))))
 998          (eb (window-buffer win))
 999          )
1000     (select-window win t)
1001     (save-excursion
1002       (goto-char (window-start win))
1003       (sit-for 0)
1004       (popup-menu semantic-stickyfunc-popup-menu event)
1005       )
1006     (select-window startwin)))
1007
1008 (semantic-add-minor-mode 'semantic-stickyfunc-mode
1009                          "" ;; Don't need indicator.  It's quite visible
1010                          semantic-stickyfunc-mode-map)
1011
1012 (provide 'semantic-util-modes)
1013
1014 ;;; semantic-util-modes.el ends here