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