Commit | Line | Data |
---|---|---|
8bf997ef CY |
1 | ;;; semantic/senator.el --- SEmantic NAvigaTOR |
2 | ||
3 | ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, | |
5df4f04c | 4 | ;; 2009, 2010, 2011 Free Software Foundation, Inc. |
8bf997ef CY |
5 | |
6 | ;; Author: David Ponce <david@dponce.com> | |
7 | ;; Maintainer: FSF | |
8 | ;; Created: 10 Nov 2000 | |
9 | ;; Keywords: syntax | |
10 | ||
11 | ;; This file is part of GNU Emacs. | |
12 | ||
13 | ;; GNU Emacs 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 3 of the License, or | |
16 | ;; (at your option) any later version. | |
17 | ||
18 | ;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. | |
25 | ||
26 | ;;; Commentary: | |
27 | ;; | |
28 | ;; This file defines some user commands for navigating between | |
29 | ;; Semantic tags. This is a subset of the version of senator.el in | |
30 | ;; the upstream CEDET package; the rest is incorporated into other | |
31 | ;; parts of Semantic or Emacs. | |
32 | ||
33 | ;;; Code: | |
34 | ||
35 | (require 'ring) | |
36 | (require 'semantic) | |
37 | (require 'semantic/ctxt) | |
38 | (require 'semantic/decorate) | |
39 | (require 'semantic/format) | |
40 | ||
41 | (eval-when-compile (require 'semantic/find)) | |
42 | ||
43 | ;; (eval-when-compile (require 'hippie-exp)) | |
44 | ||
8bf997ef CY |
45 | (declare-function semantic-analyze-tag-references "semantic/analyze/refs") |
46 | (declare-function semantic-analyze-refs-impl "semantic/analyze/refs") | |
47 | (declare-function semantic-analyze-find-tag "semantic/analyze") | |
48 | (declare-function semantic-analyze-tag-type "semantic/analyze/fcn") | |
49 | (declare-function semantic-tag-external-class "semantic/sort") | |
50 | (declare-function imenu--mouse-menu "imenu") | |
51 | ||
52 | ;;; Customization | |
53 | (defgroup senator nil | |
54 | "Semantic Navigator." | |
55 | :group 'semantic) | |
56 | ||
57 | ;;;###autoload | |
58 | (defcustom senator-step-at-tag-classes nil | |
59 | "List of tag classes recognized by Senator's navigation commands. | |
60 | A tag class is a symbol, such as `variable', `function', or `type'. | |
61 | ||
62 | As a special exception, if the value is nil, Senator's navigation | |
63 | commands recognize all tag classes." | |
64 | :group 'senator | |
65 | :type '(repeat (symbol))) | |
66 | ;;;###autoload | |
67 | (make-variable-buffer-local 'senator-step-at-tag-classes) | |
68 | ||
69 | ;;;###autoload | |
70 | (defcustom senator-step-at-start-end-tag-classes nil | |
71 | "List of tag classes at which Senator's navigation commands should stop. | |
72 | A tag class is a symbol, such as `variable', `function', or `type'. | |
73 | The navigation commands stop at the start and end of each tag | |
74 | class in this list, provided the tag class is recognized (see | |
75 | `senator-step-at-tag-classes'). | |
76 | ||
77 | As a special exception, if the value is nil, the navigation | |
78 | commands stop at the beginning of every tag. | |
79 | ||
80 | If t, the navigation commands stop at the start and end of any | |
81 | tag, where possible." | |
82 | :group 'senator | |
83 | :type '(choice :tag "Identifiers" | |
84 | (repeat :menu-tag "Symbols" (symbol)) | |
85 | (const :tag "All" t))) | |
86 | ;;;###autoload | |
87 | (make-variable-buffer-local 'senator-step-at-start-end-tag-classes) | |
88 | ||
89 | (defcustom senator-highlight-found nil | |
90 | "If non-nil, Senator commands momentarily highlight found tags." | |
91 | :group 'senator | |
92 | :type 'boolean) | |
93 | (make-variable-buffer-local 'senator-highlight-found) | |
94 | ||
95 | ;;; Faces | |
96 | (defface senator-momentary-highlight-face | |
97 | '((((class color) (background dark)) | |
98 | (:background "gray30")) | |
99 | (((class color) (background light)) | |
100 | (:background "gray70"))) | |
101 | "Face used to momentarily highlight tags." | |
102 | :group 'semantic-faces) | |
103 | ||
104 | ;;; Common functions | |
105 | ||
106 | (defun senator-momentary-highlight-tag (tag) | |
107 | "Momentarily highlight TAG. | |
108 | Does nothing if `senator-highlight-found' is nil." | |
109 | (and senator-highlight-found | |
110 | (semantic-momentary-highlight-tag | |
111 | tag 'senator-momentary-highlight-face))) | |
112 | ||
113 | (defun senator-step-at-start-end-p (tag) | |
114 | "Return non-nil if must step at start and end of TAG." | |
115 | (and tag | |
116 | (or (eq senator-step-at-start-end-tag-classes t) | |
117 | (memq (semantic-tag-class tag) | |
118 | senator-step-at-start-end-tag-classes)))) | |
119 | ||
120 | (defun senator-skip-p (tag) | |
121 | "Return non-nil if must skip TAG." | |
122 | (and tag | |
123 | senator-step-at-tag-classes | |
124 | (not (memq (semantic-tag-class tag) | |
125 | senator-step-at-tag-classes)))) | |
126 | ||
127 | (defun senator-middle-of-tag-p (pos tag) | |
128 | "Return non-nil if POS is between start and end of TAG." | |
129 | (and (> pos (semantic-tag-start tag)) | |
130 | (< pos (semantic-tag-end tag)))) | |
131 | ||
132 | (defun senator-step-at-parent (tag) | |
133 | "Return TAG's outermost parent if must step at start/end of it. | |
134 | Return nil otherwise." | |
135 | (if tag | |
136 | (let (parent parents) | |
137 | (setq parents (semantic-find-tag-by-overlay | |
138 | (semantic-tag-start tag))) | |
139 | (while (and parents (not parent)) | |
140 | (setq parent (car parents) | |
141 | parents (cdr parents)) | |
142 | (if (or (eq tag parent) | |
143 | (senator-skip-p parent) | |
144 | (not (senator-step-at-start-end-p parent))) | |
145 | (setq parent nil))) | |
146 | parent))) | |
147 | ||
148 | (defun senator-previous-tag-or-parent (pos) | |
149 | "Return the tag before POS or one of its parent where to step." | |
150 | (let (ol tag) | |
151 | (while (and pos (> pos (point-min)) (not tag)) | |
152 | (setq pos (semantic-overlay-previous-change pos)) | |
153 | (when pos | |
154 | ;; Get overlays at position | |
155 | (setq ol (semantic-overlays-at pos)) | |
156 | ;; find the overlay that belongs to semantic | |
157 | ;; and STARTS or ENDS at the found position. | |
158 | (while (and ol (not tag)) | |
159 | (setq tag (semantic-overlay-get (car ol) 'semantic)) | |
160 | (unless (and tag (semantic-tag-p tag) | |
161 | (or (= (semantic-tag-start tag) pos) | |
162 | (= (semantic-tag-end tag) pos))) | |
163 | (setq tag nil | |
164 | ol (cdr ol)))))) | |
165 | (or (senator-step-at-parent tag) tag))) | |
166 | ||
167 | ;;; Search functions | |
168 | ||
169 | (defun senator-search-tag-name (tag) | |
170 | "Search for TAG name in current buffer. | |
171 | Limit the search to TAG bounds. | |
172 | If found, set point to the end of the name, and return point. The | |
173 | beginning of the name is at (match-beginning 0). | |
174 | Return nil if not found, that is if TAG name doesn't come from the | |
175 | source." | |
176 | (let ((name (semantic-tag-name tag))) | |
177 | (setq name (if (string-match "\\`\\([^[]+\\)[[]" name) | |
178 | (match-string 1 name) | |
179 | name)) | |
180 | (goto-char (semantic-tag-start tag)) | |
181 | (when (re-search-forward (concat | |
182 | ;; The tag name is expected to be | |
183 | ;; between word delimiters, whitespaces, | |
184 | ;; or punctuations. | |
185 | "\\(\\<\\|\\s-+\\|\\s.\\)" | |
186 | (regexp-quote name) | |
187 | "\\(\\>\\|\\s-+\\|\\s.\\)") | |
188 | (semantic-tag-end tag) | |
189 | t) | |
190 | (goto-char (match-beginning 0)) | |
191 | (search-forward name)))) | |
192 | ||
193 | (defcustom senator-search-ignore-tag-classes | |
194 | '(code block) | |
195 | "List of ignored tag classes. | |
196 | Tags of those classes are excluded from search." | |
197 | :group 'senator | |
198 | :type '(repeat (symbol :tag "class"))) | |
199 | ||
200 | (defun senator-search-default-tag-filter (tag) | |
201 | "Default function that filters searched tags. | |
202 | Ignore tags of classes in `senator-search-ignore-tag-classes'" | |
203 | (not (memq (semantic-tag-class tag) | |
204 | senator-search-ignore-tag-classes))) | |
205 | ||
206 | (defvar senator-search-tag-filter-functions | |
207 | '(senator-search-default-tag-filter) | |
208 | "List of functions to be called to filter searched tags. | |
9bf6c65c | 209 | Each function is passed a tag. If one of them returns nil, the tag is |
8bf997ef CY |
210 | excluded from the search.") |
211 | ||
212 | (defun senator-search (searcher text &optional bound noerror count) | |
213 | "Use the SEARCHER function to search from point for TEXT in a tag name. | |
214 | SEARCHER is typically the function `search-forward', `search-backward', | |
215 | `word-search-forward', `word-search-backward', `re-search-forward', or | |
216 | `re-search-backward'. See one of the above function to see how the | |
217 | TEXT, BOUND, NOERROR, and COUNT arguments are interpreted." | |
218 | (let* ((origin (point)) | |
219 | (count (or count 1)) | |
220 | (step (cond ((> count 0) 1) | |
221 | ((< count 0) (setq count (- count)) -1) | |
222 | (0))) | |
223 | found next sstart send tag tstart tend) | |
224 | (or (zerop step) | |
225 | (while (and (not found) | |
226 | (setq next (funcall searcher text bound t step))) | |
227 | (setq sstart (match-beginning 0) | |
228 | send (match-end 0)) | |
229 | (if (= sstart send) | |
230 | (setq found t) | |
231 | (and (setq tag (semantic-current-tag)) | |
232 | (run-hook-with-args-until-failure | |
233 | 'senator-search-tag-filter-functions tag) | |
234 | (setq tend (senator-search-tag-name tag)) | |
235 | (setq tstart (match-beginning 0) | |
236 | found (and (>= sstart tstart) | |
237 | (<= send tend) | |
238 | (zerop (setq count (1- count)))))) | |
239 | (goto-char next)))) | |
240 | (cond ((null found) | |
241 | (setq next origin | |
242 | send origin)) | |
243 | ((= next sstart) | |
244 | (setq next send | |
245 | send sstart)) | |
246 | (t | |
247 | (setq next sstart))) | |
248 | (goto-char next) | |
249 | ;; Setup the returned value and the `match-data' or maybe fail! | |
250 | (funcall searcher text send noerror step))) | |
251 | ||
252 | ;;; Navigation commands | |
253 | ||
254 | ;;;###autoload | |
255 | (defun senator-next-tag () | |
256 | "Navigate to the next Semantic tag. | |
257 | Return the tag or nil if at end of buffer." | |
258 | (interactive) | |
259 | (let ((pos (point)) | |
260 | (tag (semantic-current-tag)) | |
261 | where) | |
262 | (if (and tag | |
263 | (not (senator-skip-p tag)) | |
264 | (senator-step-at-start-end-p tag) | |
265 | (or (= pos (semantic-tag-start tag)) | |
266 | (senator-middle-of-tag-p pos tag))) | |
267 | nil | |
268 | (if (setq tag (senator-step-at-parent tag)) | |
269 | nil | |
270 | (setq tag (semantic-find-tag-by-overlay-next pos)) | |
271 | (while (and tag (senator-skip-p tag)) | |
272 | (setq tag (semantic-find-tag-by-overlay-next | |
273 | (semantic-tag-start tag)))))) | |
274 | (if (not tag) | |
275 | (progn | |
276 | (goto-char (point-max)) | |
277 | (message "End of buffer")) | |
278 | (cond ((and (senator-step-at-start-end-p tag) | |
279 | (or (= pos (semantic-tag-start tag)) | |
280 | (senator-middle-of-tag-p pos tag))) | |
281 | (setq where "end") | |
282 | (goto-char (semantic-tag-end tag))) | |
283 | (t | |
284 | (setq where "start") | |
285 | (goto-char (semantic-tag-start tag)))) | |
286 | (senator-momentary-highlight-tag tag) | |
287 | (message "%S: %s (%s)" | |
288 | (semantic-tag-class tag) | |
289 | (semantic-tag-name tag) | |
290 | where)) | |
291 | tag)) | |
292 | ||
293 | ;;;###autoload | |
294 | (defun senator-previous-tag () | |
295 | "Navigate to the previous Semantic tag. | |
296 | Return the tag or nil if at beginning of buffer." | |
297 | (interactive) | |
298 | (let ((pos (point)) | |
299 | (tag (semantic-current-tag)) | |
300 | where) | |
301 | (if (and tag | |
302 | (not (senator-skip-p tag)) | |
303 | (senator-step-at-start-end-p tag) | |
304 | (or (= pos (semantic-tag-end tag)) | |
305 | (senator-middle-of-tag-p pos tag))) | |
306 | nil | |
307 | (if (setq tag (senator-step-at-parent tag)) | |
308 | nil | |
309 | (setq tag (senator-previous-tag-or-parent pos)) | |
310 | (while (and tag (senator-skip-p tag)) | |
311 | (setq tag (senator-previous-tag-or-parent | |
312 | (semantic-tag-start tag)))))) | |
313 | (if (not tag) | |
314 | (progn | |
315 | (goto-char (point-min)) | |
316 | (message "Beginning of buffer")) | |
317 | (cond ((or (not (senator-step-at-start-end-p tag)) | |
318 | (= pos (semantic-tag-end tag)) | |
319 | (senator-middle-of-tag-p pos tag)) | |
320 | (setq where "start") | |
321 | (goto-char (semantic-tag-start tag))) | |
322 | (t | |
323 | (setq where "end") | |
324 | (goto-char (semantic-tag-end tag)))) | |
325 | (senator-momentary-highlight-tag tag) | |
326 | (message "%S: %s (%s)" | |
327 | (semantic-tag-class tag) | |
328 | (semantic-tag-name tag) | |
329 | where)) | |
330 | tag)) | |
331 | ||
332 | ;;; Search commands | |
333 | ||
334 | (defun senator-search-forward (string &optional bound noerror count) | |
335 | "Search in tag names forward from point for STRING. | |
336 | Set point to the end of the occurrence found, and return point. | |
337 | See also the function `search-forward' for details on the BOUND, | |
338 | NOERROR and COUNT arguments." | |
339 | (interactive "sSemantic search: ") | |
340 | (senator-search 'search-forward string bound noerror count)) | |
341 | ||
342 | (defun senator-re-search-forward (regexp &optional bound noerror count) | |
343 | "Search in tag names forward from point for regular expression REGEXP. | |
344 | Set point to the end of the occurrence found, and return point. | |
345 | See also the function `re-search-forward' for details on the BOUND, | |
346 | NOERROR and COUNT arguments." | |
347 | (interactive "sSemantic regexp search: ") | |
348 | (senator-search 're-search-forward regexp bound noerror count)) | |
349 | ||
350 | (defun senator-word-search-forward (word &optional bound noerror count) | |
351 | "Search in tag names forward from point for WORD. | |
352 | Set point to the end of the occurrence found, and return point. | |
353 | See also the function `word-search-forward' for details on the BOUND, | |
354 | NOERROR and COUNT arguments." | |
355 | (interactive "sSemantic word search: ") | |
356 | (senator-search 'word-search-forward word bound noerror count)) | |
357 | ||
358 | (defun senator-search-backward (string &optional bound noerror count) | |
359 | "Search in tag names backward from point for STRING. | |
360 | Set point to the beginning of the occurrence found, and return point. | |
361 | See also the function `search-backward' for details on the BOUND, | |
362 | NOERROR and COUNT arguments." | |
363 | (interactive "sSemantic backward search: ") | |
364 | (senator-search 'search-backward string bound noerror count)) | |
365 | ||
366 | (defun senator-re-search-backward (regexp &optional bound noerror count) | |
367 | "Search in tag names backward from point for regular expression REGEXP. | |
368 | Set point to the beginning of the occurrence found, and return point. | |
369 | See also the function `re-search-backward' for details on the BOUND, | |
370 | NOERROR and COUNT arguments." | |
371 | (interactive "sSemantic backward regexp search: ") | |
372 | (senator-search 're-search-backward regexp bound noerror count)) | |
373 | ||
374 | (defun senator-word-search-backward (word &optional bound noerror count) | |
375 | "Search in tag names backward from point for WORD. | |
376 | Set point to the beginning of the occurrence found, and return point. | |
377 | See also the function `word-search-backward' for details on the BOUND, | |
378 | NOERROR and COUNT arguments." | |
379 | (interactive "sSemantic backward word search: ") | |
380 | (senator-search 'word-search-backward word bound noerror count)) | |
381 | ||
382 | ;;; Other useful search commands (minor mode menu) | |
383 | ||
384 | (defvar senator-last-search-type nil | |
385 | "Type of last non-incremental search command called.") | |
386 | ||
387 | (defun senator-nonincremental-repeat-search-forward () | |
388 | "Search forward for the previous search string or regexp." | |
389 | (interactive) | |
390 | (cond | |
391 | ((and (eq senator-last-search-type 'string) | |
392 | search-ring) | |
393 | (senator-search-forward (car search-ring))) | |
394 | ((and (eq senator-last-search-type 'regexp) | |
395 | regexp-search-ring) | |
396 | (senator-re-search-forward (car regexp-search-ring))) | |
397 | (t | |
398 | (error "No previous search")))) | |
399 | ||
400 | (defun senator-nonincremental-repeat-search-backward () | |
401 | "Search backward for the previous search string or regexp." | |
402 | (interactive) | |
403 | (cond | |
404 | ((and (eq senator-last-search-type 'string) | |
405 | search-ring) | |
406 | (senator-search-backward (car search-ring))) | |
407 | ((and (eq senator-last-search-type 'regexp) | |
408 | regexp-search-ring) | |
409 | (senator-re-search-backward (car regexp-search-ring))) | |
410 | (t | |
411 | (error "No previous search")))) | |
412 | ||
413 | (defun senator-nonincremental-search-forward (string) | |
9bf6c65c | 414 | "Search for STRING nonincrementally." |
8bf997ef CY |
415 | (interactive "sSemantic search for string: ") |
416 | (setq senator-last-search-type 'string) | |
417 | (if (equal string "") | |
418 | (senator-search-forward (car search-ring)) | |
419 | (isearch-update-ring string nil) | |
420 | (senator-search-forward string))) | |
421 | ||
422 | (defun senator-nonincremental-search-backward (string) | |
423 | "Search backward for STRING nonincrementally." | |
424 | (interactive "sSemantic search for string: ") | |
425 | (setq senator-last-search-type 'string) | |
426 | (if (equal string "") | |
427 | (senator-search-backward (car search-ring)) | |
428 | (isearch-update-ring string nil) | |
429 | (senator-search-backward string))) | |
430 | ||
431 | (defun senator-nonincremental-re-search-forward (string) | |
432 | "Search for the regular expression STRING nonincrementally." | |
433 | (interactive "sSemantic search for regexp: ") | |
434 | (setq senator-last-search-type 'regexp) | |
435 | (if (equal string "") | |
436 | (senator-re-search-forward (car regexp-search-ring)) | |
437 | (isearch-update-ring string t) | |
438 | (senator-re-search-forward string))) | |
439 | ||
440 | (defun senator-nonincremental-re-search-backward (string) | |
441 | "Search backward for the regular expression STRING nonincrementally." | |
442 | (interactive "sSemantic search for regexp: ") | |
443 | (setq senator-last-search-type 'regexp) | |
444 | (if (equal string "") | |
445 | (senator-re-search-backward (car regexp-search-ring)) | |
446 | (isearch-update-ring string t) | |
447 | (senator-re-search-backward string))) | |
448 | ||
449 | (defvar senator--search-filter nil) | |
450 | ||
451 | (defun senator-search-set-tag-class-filter (&optional classes) | |
452 | "In current buffer, limit search scope to tag CLASSES. | |
453 | CLASSES is a list of tag class symbols or nil. If nil only global | |
454 | filters in `senator-search-tag-filter-functions' remain active." | |
455 | (interactive "sClasses: ") | |
456 | (setq classes | |
457 | (cond | |
458 | ((null classes) | |
459 | nil) | |
460 | ((symbolp classes) | |
461 | (list classes)) | |
462 | ((stringp classes) | |
463 | (mapcar 'read (split-string classes))) | |
464 | (t | |
465 | (signal 'wrong-type-argument (list classes))) | |
466 | )) | |
467 | ;; Clear previous filter. | |
468 | (remove-hook 'senator-search-tag-filter-functions | |
469 | senator--search-filter t) | |
470 | (kill-local-variable 'senator--search-filter) | |
471 | (if classes | |
472 | (let ((tag (make-symbol "tag")) | |
473 | (names (mapconcat 'symbol-name classes "', `"))) | |
474 | (set (make-local-variable 'senator--search-filter) | |
475 | `(lambda (,tag) | |
476 | (memq (semantic-tag-class ,tag) ',classes))) | |
477 | (add-hook 'senator-search-tag-filter-functions | |
478 | senator--search-filter nil t) | |
479 | (message "Limit search to `%s' tags" names)) | |
480 | (message "Default search filter restored"))) | |
481 | ||
482 | ;;; Folding | |
483 | ;; | |
484 | ;; Use new folding state. It might be wise to extend the idea | |
485 | ;; of folding for hiding all but this, or show all children, etc. | |
486 | ||
487 | (defun senator-fold-tag (&optional tag) | |
488 | "Fold the current TAG." | |
489 | (interactive) | |
490 | (semantic-set-tag-folded (or tag (semantic-current-tag)) t)) | |
491 | ||
492 | (defun senator-unfold-tag (&optional tag) | |
493 | "Fold the current TAG." | |
494 | (interactive) | |
495 | (semantic-set-tag-folded (or tag (semantic-current-tag)) nil)) | |
496 | ||
497 | (defun senator-fold-tag-toggle (&optional tag) | |
498 | "Fold the current TAG." | |
499 | (interactive) | |
500 | (let ((tag (or tag (semantic-current-tag)))) | |
501 | (if (semantic-tag-folded-p tag) | |
502 | (senator-unfold-tag tag) | |
503 | (senator-fold-tag tag)))) | |
504 | ||
505 | ;; @TODO - move this to some analyzer / refs tool | |
506 | (define-overloadable-function semantic-up-reference (tag) | |
507 | "Return a tag that is referred to by TAG. | |
508 | A \"reference\" could be any interesting feature of TAG. | |
509 | In C++, a function may have a 'parent' which is non-local. | |
510 | If that parent which is only a reference in the function tag | |
511 | is found, we can jump to it. | |
512 | Some tags such as includes have other reference features.") | |
513 | ||
514 | ;;;###autoload | |
515 | (defun senator-go-to-up-reference (&optional tag) | |
516 | "Move up one reference from the current TAG. | |
517 | A \"reference\" could be any interesting feature of TAG. | |
518 | In C++, a function may have a 'parent' which is non-local. | |
519 | If that parent which is only a reference in the function tag | |
520 | is found, we can jump to it. | |
521 | Some tags such as includes have other reference features." | |
522 | (interactive) | |
523 | (let ((result (semantic-up-reference (or tag (semantic-current-tag))))) | |
524 | (if (not result) | |
525 | (error "No up reference found") | |
526 | (push-mark) | |
527 | (cond | |
528 | ;; A tag | |
529 | ((semantic-tag-p result) | |
530 | (semantic-go-to-tag result) | |
531 | (switch-to-buffer (current-buffer)) | |
532 | (semantic-momentary-highlight-tag result)) | |
533 | ;; Buffers | |
534 | ((bufferp result) | |
535 | (switch-to-buffer result) | |
536 | (pulse-momentary-highlight-one-line (point))) | |
537 | ;; Files | |
538 | ((and (stringp result) (file-exists-p result)) | |
539 | (find-file result) | |
540 | (pulse-momentary-highlight-one-line (point))) | |
541 | (t | |
542 | (error "Unknown result type from `semantic-up-reference'")))))) | |
543 | ||
544 | (defun semantic-up-reference-default (tag) | |
9bf6c65c | 545 | "Return a tag that is referred to by TAG. |
8bf997ef CY |
546 | Makes C/C++ language like assumptions." |
547 | (cond ((semantic-tag-faux-p tag) | |
548 | ;; Faux tags should have a real tag in some other location. | |
549 | (require 'semantic/sort) | |
550 | (let ((options (semantic-tag-external-class tag))) | |
551 | ;; I should do something a little better than | |
552 | ;; this. Oy! | |
553 | (car options) | |
554 | )) | |
555 | ||
556 | ;; Include always point to another file. | |
557 | ((eq (semantic-tag-class tag) 'include) | |
558 | (let ((file (semantic-dependency-tag-file tag))) | |
559 | (cond | |
560 | ((or (not file) (not (file-exists-p file))) | |
561 | (error "Could not location include %s" | |
562 | (semantic-tag-name tag))) | |
563 | ((get-file-buffer file) | |
564 | (get-file-buffer file)) | |
565 | ((stringp file) | |
566 | file) | |
567 | ))) | |
568 | ||
569 | ;; Is there a parent of the function to jump to? | |
570 | ((and (semantic-tag-of-class-p tag 'function) | |
571 | (semantic-tag-function-parent tag)) | |
572 | (let* ((scope (semantic-calculate-scope (point)))) | |
573 | ;; @todo - it would be cool to ask the user which one if | |
574 | ;; more than one. | |
575 | (car (oref scope parents)) | |
576 | )) | |
577 | ||
578 | ;; Is there a non-prototype version of the tag to jump to? | |
579 | ((semantic-tag-get-attribute tag :prototype-flag) | |
580 | (require 'semantic/analyze/refs) | |
581 | (let* ((sar (semantic-analyze-tag-references tag))) | |
582 | (car (semantic-analyze-refs-impl sar t))) | |
583 | ) | |
584 | ||
585 | ;; If this is a datatype, and we have superclasses | |
586 | ((and (semantic-tag-of-class-p tag 'type) | |
587 | (semantic-tag-type-superclasses tag)) | |
588 | (require 'semantic/analyze) | |
589 | (let ((scope (semantic-calculate-scope (point))) | |
590 | (parents (semantic-tag-type-superclasses tag))) | |
591 | (semantic-analyze-find-tag (car parents) 'type scope))) | |
592 | ||
593 | ;; Get the data type, and try to find that. | |
594 | ((semantic-tag-type tag) | |
595 | (require 'semantic/analyze) | |
596 | (let ((scope (semantic-calculate-scope (point)))) | |
597 | (semantic-analyze-tag-type tag scope)) | |
598 | ) | |
599 | (t nil))) | |
600 | ||
601 | (defvar senator-isearch-semantic-mode nil | |
602 | "Non-nil if isearch does semantic search. | |
603 | This is a buffer local variable.") | |
604 | (make-variable-buffer-local 'senator-isearch-semantic-mode) | |
605 | ||
606 | (defun senator-beginning-of-defun (&optional arg) | |
607 | "Move backward to the beginning of a defun. | |
608 | Use semantic tags to navigate. | |
609 | ARG is the number of tags to navigate (not yet implemented)." | |
610 | (semantic-fetch-tags) | |
611 | (let* ((senator-highlight-found nil) | |
612 | ;; Step at beginning of next tag with class specified in | |
613 | ;; `senator-step-at-tag-classes'. | |
614 | (senator-step-at-start-end-tag-classes t) | |
615 | (tag (senator-previous-tag))) | |
616 | (when tag | |
617 | (if (= (point) (semantic-tag-end tag)) | |
618 | (goto-char (semantic-tag-start tag))) | |
619 | (beginning-of-line)))) | |
620 | ||
621 | (defun senator-end-of-defun (&optional arg) | |
622 | "Move forward to next end of defun. | |
623 | Use semantic tags to navigate. | |
624 | ARG is the number of tags to navigate (not yet implemented)." | |
625 | (semantic-fetch-tags) | |
626 | (let* ((senator-highlight-found nil) | |
627 | ;; Step at end of next tag with class specified in | |
628 | ;; `senator-step-at-tag-classes'. | |
629 | (senator-step-at-start-end-tag-classes t) | |
630 | (tag (senator-next-tag))) | |
631 | (when tag | |
632 | (if (= (point) (semantic-tag-start tag)) | |
633 | (goto-char (semantic-tag-end tag))) | |
634 | (skip-chars-forward " \t") | |
635 | (if (looking-at "\\s<\\|\n") | |
636 | (forward-line 1))))) | |
637 | ||
638 | (defun senator-narrow-to-defun () | |
639 | "Make text outside current defun invisible. | |
640 | The defun visible is the one that contains point or follows point. | |
641 | Use semantic tags to navigate." | |
642 | (interactive) | |
643 | (semantic-fetch-tags) | |
644 | (save-excursion | |
645 | (widen) | |
646 | (senator-end-of-defun) | |
647 | (let ((end (point))) | |
648 | (senator-beginning-of-defun) | |
649 | (narrow-to-region (point) end)))) | |
650 | ||
651 | (defun senator-mark-defun () | |
652 | "Put mark at end of this defun, point at beginning. | |
653 | The defun marked is the one that contains point or follows point. | |
654 | Use semantic tags to navigate." | |
655 | (interactive) | |
656 | (let ((origin (point)) | |
657 | (end (progn (senator-end-of-defun) (point))) | |
658 | (start (progn (senator-beginning-of-defun) (point)))) | |
659 | (goto-char origin) | |
660 | (push-mark (point)) | |
661 | (goto-char end) ;; end-of-defun | |
662 | (push-mark (point) nil t) | |
663 | (goto-char start) ;; beginning-of-defun | |
664 | (re-search-backward "^\n" (- (point) 1) t))) | |
665 | ||
666 | ;;; Tag Cut & Paste | |
667 | ||
668 | ;; To copy a tag, means to put a tag definition into the tag | |
669 | ;; ring. To kill a tag, put the tag into the tag ring AND put | |
670 | ;; the body of the tag into the kill-ring. | |
671 | ;; | |
672 | ;; To retrieve a killed tag's text, use C-y (yank), but to retrieve | |
673 | ;; the tag as a reference of some sort, use senator-yank-tag. | |
674 | ||
675 | (defvar senator-tag-ring (make-ring 20) | |
676 | "Ring of tags for use with cut and paste.") | |
677 | ||
678 | ;;;###autoload | |
679 | (defun senator-copy-tag () | |
680 | "Take the current tag, and place it in the tag ring." | |
681 | (interactive) | |
682 | (semantic-fetch-tags) | |
683 | (let ((ft (semantic-obtain-foreign-tag))) | |
684 | (when ft | |
685 | (ring-insert senator-tag-ring ft) | |
686 | (kill-ring-save (semantic-tag-start ft) (semantic-tag-end ft)) | |
2054a44c CY |
687 | (when (called-interactively-p 'interactive) |
688 | (message "Use C-y to yank text. \ | |
689 | Use `senator-yank-tag' for prototype insert."))) | |
8bf997ef CY |
690 | ft)) |
691 | ||
692 | ;;;###autoload | |
693 | (defun senator-kill-tag () | |
694 | "Take the current tag, place it in the tag ring, and kill it. | |
695 | Killing the tag removes the text for that tag, and places it into | |
696 | the kill ring. Retrieve that text with \\[yank]." | |
697 | (interactive) | |
698 | (let ((ct (senator-copy-tag))) ;; this handles the reparse for us. | |
699 | (kill-region (semantic-tag-start ct) | |
700 | (semantic-tag-end ct)) | |
2054a44c CY |
701 | (when (called-interactively-p 'interactive) |
702 | (message "Use C-y to yank text. \ | |
703 | Use `senator-yank-tag' for prototype insert.")))) | |
8bf997ef CY |
704 | |
705 | ;;;###autoload | |
706 | (defun senator-yank-tag () | |
707 | "Yank a tag from the tag ring. | |
9bf6c65c | 708 | The form the tag takes is different depending on where it is being |
8bf997ef CY |
709 | yanked to." |
710 | (interactive) | |
711 | (or (ring-empty-p senator-tag-ring) | |
712 | (let ((ft (ring-ref senator-tag-ring 0))) | |
713 | (semantic-foreign-tag-check ft) | |
714 | (semantic-insert-foreign-tag ft) | |
2054a44c | 715 | (when (called-interactively-p 'interactive) |
8bf997ef | 716 | (message "Use C-y to recover the yank the text of %s." |
2054a44c | 717 | (semantic-tag-name ft)))))) |
8bf997ef CY |
718 | |
719 | ;;;###autoload | |
720 | (defun senator-copy-tag-to-register (register &optional kill-flag) | |
721 | "Copy the current tag into REGISTER. | |
722 | Optional argument KILL-FLAG will delete the text of the tag to the | |
723 | kill ring." | |
724 | (interactive "cTag to register: \nP") | |
725 | (semantic-fetch-tags) | |
726 | (let ((ft (semantic-obtain-foreign-tag))) | |
727 | (when ft | |
728 | (set-register register ft) | |
729 | (if kill-flag | |
730 | (kill-region (semantic-tag-start ft) | |
731 | (semantic-tag-end ft)))))) | |
732 | ||
733 | ;;;###autoload | |
734 | (defun senator-transpose-tags-up () | |
9bf6c65c | 735 | "Transpose the current tag, and the preceding tag." |
8bf997ef CY |
736 | (interactive) |
737 | (semantic-fetch-tags) | |
738 | (let* ((current-tag (semantic-current-tag)) | |
739 | (prev-tag (save-excursion | |
740 | (goto-char (semantic-tag-start current-tag)) | |
741 | (semantic-find-tag-by-overlay-prev))) | |
742 | (ct-parent (semantic-find-tag-parent-by-overlay current-tag)) | |
743 | (pt-parent (semantic-find-tag-parent-by-overlay prev-tag))) | |
744 | (if (not (eq ct-parent pt-parent)) | |
745 | (error "Cannot transpose tags")) | |
746 | (let ((txt (buffer-substring (semantic-tag-start current-tag) | |
747 | (semantic-tag-end current-tag))) | |
748 | (line (count-lines (semantic-tag-start current-tag) | |
749 | (point))) | |
750 | (insert-point nil) | |
751 | ) | |
752 | (delete-region (semantic-tag-start current-tag) | |
753 | (semantic-tag-end current-tag)) | |
754 | (delete-blank-lines) | |
755 | (goto-char (semantic-tag-start prev-tag)) | |
756 | (setq insert-point (point)) | |
757 | (insert txt) | |
758 | (if (/= (current-column) 0) | |
759 | (insert "\n")) | |
760 | (insert "\n") | |
761 | (goto-char insert-point) | |
762 | (forward-line line) | |
763 | ))) | |
764 | ||
765 | ;;;###autoload | |
766 | (defun senator-transpose-tags-down () | |
767 | "Transpose the current tag, and the following tag." | |
768 | (interactive) | |
769 | (semantic-fetch-tags) | |
770 | (let* ((current-tag (semantic-current-tag)) | |
771 | (next-tag (save-excursion | |
772 | (goto-char (semantic-tag-end current-tag)) | |
773 | (semantic-find-tag-by-overlay-next))) | |
774 | (end-pt (point-marker)) | |
775 | ) | |
776 | (goto-char (semantic-tag-start next-tag)) | |
777 | (forward-char 1) | |
778 | (senator-transpose-tags-up) | |
779 | ;; I know that the above fcn deletes the next tag, so our pt marker | |
780 | ;; will be stable. | |
781 | (goto-char end-pt))) | |
782 | ||
783 | ;;; Using semantic search in isearch mode | |
784 | ||
785 | (defun senator-lazy-highlight-update () | |
786 | "Force lazy highlight update." | |
787 | (lazy-highlight-cleanup t) | |
788 | (set 'isearch-lazy-highlight-last-string nil) | |
789 | (setq isearch-adjusted t) | |
790 | (isearch-update)) | |
791 | ||
792 | ;; Recent versions of GNU Emacs allow to override the isearch search | |
793 | ;; function for special needs, and avoid to advice the built-in search | |
794 | ;; function :-) | |
795 | (defun senator-isearch-search-fun () | |
796 | "Return the function to use for the search. | |
797 | Use a senator search function when semantic isearch mode is enabled." | |
798 | (intern | |
799 | (concat (if senator-isearch-semantic-mode | |
800 | "senator-" | |
801 | "") | |
802 | (cond (isearch-word "word-") | |
803 | (isearch-regexp "re-") | |
804 | (t "")) | |
805 | "search-" | |
806 | (if isearch-forward | |
807 | "forward" | |
808 | "backward")))) | |
809 | ||
810 | (defun senator-isearch-toggle-semantic-mode () | |
811 | "Toggle semantic searching on or off in isearch mode." | |
812 | (interactive) | |
813 | (setq senator-isearch-semantic-mode | |
814 | (not senator-isearch-semantic-mode)) | |
815 | (if isearch-mode | |
816 | ;; force lazy highlight update | |
817 | (senator-lazy-highlight-update) | |
818 | (message "Isearch semantic mode %s" | |
819 | (if senator-isearch-semantic-mode | |
820 | "enabled" | |
821 | "disabled")))) | |
822 | ||
823 | (defvar senator-old-isearch-search-fun nil | |
824 | "Hold previous value of `isearch-search-fun-function'.") | |
825 | ||
826 | (defun senator-isearch-mode-hook () | |
827 | "Isearch mode hook to setup semantic searching." | |
828 | (if (and isearch-mode senator-isearch-semantic-mode) | |
829 | (progn | |
830 | ;; When `senator-isearch-semantic-mode' is on save the | |
831 | ;; previous `isearch-search-fun-function' and install the | |
832 | ;; senator one. | |
833 | (when (and (local-variable-p 'isearch-search-fun-function) | |
834 | (not (local-variable-p 'senator-old-isearch-search-fun))) | |
835 | (set (make-local-variable 'senator-old-isearch-search-fun) | |
836 | isearch-search-fun-function)) | |
837 | (set (make-local-variable 'isearch-search-fun-function) | |
838 | 'senator-isearch-search-fun)) | |
839 | ;; When `senator-isearch-semantic-mode' is off restore the | |
840 | ;; previous `isearch-search-fun-function'. | |
841 | (when (eq isearch-search-fun-function 'senator-isearch-search-fun) | |
842 | (if (local-variable-p 'senator-old-isearch-search-fun) | |
843 | (progn | |
844 | (set (make-local-variable 'isearch-search-fun-function) | |
845 | senator-old-isearch-search-fun) | |
846 | (kill-local-variable 'senator-old-isearch-search-fun)) | |
847 | (kill-local-variable 'isearch-search-fun-function))))) | |
848 | ||
849 | ;; (add-hook 'isearch-mode-hook 'senator-isearch-mode-hook) | |
850 | ;; (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook) | |
851 | ||
852 | ;; ;; Keyboard shortcut to toggle semantic search in isearch mode. | |
853 | ;; (define-key isearch-mode-map | |
854 | ;; [(control ?,)] | |
855 | ;; 'senator-isearch-toggle-semantic-mode) | |
856 | ||
8bf997ef CY |
857 | (provide 'semantic/senator) |
858 | ||
859 | ;; Local variables: | |
860 | ;; generated-autoload-file: "loaddefs.el" | |
8bf997ef CY |
861 | ;; generated-autoload-load-name: "semantic/senator" |
862 | ;; End: | |
863 | ||
3999968a | 864 | ;; arch-tag: 397100d0-e2db-467e-8c19-d8d4d99d51f1 |
8bf997ef | 865 | ;;; semantic/senator.el ends here |