Commit | Line | Data |
---|---|---|
8bf997ef CY |
1 | ;;; semantic/senator.el --- SEmantic NAvigaTOR |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2000-2014 Free Software Foundation, Inc. |
8bf997ef CY |
4 | |
5 | ;; Author: David Ponce <david@dponce.com> | |
34dc21db | 6 | ;; Maintainer: emacs-devel@gnu.org |
8bf997ef CY |
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) | |
bf659b3f | 258 | (semantic-error-if-unparsed) |
8bf997ef CY |
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) | |
bf659b3f | 298 | (semantic-error-if-unparsed) |
8bf997ef CY |
299 | (let ((pos (point)) |
300 | (tag (semantic-current-tag)) | |
301 | where) | |
302 | (if (and tag | |
303 | (not (senator-skip-p tag)) | |
304 | (senator-step-at-start-end-p tag) | |
305 | (or (= pos (semantic-tag-end tag)) | |
306 | (senator-middle-of-tag-p pos tag))) | |
307 | nil | |
308 | (if (setq tag (senator-step-at-parent tag)) | |
309 | nil | |
310 | (setq tag (senator-previous-tag-or-parent pos)) | |
311 | (while (and tag (senator-skip-p tag)) | |
312 | (setq tag (senator-previous-tag-or-parent | |
313 | (semantic-tag-start tag)))))) | |
314 | (if (not tag) | |
315 | (progn | |
316 | (goto-char (point-min)) | |
317 | (message "Beginning of buffer")) | |
318 | (cond ((or (not (senator-step-at-start-end-p tag)) | |
319 | (= pos (semantic-tag-end tag)) | |
320 | (senator-middle-of-tag-p pos tag)) | |
321 | (setq where "start") | |
322 | (goto-char (semantic-tag-start tag))) | |
323 | (t | |
324 | (setq where "end") | |
325 | (goto-char (semantic-tag-end tag)))) | |
326 | (senator-momentary-highlight-tag tag) | |
327 | (message "%S: %s (%s)" | |
328 | (semantic-tag-class tag) | |
329 | (semantic-tag-name tag) | |
330 | where)) | |
331 | tag)) | |
332 | ||
333 | ;;; Search commands | |
334 | ||
335 | (defun senator-search-forward (string &optional bound noerror count) | |
336 | "Search in tag names forward from point for STRING. | |
337 | Set point to the end of the occurrence found, and return point. | |
338 | See also the function `search-forward' for details on the BOUND, | |
339 | NOERROR and COUNT arguments." | |
340 | (interactive "sSemantic search: ") | |
341 | (senator-search 'search-forward string bound noerror count)) | |
342 | ||
343 | (defun senator-re-search-forward (regexp &optional bound noerror count) | |
344 | "Search in tag names forward from point for regular expression REGEXP. | |
345 | Set point to the end of the occurrence found, and return point. | |
346 | See also the function `re-search-forward' for details on the BOUND, | |
347 | NOERROR and COUNT arguments." | |
348 | (interactive "sSemantic regexp search: ") | |
349 | (senator-search 're-search-forward regexp bound noerror count)) | |
350 | ||
351 | (defun senator-word-search-forward (word &optional bound noerror count) | |
352 | "Search in tag names forward from point for WORD. | |
353 | Set point to the end of the occurrence found, and return point. | |
354 | See also the function `word-search-forward' for details on the BOUND, | |
355 | NOERROR and COUNT arguments." | |
356 | (interactive "sSemantic word search: ") | |
357 | (senator-search 'word-search-forward word bound noerror count)) | |
358 | ||
359 | (defun senator-search-backward (string &optional bound noerror count) | |
360 | "Search in tag names backward from point for STRING. | |
361 | Set point to the beginning of the occurrence found, and return point. | |
362 | See also the function `search-backward' for details on the BOUND, | |
363 | NOERROR and COUNT arguments." | |
364 | (interactive "sSemantic backward search: ") | |
365 | (senator-search 'search-backward string bound noerror count)) | |
366 | ||
367 | (defun senator-re-search-backward (regexp &optional bound noerror count) | |
368 | "Search in tag names backward from point for regular expression REGEXP. | |
369 | Set point to the beginning of the occurrence found, and return point. | |
370 | See also the function `re-search-backward' for details on the BOUND, | |
371 | NOERROR and COUNT arguments." | |
372 | (interactive "sSemantic backward regexp search: ") | |
373 | (senator-search 're-search-backward regexp bound noerror count)) | |
374 | ||
375 | (defun senator-word-search-backward (word &optional bound noerror count) | |
376 | "Search in tag names backward from point for WORD. | |
377 | Set point to the beginning of the occurrence found, and return point. | |
378 | See also the function `word-search-backward' for details on the BOUND, | |
379 | NOERROR and COUNT arguments." | |
380 | (interactive "sSemantic backward word search: ") | |
381 | (senator-search 'word-search-backward word bound noerror count)) | |
382 | ||
383 | ;;; Other useful search commands (minor mode menu) | |
384 | ||
385 | (defvar senator-last-search-type nil | |
386 | "Type of last non-incremental search command called.") | |
387 | ||
388 | (defun senator-nonincremental-repeat-search-forward () | |
389 | "Search forward for the previous search string or regexp." | |
390 | (interactive) | |
391 | (cond | |
392 | ((and (eq senator-last-search-type 'string) | |
393 | search-ring) | |
394 | (senator-search-forward (car search-ring))) | |
395 | ((and (eq senator-last-search-type 'regexp) | |
396 | regexp-search-ring) | |
397 | (senator-re-search-forward (car regexp-search-ring))) | |
398 | (t | |
399 | (error "No previous search")))) | |
400 | ||
401 | (defun senator-nonincremental-repeat-search-backward () | |
402 | "Search backward for the previous search string or regexp." | |
403 | (interactive) | |
404 | (cond | |
405 | ((and (eq senator-last-search-type 'string) | |
406 | search-ring) | |
407 | (senator-search-backward (car search-ring))) | |
408 | ((and (eq senator-last-search-type 'regexp) | |
409 | regexp-search-ring) | |
410 | (senator-re-search-backward (car regexp-search-ring))) | |
411 | (t | |
412 | (error "No previous search")))) | |
413 | ||
414 | (defun senator-nonincremental-search-forward (string) | |
9bf6c65c | 415 | "Search for STRING nonincrementally." |
8bf997ef CY |
416 | (interactive "sSemantic search for string: ") |
417 | (setq senator-last-search-type 'string) | |
418 | (if (equal string "") | |
419 | (senator-search-forward (car search-ring)) | |
420 | (isearch-update-ring string nil) | |
421 | (senator-search-forward string))) | |
422 | ||
423 | (defun senator-nonincremental-search-backward (string) | |
424 | "Search backward for STRING nonincrementally." | |
425 | (interactive "sSemantic search for string: ") | |
426 | (setq senator-last-search-type 'string) | |
427 | (if (equal string "") | |
428 | (senator-search-backward (car search-ring)) | |
429 | (isearch-update-ring string nil) | |
430 | (senator-search-backward string))) | |
431 | ||
432 | (defun senator-nonincremental-re-search-forward (string) | |
433 | "Search for the regular expression STRING nonincrementally." | |
434 | (interactive "sSemantic search for regexp: ") | |
435 | (setq senator-last-search-type 'regexp) | |
436 | (if (equal string "") | |
437 | (senator-re-search-forward (car regexp-search-ring)) | |
438 | (isearch-update-ring string t) | |
439 | (senator-re-search-forward string))) | |
440 | ||
441 | (defun senator-nonincremental-re-search-backward (string) | |
442 | "Search backward for the regular expression STRING nonincrementally." | |
443 | (interactive "sSemantic search for regexp: ") | |
444 | (setq senator-last-search-type 'regexp) | |
445 | (if (equal string "") | |
446 | (senator-re-search-backward (car regexp-search-ring)) | |
447 | (isearch-update-ring string t) | |
448 | (senator-re-search-backward string))) | |
449 | ||
450 | (defvar senator--search-filter nil) | |
451 | ||
452 | (defun senator-search-set-tag-class-filter (&optional classes) | |
453 | "In current buffer, limit search scope to tag CLASSES. | |
454 | CLASSES is a list of tag class symbols or nil. If nil only global | |
455 | filters in `senator-search-tag-filter-functions' remain active." | |
456 | (interactive "sClasses: ") | |
457 | (setq classes | |
458 | (cond | |
459 | ((null classes) | |
460 | nil) | |
461 | ((symbolp classes) | |
462 | (list classes)) | |
463 | ((stringp classes) | |
464 | (mapcar 'read (split-string classes))) | |
465 | (t | |
466 | (signal 'wrong-type-argument (list classes))) | |
467 | )) | |
468 | ;; Clear previous filter. | |
469 | (remove-hook 'senator-search-tag-filter-functions | |
470 | senator--search-filter t) | |
471 | (kill-local-variable 'senator--search-filter) | |
472 | (if classes | |
473 | (let ((tag (make-symbol "tag")) | |
474 | (names (mapconcat 'symbol-name classes "', `"))) | |
475 | (set (make-local-variable 'senator--search-filter) | |
476 | `(lambda (,tag) | |
477 | (memq (semantic-tag-class ,tag) ',classes))) | |
478 | (add-hook 'senator-search-tag-filter-functions | |
479 | senator--search-filter nil t) | |
480 | (message "Limit search to `%s' tags" names)) | |
481 | (message "Default search filter restored"))) | |
482 | ||
483 | ;;; Folding | |
484 | ;; | |
485 | ;; Use new folding state. It might be wise to extend the idea | |
486 | ;; of folding for hiding all but this, or show all children, etc. | |
487 | ||
488 | (defun senator-fold-tag (&optional tag) | |
489 | "Fold the current TAG." | |
490 | (interactive) | |
491 | (semantic-set-tag-folded (or tag (semantic-current-tag)) t)) | |
492 | ||
493 | (defun senator-unfold-tag (&optional tag) | |
494 | "Fold the current TAG." | |
495 | (interactive) | |
496 | (semantic-set-tag-folded (or tag (semantic-current-tag)) nil)) | |
497 | ||
498 | (defun senator-fold-tag-toggle (&optional tag) | |
499 | "Fold the current TAG." | |
500 | (interactive) | |
501 | (let ((tag (or tag (semantic-current-tag)))) | |
502 | (if (semantic-tag-folded-p tag) | |
503 | (senator-unfold-tag tag) | |
504 | (senator-fold-tag tag)))) | |
505 | ||
506 | ;; @TODO - move this to some analyzer / refs tool | |
507 | (define-overloadable-function semantic-up-reference (tag) | |
508 | "Return a tag that is referred to by TAG. | |
509 | A \"reference\" could be any interesting feature of TAG. | |
510 | In C++, a function may have a 'parent' which is non-local. | |
511 | If that parent which is only a reference in the function tag | |
512 | is found, we can jump to it. | |
513 | Some tags such as includes have other reference features.") | |
514 | ||
515 | ;;;###autoload | |
516 | (defun senator-go-to-up-reference (&optional tag) | |
517 | "Move up one reference from the current TAG. | |
518 | A \"reference\" could be any interesting feature of TAG. | |
519 | In C++, a function may have a 'parent' which is non-local. | |
520 | If that parent which is only a reference in the function tag | |
521 | is found, we can jump to it. | |
522 | Some tags such as includes have other reference features." | |
523 | (interactive) | |
bf659b3f | 524 | (semantic-error-if-unparsed) |
8bf997ef CY |
525 | (let ((result (semantic-up-reference (or tag (semantic-current-tag))))) |
526 | (if (not result) | |
527 | (error "No up reference found") | |
528 | (push-mark) | |
529 | (cond | |
530 | ;; A tag | |
531 | ((semantic-tag-p result) | |
532 | (semantic-go-to-tag result) | |
533 | (switch-to-buffer (current-buffer)) | |
534 | (semantic-momentary-highlight-tag result)) | |
535 | ;; Buffers | |
536 | ((bufferp result) | |
537 | (switch-to-buffer result) | |
538 | (pulse-momentary-highlight-one-line (point))) | |
539 | ;; Files | |
540 | ((and (stringp result) (file-exists-p result)) | |
541 | (find-file result) | |
542 | (pulse-momentary-highlight-one-line (point))) | |
543 | (t | |
544 | (error "Unknown result type from `semantic-up-reference'")))))) | |
545 | ||
546 | (defun semantic-up-reference-default (tag) | |
9bf6c65c | 547 | "Return a tag that is referred to by TAG. |
8bf997ef CY |
548 | Makes C/C++ language like assumptions." |
549 | (cond ((semantic-tag-faux-p tag) | |
550 | ;; Faux tags should have a real tag in some other location. | |
551 | (require 'semantic/sort) | |
552 | (let ((options (semantic-tag-external-class tag))) | |
553 | ;; I should do something a little better than | |
554 | ;; this. Oy! | |
555 | (car options) | |
556 | )) | |
557 | ||
558 | ;; Include always point to another file. | |
559 | ((eq (semantic-tag-class tag) 'include) | |
560 | (let ((file (semantic-dependency-tag-file tag))) | |
561 | (cond | |
562 | ((or (not file) (not (file-exists-p file))) | |
563 | (error "Could not location include %s" | |
564 | (semantic-tag-name tag))) | |
565 | ((get-file-buffer file) | |
566 | (get-file-buffer file)) | |
567 | ((stringp file) | |
568 | file) | |
569 | ))) | |
570 | ||
571 | ;; Is there a parent of the function to jump to? | |
572 | ((and (semantic-tag-of-class-p tag 'function) | |
573 | (semantic-tag-function-parent tag)) | |
574 | (let* ((scope (semantic-calculate-scope (point)))) | |
575 | ;; @todo - it would be cool to ask the user which one if | |
576 | ;; more than one. | |
577 | (car (oref scope parents)) | |
578 | )) | |
579 | ||
580 | ;; Is there a non-prototype version of the tag to jump to? | |
581 | ((semantic-tag-get-attribute tag :prototype-flag) | |
582 | (require 'semantic/analyze/refs) | |
583 | (let* ((sar (semantic-analyze-tag-references tag))) | |
584 | (car (semantic-analyze-refs-impl sar t))) | |
585 | ) | |
586 | ||
587 | ;; If this is a datatype, and we have superclasses | |
588 | ((and (semantic-tag-of-class-p tag 'type) | |
589 | (semantic-tag-type-superclasses tag)) | |
590 | (require 'semantic/analyze) | |
591 | (let ((scope (semantic-calculate-scope (point))) | |
592 | (parents (semantic-tag-type-superclasses tag))) | |
593 | (semantic-analyze-find-tag (car parents) 'type scope))) | |
594 | ||
595 | ;; Get the data type, and try to find that. | |
596 | ((semantic-tag-type tag) | |
597 | (require 'semantic/analyze) | |
598 | (let ((scope (semantic-calculate-scope (point)))) | |
599 | (semantic-analyze-tag-type tag scope)) | |
600 | ) | |
601 | (t nil))) | |
602 | ||
603 | (defvar senator-isearch-semantic-mode nil | |
604 | "Non-nil if isearch does semantic search. | |
605 | This is a buffer local variable.") | |
606 | (make-variable-buffer-local 'senator-isearch-semantic-mode) | |
607 | ||
608 | (defun senator-beginning-of-defun (&optional arg) | |
609 | "Move backward to the beginning of a defun. | |
610 | Use semantic tags to navigate. | |
611 | ARG is the number of tags to navigate (not yet implemented)." | |
612 | (semantic-fetch-tags) | |
613 | (let* ((senator-highlight-found nil) | |
614 | ;; Step at beginning of next tag with class specified in | |
615 | ;; `senator-step-at-tag-classes'. | |
616 | (senator-step-at-start-end-tag-classes t) | |
617 | (tag (senator-previous-tag))) | |
618 | (when tag | |
619 | (if (= (point) (semantic-tag-end tag)) | |
620 | (goto-char (semantic-tag-start tag))) | |
621 | (beginning-of-line)))) | |
622 | ||
623 | (defun senator-end-of-defun (&optional arg) | |
624 | "Move forward to next end of defun. | |
625 | Use semantic tags to navigate. | |
626 | ARG is the number of tags to navigate (not yet implemented)." | |
627 | (semantic-fetch-tags) | |
628 | (let* ((senator-highlight-found nil) | |
629 | ;; Step at end of next tag with class specified in | |
630 | ;; `senator-step-at-tag-classes'. | |
631 | (senator-step-at-start-end-tag-classes t) | |
632 | (tag (senator-next-tag))) | |
633 | (when tag | |
634 | (if (= (point) (semantic-tag-start tag)) | |
635 | (goto-char (semantic-tag-end tag))) | |
636 | (skip-chars-forward " \t") | |
637 | (if (looking-at "\\s<\\|\n") | |
638 | (forward-line 1))))) | |
639 | ||
640 | (defun senator-narrow-to-defun () | |
641 | "Make text outside current defun invisible. | |
642 | The defun visible is the one that contains point or follows point. | |
643 | Use semantic tags to navigate." | |
644 | (interactive) | |
645 | (semantic-fetch-tags) | |
646 | (save-excursion | |
647 | (widen) | |
648 | (senator-end-of-defun) | |
649 | (let ((end (point))) | |
650 | (senator-beginning-of-defun) | |
651 | (narrow-to-region (point) end)))) | |
652 | ||
653 | (defun senator-mark-defun () | |
654 | "Put mark at end of this defun, point at beginning. | |
655 | The defun marked is the one that contains point or follows point. | |
656 | Use semantic tags to navigate." | |
657 | (interactive) | |
658 | (let ((origin (point)) | |
659 | (end (progn (senator-end-of-defun) (point))) | |
660 | (start (progn (senator-beginning-of-defun) (point)))) | |
661 | (goto-char origin) | |
662 | (push-mark (point)) | |
663 | (goto-char end) ;; end-of-defun | |
664 | (push-mark (point) nil t) | |
665 | (goto-char start) ;; beginning-of-defun | |
666 | (re-search-backward "^\n" (- (point) 1) t))) | |
667 | ||
668 | ;;; Tag Cut & Paste | |
669 | ||
670 | ;; To copy a tag, means to put a tag definition into the tag | |
671 | ;; ring. To kill a tag, put the tag into the tag ring AND put | |
672 | ;; the body of the tag into the kill-ring. | |
673 | ;; | |
674 | ;; To retrieve a killed tag's text, use C-y (yank), but to retrieve | |
675 | ;; the tag as a reference of some sort, use senator-yank-tag. | |
676 | ||
677 | (defvar senator-tag-ring (make-ring 20) | |
678 | "Ring of tags for use with cut and paste.") | |
679 | ||
680 | ;;;###autoload | |
681 | (defun senator-copy-tag () | |
682 | "Take the current tag, and place it in the tag ring." | |
683 | (interactive) | |
684 | (semantic-fetch-tags) | |
685 | (let ((ft (semantic-obtain-foreign-tag))) | |
686 | (when ft | |
687 | (ring-insert senator-tag-ring ft) | |
688 | (kill-ring-save (semantic-tag-start ft) (semantic-tag-end ft)) | |
2054a44c CY |
689 | (when (called-interactively-p 'interactive) |
690 | (message "Use C-y to yank text. \ | |
691 | Use `senator-yank-tag' for prototype insert."))) | |
8bf997ef CY |
692 | ft)) |
693 | ||
694 | ;;;###autoload | |
695 | (defun senator-kill-tag () | |
696 | "Take the current tag, place it in the tag ring, and kill it. | |
697 | Killing the tag removes the text for that tag, and places it into | |
698 | the kill ring. Retrieve that text with \\[yank]." | |
699 | (interactive) | |
700 | (let ((ct (senator-copy-tag))) ;; this handles the reparse for us. | |
701 | (kill-region (semantic-tag-start ct) | |
702 | (semantic-tag-end ct)) | |
2054a44c CY |
703 | (when (called-interactively-p 'interactive) |
704 | (message "Use C-y to yank text. \ | |
705 | Use `senator-yank-tag' for prototype insert.")))) | |
8bf997ef CY |
706 | |
707 | ;;;###autoload | |
708 | (defun senator-yank-tag () | |
709 | "Yank a tag from the tag ring. | |
9bf6c65c | 710 | The form the tag takes is different depending on where it is being |
8bf997ef CY |
711 | yanked to." |
712 | (interactive) | |
713 | (or (ring-empty-p senator-tag-ring) | |
714 | (let ((ft (ring-ref senator-tag-ring 0))) | |
715 | (semantic-foreign-tag-check ft) | |
716 | (semantic-insert-foreign-tag ft) | |
2054a44c | 717 | (when (called-interactively-p 'interactive) |
8bf997ef | 718 | (message "Use C-y to recover the yank the text of %s." |
2054a44c | 719 | (semantic-tag-name ft)))))) |
8bf997ef CY |
720 | |
721 | ;;;###autoload | |
722 | (defun senator-copy-tag-to-register (register &optional kill-flag) | |
723 | "Copy the current tag into REGISTER. | |
724 | Optional argument KILL-FLAG will delete the text of the tag to the | |
6a6b8e40 GM |
725 | kill ring. |
726 | ||
727 | Interactively, reads the register using `register-read-with-preview', | |
728 | if available." | |
729 | (interactive (list (if (fboundp 'register-read-with-preview) | |
730 | (register-read-with-preview "Tag to register: ") | |
731 | (read-char "Tag to register: ")) | |
732 | current-prefix-arg)) | |
8bf997ef CY |
733 | (semantic-fetch-tags) |
734 | (let ((ft (semantic-obtain-foreign-tag))) | |
735 | (when ft | |
08bb5ee2 LL |
736 | (set-register |
737 | register (registerv-make | |
738 | ft | |
739 | :insert-func #'semantic-insert-foreign-tag | |
740 | :jump-func (lambda (v) | |
741 | (switch-to-buffer (semantic-tag-buffer v)) | |
742 | (goto-char (semantic-tag-start v))))) | |
8bf997ef CY |
743 | (if kill-flag |
744 | (kill-region (semantic-tag-start ft) | |
745 | (semantic-tag-end ft)))))) | |
746 | ||
747 | ;;;###autoload | |
748 | (defun senator-transpose-tags-up () | |
9bf6c65c | 749 | "Transpose the current tag, and the preceding tag." |
8bf997ef CY |
750 | (interactive) |
751 | (semantic-fetch-tags) | |
752 | (let* ((current-tag (semantic-current-tag)) | |
753 | (prev-tag (save-excursion | |
754 | (goto-char (semantic-tag-start current-tag)) | |
755 | (semantic-find-tag-by-overlay-prev))) | |
756 | (ct-parent (semantic-find-tag-parent-by-overlay current-tag)) | |
757 | (pt-parent (semantic-find-tag-parent-by-overlay prev-tag))) | |
758 | (if (not (eq ct-parent pt-parent)) | |
759 | (error "Cannot transpose tags")) | |
760 | (let ((txt (buffer-substring (semantic-tag-start current-tag) | |
761 | (semantic-tag-end current-tag))) | |
762 | (line (count-lines (semantic-tag-start current-tag) | |
763 | (point))) | |
764 | (insert-point nil) | |
765 | ) | |
766 | (delete-region (semantic-tag-start current-tag) | |
767 | (semantic-tag-end current-tag)) | |
768 | (delete-blank-lines) | |
769 | (goto-char (semantic-tag-start prev-tag)) | |
770 | (setq insert-point (point)) | |
771 | (insert txt) | |
772 | (if (/= (current-column) 0) | |
773 | (insert "\n")) | |
774 | (insert "\n") | |
775 | (goto-char insert-point) | |
776 | (forward-line line) | |
777 | ))) | |
778 | ||
779 | ;;;###autoload | |
780 | (defun senator-transpose-tags-down () | |
781 | "Transpose the current tag, and the following tag." | |
782 | (interactive) | |
783 | (semantic-fetch-tags) | |
784 | (let* ((current-tag (semantic-current-tag)) | |
785 | (next-tag (save-excursion | |
786 | (goto-char (semantic-tag-end current-tag)) | |
787 | (semantic-find-tag-by-overlay-next))) | |
788 | (end-pt (point-marker)) | |
789 | ) | |
790 | (goto-char (semantic-tag-start next-tag)) | |
791 | (forward-char 1) | |
792 | (senator-transpose-tags-up) | |
793 | ;; I know that the above fcn deletes the next tag, so our pt marker | |
794 | ;; will be stable. | |
795 | (goto-char end-pt))) | |
796 | ||
797 | ;;; Using semantic search in isearch mode | |
798 | ||
799 | (defun senator-lazy-highlight-update () | |
800 | "Force lazy highlight update." | |
801 | (lazy-highlight-cleanup t) | |
802 | (set 'isearch-lazy-highlight-last-string nil) | |
803 | (setq isearch-adjusted t) | |
804 | (isearch-update)) | |
805 | ||
806 | ;; Recent versions of GNU Emacs allow to override the isearch search | |
807 | ;; function for special needs, and avoid to advice the built-in search | |
808 | ;; function :-) | |
809 | (defun senator-isearch-search-fun () | |
810 | "Return the function to use for the search. | |
811 | Use a senator search function when semantic isearch mode is enabled." | |
812 | (intern | |
813 | (concat (if senator-isearch-semantic-mode | |
814 | "senator-" | |
815 | "") | |
816 | (cond (isearch-word "word-") | |
817 | (isearch-regexp "re-") | |
818 | (t "")) | |
819 | "search-" | |
820 | (if isearch-forward | |
821 | "forward" | |
822 | "backward")))) | |
823 | ||
824 | (defun senator-isearch-toggle-semantic-mode () | |
825 | "Toggle semantic searching on or off in isearch mode." | |
826 | (interactive) | |
827 | (setq senator-isearch-semantic-mode | |
828 | (not senator-isearch-semantic-mode)) | |
829 | (if isearch-mode | |
830 | ;; force lazy highlight update | |
831 | (senator-lazy-highlight-update) | |
832 | (message "Isearch semantic mode %s" | |
833 | (if senator-isearch-semantic-mode | |
834 | "enabled" | |
835 | "disabled")))) | |
836 | ||
837 | (defvar senator-old-isearch-search-fun nil | |
838 | "Hold previous value of `isearch-search-fun-function'.") | |
839 | ||
840 | (defun senator-isearch-mode-hook () | |
841 | "Isearch mode hook to setup semantic searching." | |
842 | (if (and isearch-mode senator-isearch-semantic-mode) | |
843 | (progn | |
844 | ;; When `senator-isearch-semantic-mode' is on save the | |
845 | ;; previous `isearch-search-fun-function' and install the | |
846 | ;; senator one. | |
847 | (when (and (local-variable-p 'isearch-search-fun-function) | |
848 | (not (local-variable-p 'senator-old-isearch-search-fun))) | |
849 | (set (make-local-variable 'senator-old-isearch-search-fun) | |
850 | isearch-search-fun-function)) | |
851 | (set (make-local-variable 'isearch-search-fun-function) | |
852 | 'senator-isearch-search-fun)) | |
853 | ;; When `senator-isearch-semantic-mode' is off restore the | |
854 | ;; previous `isearch-search-fun-function'. | |
855 | (when (eq isearch-search-fun-function 'senator-isearch-search-fun) | |
856 | (if (local-variable-p 'senator-old-isearch-search-fun) | |
857 | (progn | |
858 | (set (make-local-variable 'isearch-search-fun-function) | |
859 | senator-old-isearch-search-fun) | |
860 | (kill-local-variable 'senator-old-isearch-search-fun)) | |
861 | (kill-local-variable 'isearch-search-fun-function))))) | |
862 | ||
863 | ;; (add-hook 'isearch-mode-hook 'senator-isearch-mode-hook) | |
864 | ;; (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook) | |
865 | ||
866 | ;; ;; Keyboard shortcut to toggle semantic search in isearch mode. | |
867 | ;; (define-key isearch-mode-map | |
868 | ;; [(control ?,)] | |
869 | ;; 'senator-isearch-toggle-semantic-mode) | |
870 | ||
8bf997ef CY |
871 | (provide 'semantic/senator) |
872 | ||
873 | ;; Local variables: | |
874 | ;; generated-autoload-file: "loaddefs.el" | |
8bf997ef CY |
875 | ;; generated-autoload-load-name: "semantic/senator" |
876 | ;; End: | |
877 | ||
878 | ;;; semantic/senator.el ends here |