1 ;;; semantic/util-modes.el --- Semantic minor modes
3 ;; Copyright (C) 2000-2005, 2007-2013 Free Software Foundation, Inc.
5 ;; Authors: Eric M. Ludlam <zappo@gnu.org>
6 ;; David Ponce <david@dponce.com>
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
26 ;; Semantic utility minor modes.
31 ;; FIXME: compiling util-modes.el seems to require loading util-modes.el,
32 ;; so if the previous compilation generated a file that fails to load,
33 ;; recompiling fails to fix the problem.
36 ;;; Group for all semantic enhancing modes
37 (defgroup semantic-modes nil
38 "Minor modes associated with the Semantic architecture."
42 ;;;; Semantic minor modes stuff
44 (defcustom semantic-update-mode-line t
45 "If non-nil, show enabled minor modes in the mode line.
46 Only minor modes that are not turned on globally are shown in the mode
50 :require
'semantic
/util-modes
51 :initialize
'custom-initialize-default
52 :set
(lambda (sym val
)
54 ;; Update status of all Semantic enabled buffers
55 (semantic-mode-line-update)))
57 (defcustom semantic-mode-line-prefix
58 (propertize "S" 'face
'bold
)
59 "Prefix added to minor mode indicators in the mode line."
62 :require
'semantic
/util-modes
63 :initialize
'custom-initialize-default
)
65 (defvar semantic-minor-modes-format nil
66 "Mode line format showing Semantic minor modes which are locally enabled.
67 It is displayed in the mode line.")
68 (put 'semantic-minor-modes-format
'risky-local-variable t
)
70 (defvar semantic-minor-mode-alist nil
71 "Alist saying how to show Semantic minor modes in the mode line.
72 Like variable `minor-mode-alist'.")
74 (defun semantic-mode-line-update ()
75 "Update mode line format of Semantic minor modes.
76 Only minor modes that are locally enabled are shown in the mode line."
77 (setq semantic-minor-modes-format nil
)
78 (dolist (x semantic-minor-mode-alist
)
79 (setq minor-mode-alist
(delq (assq (car x
) minor-mode-alist
)
81 (when semantic-update-mode-line
83 ;; Select the minor modes that aren't enabled globally and who
84 ;; have a non-empty "name".
85 (dolist (x semantic-minor-mode-alist
)
86 (unless (or (memq (car x
) semantic-init-hook
)
87 (not (string-match "^[ ]*\\(.+\\)" (cadr x
))))
88 (push (list (car x
) (concat "/" (match-string 1 (cadr x
)))) locals
)))
89 ;; Then build the format spec.
91 (let ((prefix (if (string-match "^[ ]*\\(.+\\)"
92 semantic-mode-line-prefix
)
93 (match-string 1 semantic-mode-line-prefix
)
95 (setq semantic-minor-modes-format
96 `((:eval
(if (or ,@(mapcar 'car locals
))
97 ,(concat " " prefix
)))))
98 ;; It would be easier to just put `locals' inside
99 ;; semantic-minor-modes-format, but then things like
100 ;; mode-line-minor-mode-help can't find the right major mode
101 ;; any more. So instead, we carefully put the minor modes
102 ;; in minor-mode-alist.
103 (let* ((elem (or (assq 'semantic-minor-modes-format
105 ;; FIXME: This entry is meaningless for
106 ;; mode-line-minor-mode-help.
107 '(semantic-minor-modes-format
108 semantic-minor-modes-format
)))
109 (tail (or (memq elem minor-mode-alist
)
110 (setq minor-mode-alist
111 (cons elem minor-mode-alist
)))))
112 (setcdr tail
(nconc locals
(cdr tail
)))))))))
114 (defun semantic-desktop-ignore-this-minor-mode (buffer)
115 "Installed as a minor-mode initializer for Desktop mode.
116 BUFFER is the buffer to not initialize a Semantic minor mode in."
119 (defun semantic-add-minor-mode (toggle name
)
120 "Register a new Semantic minor mode.
121 TOGGLE is a symbol which is the name of a buffer-local variable that
122 is toggled on or off to say whether the minor mode is active or not.
123 It is also an interactive function to toggle the mode.
125 NAME specifies what will appear in the mode line when the minor mode
126 is active. NAME should be either a string starting with a space, or a
127 symbol whose value is such a string."
128 ;; Record how to display this minor mode in the mode line
129 (let ((mm (assq toggle semantic-minor-mode-alist
)))
131 (setcdr mm
(list name
))
132 (setq semantic-minor-mode-alist
(cons (list toggle name
)
133 semantic-minor-mode-alist
))))
134 (semantic-mode-line-update)
136 ;; Semantic minor modes don't work w/ Desktop restore.
137 ;; This line will disable this minor mode from being restored
139 (when (boundp 'desktop-minor-mode-handlers
)
140 (add-to-list 'desktop-minor-mode-handlers
141 (cons toggle
'semantic-desktop-ignore-this-minor-mode
))))
143 (defun semantic-toggle-minor-mode-globally (mode &optional arg
)
144 "Toggle minor mode MODE in every Semantic enabled buffer.
145 Return non-nil if MODE is turned on in every Semantic enabled buffer.
146 If ARG is positive, enable, if it is negative, disable.
147 MODE must be a valid minor mode defined in `minor-mode-alist' and must be
148 too an interactive function used to toggle the mode."
149 ;; FIXME: All callers should pass a -1 or +1 argument.
150 (or (and (fboundp mode
) (or (assq mode minor-mode-alist
) ;Needed?
151 (assq mode semantic-minor-mode-alist
)))
152 (error "Semantic minor mode %s not found" mode
))
153 ;; Add or remove the MODE toggle function from `semantic-init-hook'.
155 ;; Turn off if ARG < 0
156 ((< arg
0) (remove-hook 'semantic-init-hook mode
))
157 ;; Turn on if ARG > 0
158 ((> arg
0) (add-hook 'semantic-init-hook mode
))
159 ;; Otherwise just check MODE state
161 (error "semantic-toggle-minor-mode-globally: arg should be -1 or 1")))
162 ;; Update the minor mode format.
163 (semantic-mode-line-update)
164 ;; Then turn MODE on or off in every Semantic enabled buffer.
165 (semantic-map-buffers #'(lambda () (funcall mode arg
))))
168 ;;;; Minor mode to highlight areas that a user edits.
172 (define-minor-mode global-semantic-highlight-edits-mode
173 "Toggle global use of option `semantic-highlight-edits-mode'.
174 If ARG is positive or nil, enable, if it is negative, disable."
175 :global t
:group
'semantic
:group
'semantic-modes
176 (semantic-toggle-minor-mode-globally
177 'semantic-highlight-edits-mode
178 (if global-semantic-highlight-edits-mode
1 -
1)))
180 (defcustom semantic-highlight-edits-mode-hook nil
181 "Hook run at the end of function `semantic-highlight-edits-mode'."
185 (defface semantic-highlight-edits-face
186 '((((class color
) (background dark
))
187 ;; Put this back to something closer to black later.
188 (:background
"gray20"))
189 (((class color
) (background light
))
190 (:background
"gray90")))
191 "Face used to show dirty tokens in `semantic-highlight-edits-mode'."
192 :group
'semantic-faces
)
194 (defun semantic-highlight-edits-new-change-hook-fcn (overlay)
195 "Function set into `semantic-edits-new-change-hook'.
196 Argument OVERLAY is the overlay created to mark the change.
197 This function will set the face property on this overlay."
198 (semantic-overlay-put overlay
'face
'semantic-highlight-edits-face
))
200 (defvar semantic-highlight-edits-mode-map
201 (let ((km (make-sparse-keymap)))
203 "Keymap for highlight-edits minor mode.")
206 (define-minor-mode semantic-highlight-edits-mode
207 "Minor mode for highlighting changes made in a buffer.
208 Changes are tracked by semantic so that the incremental parser can work
210 This mode will highlight those changes as they are made, and clear them
211 when the incremental parser accounts for those edits.
212 With prefix argument ARG, turn on if positive, otherwise off. The
213 minor mode can be turned on only if semantic feature is available and
214 the current buffer was set up for parsing. Return non-nil if the
215 minor mode is enabled."
216 :keymap semantic-highlight-edits-mode-map
217 (if semantic-highlight-edits-mode
218 (if (not (and (featurep 'semantic
) (semantic-active-p)))
220 ;; Disable minor mode if semantic stuff not available
221 (setq semantic-highlight-edits-mode nil
)
222 (error "Buffer %s was not set up for parsing"
224 (semantic-make-local-hook 'semantic-edits-new-change-functions
)
225 (add-hook 'semantic-edits-new-change-functions
226 'semantic-highlight-edits-new-change-hook-fcn nil t
))
228 (remove-hook 'semantic-edits-new-change-functions
229 'semantic-highlight-edits-new-change-hook-fcn t
)))
231 (semantic-add-minor-mode 'semantic-highlight-edits-mode
235 ;;;; Minor mode to show unmatched-syntax elements
239 (define-minor-mode global-semantic-show-unmatched-syntax-mode
240 "Toggle global use of option `semantic-show-unmatched-syntax-mode'.
241 If ARG is positive or nil, enable, if it is negative, disable."
242 :global t
:group
'semantic
:group
'semantic-modes
243 ;; Not needed because it's autoloaded instead.
244 ;; :require 'semantic/util-modes
245 (semantic-toggle-minor-mode-globally
246 'semantic-show-unmatched-syntax-mode
247 (if global-semantic-show-unmatched-syntax-mode
1 -
1)))
249 (defcustom semantic-show-unmatched-syntax-mode-hook nil
250 "Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
254 (defface semantic-unmatched-syntax-face
255 '((((class color
) (background dark
))
257 (((class color
) (background light
))
259 "Face used to show unmatched syntax in.
260 The face is used in `semantic-show-unmatched-syntax-mode'."
261 :group
'semantic-faces
)
263 (defsubst semantic-unmatched-syntax-overlay-p
(overlay)
264 "Return non-nil if OVERLAY is an unmatched syntax one."
265 (eq (semantic-overlay-get overlay
'semantic
) 'unmatched
))
267 (defun semantic-showing-unmatched-syntax-p ()
268 "Return non-nil if an unmatched syntax overlay was found in buffer."
269 (let ((ol (semantic-overlays-in (point-min) (point-max)))
271 (while (and ol
(not found
))
272 (setq found
(semantic-unmatched-syntax-overlay-p (car ol
))
276 (defun semantic-show-unmatched-lex-tokens-fetch ()
277 "Fetch a list of unmatched lexical tokens from the current buffer.
278 Uses the overlays which have accurate bounds, and rebuilds what was
279 originally passed in."
280 (let ((ol (semantic-overlays-in (point-min) (point-max)))
283 (if (semantic-unmatched-syntax-overlay-p (car ol
))
284 (setq ustc
(cons (cons 'thing
285 (cons (semantic-overlay-start (car ol
))
286 (semantic-overlay-end (car ol
))))
292 (defun semantic-clean-unmatched-syntax-in-region (beg end
)
293 "Remove all unmatched syntax overlays between BEG and END."
294 (let ((ol (semantic-overlays-in beg end
)))
296 (if (semantic-unmatched-syntax-overlay-p (car ol
))
297 (semantic-overlay-delete (car ol
)))
298 (setq ol
(cdr ol
)))))
300 (defsubst semantic-clean-unmatched-syntax-in-buffer
()
301 "Remove all unmatched syntax overlays found in current buffer."
302 (semantic-clean-unmatched-syntax-in-region
303 (point-min) (point-max)))
305 (defsubst semantic-clean-token-of-unmatched-syntax
(token)
306 "Clean the area covered by TOKEN of unmatched syntax markers."
307 (semantic-clean-unmatched-syntax-in-region
308 (semantic-tag-start token
) (semantic-tag-end token
)))
310 (defun semantic-show-unmatched-syntax (syntax)
311 "Function set into `semantic-unmatched-syntax-hook'.
312 This will highlight elements in SYNTAX as unmatched syntax."
313 ;; This is called when `semantic-show-unmatched-syntax-mode' is
314 ;; enabled. Highlight the unmatched syntax, and then add a semantic
315 ;; property to that overlay so we can add it to the official list of
316 ;; semantic supported overlays. This gets it cleaned up for errors,
317 ;; buffer cleaning, and the like.
318 (semantic-clean-unmatched-syntax-in-buffer) ;Clear previous highlighting
322 (setq o
(semantic-make-overlay (semantic-lex-token-start (car syntax
))
323 (semantic-lex-token-end (car syntax
))))
324 (semantic-overlay-put o
'semantic
'unmatched
)
325 (semantic-overlay-put o
'face
'semantic-unmatched-syntax-face
)
326 (setq syntax
(cdr syntax
))))
329 (defun semantic-next-unmatched-syntax (point &optional bound
)
330 "Find the next overlay for unmatched syntax after POINT.
331 Do not search past BOUND if non-nil."
334 (let ((os point
) (ol nil
))
335 (while (and os
(< os
(or bound
(point-max))) (not ol
))
336 (setq os
(semantic-overlay-next-change os
))
338 ;; Get overlays at position
339 (setq ol
(semantic-overlays-at os
))
340 ;; find the overlay that belongs to semantic
341 ;; and starts at the found position.
342 (while (and ol
(listp ol
))
343 (and (semantic-unmatched-syntax-overlay-p (car ol
))
346 (setq ol
(cdr ol
))))))
349 (defvar semantic-show-unmatched-syntax-mode-map
350 (let ((km (make-sparse-keymap)))
351 (define-key km
"\C-c,`" 'semantic-show-unmatched-syntax-next
)
353 "Keymap for command `semantic-show-unmatched-syntax-mode'.")
356 (define-minor-mode semantic-show-unmatched-syntax-mode
357 "Minor mode to highlight unmatched lexical syntax tokens.
358 When a parser executes, some elements in the buffer may not match any
359 parser rules. These text characters are considered unmatched syntax.
360 Often time, the display of unmatched syntax can expose coding
361 problems before the compiler is run.
363 With prefix argument ARG, turn on if positive, otherwise off. The
364 minor mode can be turned on only if semantic feature is available and
365 the current buffer was set up for parsing. Return non-nil if the
366 minor mode is enabled.
368 \\{semantic-show-unmatched-syntax-mode-map}"
369 :keymap semantic-show-unmatched-syntax-mode-map
370 (if semantic-show-unmatched-syntax-mode
371 (if (not (and (featurep 'semantic
) (semantic-active-p)))
373 ;; Disable minor mode if semantic stuff not available
374 (setq semantic-show-unmatched-syntax-mode nil
)
375 (error "Buffer %s was not set up for parsing"
378 (semantic-make-local-hook 'semantic-unmatched-syntax-hook
)
379 (add-hook 'semantic-unmatched-syntax-hook
380 'semantic-show-unmatched-syntax nil t
)
381 (semantic-make-local-hook 'semantic-pre-clean-token-hooks
)
382 (add-hook 'semantic-pre-clean-token-hooks
383 'semantic-clean-token-of-unmatched-syntax nil t
)
384 ;; Show unmatched syntax elements
385 (if (not (semantic--umatched-syntax-needs-refresh-p))
386 (semantic-show-unmatched-syntax
387 (semantic-unmatched-syntax-tokens))))
389 (remove-hook 'semantic-unmatched-syntax-hook
390 'semantic-show-unmatched-syntax t
)
391 (remove-hook 'semantic-pre-clean-token-hooks
392 'semantic-clean-token-of-unmatched-syntax t
)
393 ;; Cleanup unmatched-syntax highlighting
394 (semantic-clean-unmatched-syntax-in-buffer)))
396 (semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
399 (defun semantic-show-unmatched-syntax-next ()
400 "Move forward to the next occurrence of unmatched syntax."
402 (let ((o (semantic-next-unmatched-syntax (point))))
404 (goto-char (semantic-overlay-start o
)))))
408 ;;;; Minor mode to display the parser state in the modeline.
412 (define-minor-mode global-semantic-show-parser-state-mode
413 "Toggle global use of option `semantic-show-parser-state-mode'.
414 If ARG is positive or nil, enable, if it is negative, disable."
415 :global t
:group
'semantic
416 ;; Not needed because it's autoloaded instead.
417 ;; :require 'semantic/util-modes
418 (semantic-toggle-minor-mode-globally
419 'semantic-show-parser-state-mode
420 (if global-semantic-show-parser-state-mode
1 -
1)))
422 (defcustom semantic-show-parser-state-mode-hook nil
423 "Hook run at the end of function `semantic-show-parser-state-mode'."
427 (defvar semantic-show-parser-state-mode-map
428 (let ((km (make-sparse-keymap)))
430 "Keymap for show-parser-state minor mode.")
433 (define-minor-mode semantic-show-parser-state-mode
434 "Minor mode for displaying parser cache state in the modeline.
435 The cache can be in one of three states. They are
436 Up to date, Partial reparse needed, and Full reparse needed.
437 The state is indicated in the modeline with the following characters:
438 `-' -> The cache is up to date.
439 `!' -> The cache requires a full update.
440 `~' -> The cache needs to be incrementally parsed.
441 `%' -> The cache is not currently parsable.
442 `@' -> Auto-parse in progress (not set here.)
443 With prefix argument ARG, turn on if positive, otherwise off. The
444 minor mode can be turned on only if semantic feature is available and
445 the current buffer was set up for parsing. Return non-nil if the
446 minor mode is enabled."
447 :keymap semantic-show-parser-state-mode-map
448 (if semantic-show-parser-state-mode
449 (if (not (and (featurep 'semantic
) (semantic-active-p)))
451 ;; Disable minor mode if semantic stuff not available
452 (setq semantic-show-parser-state-mode nil
)
453 (error "Buffer %s was not set up for parsing"
458 (memq 'semantic-show-parser-state-string mode-line-modified
))
459 (setq mode-line-modified
460 (append mode-line-modified
461 '(semantic-show-parser-state-string))))
463 (semantic-make-local-hook 'semantic-edits-new-change-functions
)
464 (add-hook 'semantic-edits-new-change-functions
465 'semantic-show-parser-state-marker nil t
)
466 (semantic-make-local-hook 'semantic-edits-incremental-reparse-failed-hook
)
467 (add-hook 'semantic-edits-incremental-reparse-failed-hook
468 'semantic-show-parser-state-marker nil t
)
469 (semantic-make-local-hook 'semantic-after-partial-cache-change-hook
)
470 (add-hook 'semantic-after-partial-cache-change-hook
471 'semantic-show-parser-state-marker nil t
)
472 (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook
)
473 (add-hook 'semantic-after-toplevel-cache-change-hook
474 'semantic-show-parser-state-marker nil t
)
475 (semantic-show-parser-state-marker)
477 (semantic-make-local-hook 'semantic-before-auto-parse-hooks
)
478 (add-hook 'semantic-before-auto-parse-hooks
479 'semantic-show-parser-state-auto-marker nil t
)
480 (semantic-make-local-hook 'semantic-after-auto-parse-hooks
)
481 (add-hook 'semantic-after-auto-parse-hooks
482 'semantic-show-parser-state-marker nil t
)
484 (semantic-make-local-hook 'semantic-before-idle-scheduler-reparse-hook
)
485 (add-hook 'semantic-before-idle-scheduler-reparse-hook
486 'semantic-show-parser-state-auto-marker nil t
)
487 (semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hook
)
488 (add-hook 'semantic-after-idle-scheduler-reparse-hook
489 'semantic-show-parser-state-marker nil t
))
490 ;; Remove parts of mode line
491 (setq mode-line-modified
492 (delq 'semantic-show-parser-state-string mode-line-modified
))
494 (remove-hook 'semantic-edits-new-change-functions
495 'semantic-show-parser-state-marker t
)
496 (remove-hook 'semantic-edits-incremental-reparse-failed-hook
497 'semantic-show-parser-state-marker t
)
498 (remove-hook 'semantic-after-partial-cache-change-hook
499 'semantic-show-parser-state-marker t
)
500 (remove-hook 'semantic-after-toplevel-cache-change-hook
501 'semantic-show-parser-state-marker t
)
503 (remove-hook 'semantic-before-auto-parse-hooks
504 'semantic-show-parser-state-auto-marker t
)
505 (remove-hook 'semantic-after-auto-parse-hooks
506 'semantic-show-parser-state-marker t
)
508 (remove-hook 'semantic-before-idle-scheduler-reparse-hook
509 'semantic-show-parser-state-auto-marker t
)
510 (remove-hook 'semantic-after-idle-scheduler-reparse-hook
511 'semantic-show-parser-state-marker t
)))
513 (semantic-add-minor-mode 'semantic-show-parser-state-mode
516 (defvar semantic-show-parser-state-string nil
517 "String showing the parser state for this buffer.
518 See `semantic-show-parser-state-marker' for details.")
519 (make-variable-buffer-local 'semantic-show-parser-state-string
)
521 (defun semantic-show-parser-state-marker (&rest ignore
)
522 "Set `semantic-show-parser-state-string' to indicate parser state.
523 This marker is one of the following:
524 `-' -> The cache is up to date.
525 `!' -> The cache requires a full update.
526 `~' -> The cache needs to be incrementally parsed.
527 `%' -> The cache is not currently parsable.
528 `@' -> Auto-parse in progress (not set here.)
529 Arguments IGNORE are ignored, and accepted so this can be used as a hook
531 (setq semantic-show-parser-state-string
532 (cond ((semantic-parse-tree-needs-rebuild-p)
534 ((semantic-parse-tree-needs-update-p)
536 ((semantic-parse-tree-unparseable-p)
540 ;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string)
543 (defun semantic-show-parser-state-auto-marker ()
544 "Hook function run before an autoparse.
545 Set up `semantic-show-parser-state-marker' to show `@'
546 to indicate a parse in progress."
547 (unless (semantic-parse-tree-up-to-date-p)
548 (setq semantic-show-parser-state-string
"@")
555 ;;;; Minor mode to make function decls sticky.
559 (define-minor-mode global-semantic-stickyfunc-mode
560 "Toggle global use of option `semantic-stickyfunc-mode'.
561 If ARG is positive or nil, enable, if it is negative, disable."
562 :global t
:group
'semantic
:group
'semantic-modes
563 ;; Not needed because it's autoloaded instead.
564 ;; :require 'semantic/util-modes
565 (semantic-toggle-minor-mode-globally
566 'semantic-stickyfunc-mode
(if global-semantic-stickyfunc-mode
1 -
1)))
568 (defcustom semantic-stickyfunc-mode-hook nil
569 "Hook run at the end of function `semantic-stickyfunc-mode'."
573 (defvar semantic-stickyfunc-mode-map
574 (let ((km (make-sparse-keymap)))
575 (define-key km
[ header-line down-mouse-1
] 'semantic-stickyfunc-menu
)
577 "Keymap for stickyfunc minor mode.")
579 (defvar semantic-stickyfunc-popup-menu nil
580 "Menu used if the user clicks on the header line used by stickyfunc mode.")
583 semantic-stickyfunc-popup-menu
584 semantic-stickyfunc-mode-map
586 '("Stickyfunc Mode" :visible
(progn nil
)
587 [ "Copy Headerline Tag" senator-copy-tag
588 :active
(semantic-current-tag)
589 :help
"Copy the current tag to the tag ring"]
590 [ "Kill Headerline Tag" senator-kill-tag
591 :active
(semantic-current-tag)
592 :help
"Kill tag text to the kill ring, and copy the tag to the tag ring"
594 [ "Copy Headerline Tag to Register" senator-copy-tag-to-register
595 :active
(semantic-current-tag)
596 :help
"Copy the current tag to a register"
598 [ "Narrow To Headerline Tag" senator-narrow-to-defun
599 :active
(semantic-current-tag)
600 :help
"Narrow to the bounds of the current tag"]
601 [ "Fold Headerline Tag" senator-fold-tag-toggle
602 :active
(semantic-current-tag)
604 :selected
(let ((tag (semantic-current-tag)))
605 (and tag
(semantic-tag-folded-p tag
)))
606 :help
"Fold the current tag to one line"
609 [ "About This Header Line"
610 (lambda () (interactive)
611 (describe-function 'semantic-stickyfunc-mode
)) t
])
614 (defcustom semantic-stickyfunc-indent-string
615 (if (and window-system
(not (featurep 'xemacs
)))
618 ;; Test scroll bar location
619 (let ((charwidth (frame-char-width))
620 (scrollpos (frame-parameter (selected-frame)
621 'vertical-scroll-bars
))
623 (if (or (eq scrollpos
'left
)
624 ;; Now wait a minute. If you turn scroll-bar-mode
625 ;; on, then off, the new value is t, not left.
626 ;; Will this mess up older emacs where the default
627 ;; was on the right? I don't think so since they don't
628 ;; support a header line.
630 (let ((w (when (boundp 'scroll-bar-width
)
631 (symbol-value 'scroll-bar-width
))))
634 (setq w
(frame-parameter (selected-frame)
637 ;; in 21.2, the frame parameter is sometimes empty
638 ;; so we need to get the value here.
640 (setq w
(+ (get 'scroll-bar-width
'x-frame-parameter
)
641 ;; In 21.4, or perhaps 22.1 the x-frame
642 ;; parameter is different from the frame
643 ;; parameter by only 1 pixel.
648 (setq w
(+ 2 w
)) ; Some sort of border around
650 (make-string (/ w charwidth
) ?
)))
655 (let* ((f (window-fringes))
657 (numspace (/ fw
(frame-char-width)))
659 (make-string numspace ?
))
661 ;; Well, the fancy new Emacs functions failed. Try older
664 ;; I'm not so sure what's up with the 21.1-21.3 fringe.
665 ;; It looks to be about 1 space wide.
666 (if (get 'fringe
'face
)
671 ;; Not Emacs or a window system means no scrollbar or fringe,
672 ;; and perhaps not even a header line to worry about.
674 "String used to indent the stickyfunc header.
675 Customize this string to match the space used by scrollbars and
676 fringe so it does not appear that the code is moving left/right
677 when it lands in the sticky line."
681 (defvar semantic-stickyfunc-old-hlf nil
682 "Value of the header line when entering stickyfunc mode.")
684 (defconst semantic-stickyfunc-header-line-format
685 (cond ((featurep 'xemacs
)
687 ((>= emacs-major-version
22)
689 ;; Magic bit I found on emacswiki.
690 (propertize " " 'display
'((space :align-to
0)))
691 (semantic-stickyfunc-fetch-stickyline))))
692 ((= emacs-major-version
21)
693 '(:eval
(list semantic-stickyfunc-indent-string
694 (semantic-stickyfunc-fetch-stickyline))))
696 "The header line format used by stickyfunc mode.")
699 (define-minor-mode semantic-stickyfunc-mode
700 "Minor mode to show the title of a tag in the header line.
701 Enables/disables making the header line of functions sticky.
702 A function (or other tag class specified by
703 `semantic-stickyfunc-sticky-classes') has a header line, meaning the
704 first line which describes the rest of the construct. This first
705 line is what is displayed in the header line.
707 With prefix argument ARG, turn on if positive, otherwise off. The
708 minor mode can be turned on only if semantic feature is available and
709 the current buffer was set up for parsing. Return non-nil if the
710 minor mode is enabled."
711 ;; Don't need indicator. It's quite visible
712 :keymap semantic-stickyfunc-mode-map
713 (if semantic-stickyfunc-mode
715 (unless (and (featurep 'semantic
) (semantic-active-p))
716 ;; Disable minor mode if semantic stuff not available
717 (setq semantic-stickyfunc-mode nil
)
718 (error "Buffer %s was not set up for parsing" (buffer-name)))
719 (unless (boundp 'default-header-line-format
)
720 ;; Disable if there are no header lines to use.
721 (setq semantic-stickyfunc-mode nil
)
722 (error "Sticky Function mode requires Emacs 21"))
724 ;; Save previous buffer local value of header line format.
725 (when (and (local-variable-p 'header-line-format
(current-buffer))
726 (not (eq header-line-format
727 semantic-stickyfunc-header-line-format
)))
728 (set (make-local-variable 'semantic-stickyfunc-old-hlf
)
730 (setq header-line-format semantic-stickyfunc-header-line-format
))
731 ;; Disable sticky func mode
732 ;; Restore previous buffer local value of header line format if
733 ;; the current one is the sticky func one.
734 (when (eq header-line-format semantic-stickyfunc-header-line-format
)
735 (kill-local-variable 'header-line-format
)
736 (when (local-variable-p 'semantic-stickyfunc-old-hlf
(current-buffer))
737 (setq header-line-format semantic-stickyfunc-old-hlf
)
738 (kill-local-variable 'semantic-stickyfunc-old-hlf
)))))
740 (defvar semantic-stickyfunc-sticky-classes
742 "List of tag classes which stickyfunc will display in the header line.")
743 (make-variable-buffer-local 'semantic-stickyfunc-sticky-classes
)
745 (defcustom semantic-stickyfunc-show-only-functions-p nil
746 "Non-nil means don't show lines that aren't part of a tag.
747 If this is nil, then comments or other text between tags that is
748 1 line above the top of the current window will be shown."
752 (defun semantic-stickyfunc-tag-to-stick ()
753 "Return the tag to stick at the current point."
754 (let ((tags (nreverse (semantic-find-tag-by-overlay (point)))))
755 ;; Get rid of non-matching tags.
758 (semantic-tag-class (car tags
))
759 semantic-stickyfunc-sticky-classes
))
761 (setq tags
(cdr tags
)))
764 (defun semantic-stickyfunc-fetch-stickyline ()
765 "Make the function at the top of the current window sticky.
766 Capture its function declaration, and place it in the header line.
767 If there is no function, disable the header line."
769 (goto-char (window-start (selected-window)))
770 (let* ((noshow (bobp))
775 ;; Capture this function
776 (let* ((tag (semantic-stickyfunc-tag-to-stick)))
777 ;; TAG is nil if there was nothing of the appropriate type there.
779 ;; Set it to be the text under the header line
782 (if semantic-stickyfunc-show-only-functions-p
""
783 (buffer-substring (point-at-bol) (point-at-eol))
785 ;; Go get the first line of this tag.
786 (goto-char (semantic-tag-start tag
))
787 ;; Klaus Berndl <klaus.berndl@sdm.de>:
788 ;; goto the tag name; this is especially needed for languages
789 ;; like c++ where a often used style is like:
791 ;; ClassX::methodM(arg1...)
795 ;; Without going to the tag-name we would get"void" in the
796 ;; header line which is IMHO not really useful
797 (search-forward (semantic-tag-name tag
) nil t
)
798 (buffer-substring (point-at-bol) (point-at-eol))
801 (while (string-match "%" str start
)
802 (setq str
(replace-match "%%" t t str
0)
803 start
(1+ (match-end 0)))
805 ;; In 21.4 (or 22.1) the header doesn't expand tabs. Hmmmm.
806 ;; We should replace them here.
808 ;; This hack assumes that tabs are kept smartly at tab boundaries
809 ;; instead of in a tab boundary where it might only represent 4 spaces.
810 (while (string-match "\t" str start
)
811 (setq str
(replace-match " " t t str
0)))
814 (defun semantic-stickyfunc-menu (event)
815 "Popup a menu that can help a user understand stickyfunc-mode.
816 Argument EVENT describes the event that caused this function to be called."
818 (let* ((startwin (selected-window))
819 (win (car (car (cdr event
))))
821 (select-window win t
)
823 (goto-char (window-start win
))
825 (popup-menu semantic-stickyfunc-popup-menu event
)
827 (select-window startwin
)))
830 (semantic-add-minor-mode 'semantic-stickyfunc-mode
831 "") ;; Don't need indicator. It's quite visible
836 ;;;; Minor mode to make highlight the current function
839 ;; Highlight the first like of the function we are in if it is different
840 ;; from the tag going off the top of the screen.
843 (define-minor-mode global-semantic-highlight-func-mode
844 "Toggle global use of option `semantic-highlight-func-mode'.
845 If ARG is positive or nil, enable, if it is negative, disable."
846 :global t
:group
'semantic
:group
'semantic-modes
847 ;; Not needed because it's autoloaded instead.
848 ;; :require 'semantic/util-modes
849 (semantic-toggle-minor-mode-globally
850 'semantic-highlight-func-mode
851 (if global-semantic-highlight-func-mode
1 -
1)))
853 (defcustom semantic-highlight-func-mode-hook nil
854 "Hook run at the end of function `semantic-highlight-func-mode'."
858 (defvar semantic-highlight-func-mode-map
859 (let ((km (make-sparse-keymap))
860 (m3 (if (featurep 'xemacs
) [ button3
] [ mouse-3
]))
862 (define-key km m3
'semantic-highlight-func-menu
)
864 "Keymap for highlight-func minor mode.")
866 (defvar semantic-highlight-func-popup-menu nil
867 "Menu used if the user clicks on the header line used by `semantic-highlight-func-mode'.")
870 semantic-highlight-func-popup-menu
871 semantic-highlight-func-mode-map
872 "Highlight-Func Menu"
873 '("Highlight-Func Mode" :visible
(progn nil
)
874 [ "Copy Tag" senator-copy-tag
875 :active
(semantic-current-tag)
876 :help
"Copy the current tag to the tag ring"]
877 [ "Kill Tag" senator-kill-tag
878 :active
(semantic-current-tag)
879 :help
"Kill tag text to the kill ring, and copy the tag to the tag ring"
881 [ "Copy Tag to Register" senator-copy-tag-to-register
882 :active
(semantic-current-tag)
883 :help
"Copy the current tag to a register"
885 [ "Narrow To Tag" senator-narrow-to-defun
886 :active
(semantic-current-tag)
887 :help
"Narrow to the bounds of the current tag"]
888 [ "Fold Tag" senator-fold-tag-toggle
889 :active
(semantic-current-tag)
891 :selected
(let ((tag (semantic-stickyfunc-tag-to-stick)))
892 (and tag
(semantic-tag-folded-p tag
)))
893 :help
"Fold the current tag to one line"
896 [ "About This Tag" semantic-describe-tag t
])
899 (defun semantic-highlight-func-menu (event)
900 "Popup a menu that displays things to do to the current tag.
901 Argument EVENT describes the event that caused this function to be called."
903 (let* ((startwin (selected-window))
904 (win (semantic-event-window event
))
906 (select-window win t
)
908 ;(goto-char (window-start win))
909 (mouse-set-point event
)
911 (semantic-popup-menu semantic-highlight-func-popup-menu
)
913 (select-window startwin
)))
915 (defvar semantic-highlight-func-ct-overlay nil
916 "Overlay used to highlight the tag the cursor is in.")
917 (make-variable-buffer-local 'semantic-highlight-func-ct-overlay
)
919 (defface semantic-highlight-func-current-tag-face
920 '((((class color
) (background dark
))
921 ;; Put this back to something closer to black later.
922 (:background
"gray20"))
923 (((class color
) (background light
))
924 (:background
"gray90")))
925 "Face used to show the top of current function."
926 :group
'semantic-faces
)
929 (define-minor-mode semantic-highlight-func-mode
930 "Minor mode to highlight the first line of the current tag.
931 Enables/disables making the current function's first line light up.
932 A function (or other tag class specified by
933 `semantic-stickyfunc-sticky-classes') is highlighted, meaning the
934 first line which describes the rest of the construct.
936 See `semantic-stickyfunc-mode' for putting a function in the
937 header line. This mode recycles the stickyfunc configuration
940 With prefix argument ARG, turn on if positive, otherwise off. The
941 minor mode can be turned on only if semantic feature is available and
942 the current buffer was set up for parsing. Return non-nil if the
943 minor mode is enabled."
944 :lighter nil
;; Don't need indicator. It's quite visible.
945 (if semantic-highlight-func-mode
947 (unless (and (featurep 'semantic
) (semantic-active-p))
948 ;; Disable minor mode if semantic stuff not available
949 (setq semantic-highlight-func-mode nil
)
950 (error "Buffer %s was not set up for parsing" (buffer-name)))
952 (add-hook 'post-command-hook
953 'semantic-highlight-func-highlight-current-tag nil t
))
954 ;; Disable highlight func mode
955 (remove-hook 'post-command-hook
956 'semantic-highlight-func-highlight-current-tag t
)
957 (semantic-highlight-func-highlight-current-tag t
)))
959 (defun semantic-highlight-func-highlight-current-tag (&optional disable
)
960 "Highlight the current tag under point.
961 Optional argument DISABLE will turn off any active highlight.
962 If the current tag for this buffer is different from the last time this
963 function was called, move the overlay."
964 (when (and (not (minibufferp))
965 (or (not semantic-highlight-func-ct-overlay
)
966 (eq (semantic-overlay-buffer
967 semantic-highlight-func-ct-overlay
)
969 (let* ((tag (semantic-stickyfunc-tag-to-stick))
970 (ol semantic-highlight-func-ct-overlay
))
972 ;; No overlay in this buffer. Make one.
973 (setq ol
(semantic-make-overlay (point-min) (point-min)
974 (current-buffer) t nil
))
975 (semantic-overlay-put ol
'highlight-func t
)
976 (semantic-overlay-put ol
'face
'semantic-highlight-func-current-tag-face
)
977 (semantic-overlay-put ol
'keymap semantic-highlight-func-mode-map
)
978 (semantic-overlay-put ol
'help-echo
979 "Current Function : mouse-3 - Context menu")
980 (setq semantic-highlight-func-ct-overlay ol
)
983 ;; TAG is nil if there was nothing of the appropriate type there.
984 (if (or (not tag
) disable
)
985 ;; No tag, make the overlay go away.
987 (semantic-overlay-put ol
'tag nil
)
988 (semantic-overlay-move ol
(point-min) (point-min) (current-buffer))
991 ;; We have a tag, if it is the same, do nothing.
992 (unless (eq (semantic-overlay-get ol
'tag
) tag
)
994 (goto-char (semantic-tag-start tag
))
995 (search-forward (semantic-tag-name tag
) nil t
)
996 (semantic-overlay-put ol
'tag tag
)
997 (semantic-overlay-move ol
(point-at-bol) (point-at-eol))
1003 (semantic-add-minor-mode 'semantic-highlight-func-mode
1004 "") ;; Don't need indicator. It's quite visible
1006 (provide 'semantic
/util-modes
)
1009 ;; generated-autoload-file: "loaddefs.el"
1010 ;; generated-autoload-load-name: "semantic/util-modes"
1013 ;;; semantic/util-modes.el ends here