Commit | Line | Data |
---|---|---|
55b522b2 | 1 | ;;; semantic/util.el --- Utilities for use with semantic tag tables |
a91e32bc CY |
2 | |
3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, | |
5df4f04c | 4 | ;;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. |
a91e32bc CY |
5 | |
6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
7 | ;; Keywords: syntax | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
13 | ;; the Free Software Foundation, either version 3 of the License, or | |
14 | ;; (at your option) any later version. | |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | ;;; Commentary: | |
25 | ;; | |
26 | ;; Semantic utility API for use with semantic tag tables. | |
27 | ;; | |
28 | ||
a91e32bc | 29 | (require 'semantic) |
996bc9bf | 30 | |
b90caf50 CY |
31 | (eval-when-compile |
32 | (require 'semantic/db-find) | |
33 | ;; For semantic-find-tags-by-class, semantic--find-tags-by-function, | |
34 | ;; and semantic-brute-find-tag-standard: | |
35 | (require 'semantic/find)) | |
36 | ||
996bc9bf CY |
37 | (declare-function data-debug-insert-stuff-list "data-debug") |
38 | (declare-function data-debug-insert-thing "data-debug") | |
b90caf50 | 39 | (declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt") |
a91e32bc CY |
40 | |
41 | ;;; Code: | |
42 | ||
43 | (defvar semantic-type-relation-separator-character '(".") | |
44 | "Character strings used to separate a parent/child relationship. | |
45 | This list of strings are used for displaying or finding separators | |
46 | in variable field dereferencing. The first character will be used for | |
47 | display. In C, a type field is separated like this: \"type.field\" | |
48 | thus, the character is a \".\". In C, and additional value of \"->\" | |
49 | would be in the list, so that \"type->field\" could be found.") | |
50 | (make-variable-buffer-local 'semantic-type-relation-separator-character) | |
51 | ||
52 | (defvar semantic-equivalent-major-modes nil | |
53 | "List of major modes which are considered equivalent. | |
54 | Equivalent modes share a parser, and a set of override methods. | |
55 | A value of nil means that the current major mode is the only one.") | |
56 | (make-variable-buffer-local 'semantic-equivalent-major-modes) | |
57 | ||
58 | ;; These semanticdb calls will throw warnings in the byte compiler. | |
59 | ;; Doing the right thing to make them available at compile time | |
60 | ;; really messes up the compilation sequence. | |
61 | (defun semantic-file-tag-table (file) | |
62 | "Return a tag table for FILE. | |
63 | If it is loaded, return the stream after making sure it's ok. | |
64 | If FILE is not loaded, check to see if `semanticdb' feature exists, | |
65 | and use it to get tags from files not in memory. | |
66 | If FILE is not loaded, and semanticdb is not available, find the file | |
67 | and parse it." | |
1eac105a CY |
68 | (save-match-data |
69 | (if (find-buffer-visiting file) | |
0816d744 | 70 | (with-current-buffer (find-buffer-visiting file) |
1eac105a CY |
71 | (semantic-fetch-tags)) |
72 | ;; File not loaded | |
73 | (if (and (require 'semantic/db-mode) | |
74 | (semanticdb-minor-mode-p)) | |
75 | ;; semanticdb is around, use it. | |
76 | (semanticdb-file-stream file) | |
77 | ;; Get the stream ourselves. | |
0816d744 | 78 | (with-current-buffer (find-file-noselect file) |
1eac105a | 79 | (semantic-fetch-tags)))))) |
a91e32bc CY |
80 | |
81 | (semantic-alias-obsolete 'semantic-file-token-stream | |
eefa91db | 82 | 'semantic-file-tag-table "23.2") |
a91e32bc CY |
83 | |
84 | (defun semantic-something-to-tag-table (something) | |
85 | "Convert SOMETHING into a semantic tag table. | |
86 | Something can be a tag with a valid BUFFER property, a tag table, a | |
87 | buffer, or a filename. If SOMETHING is nil return nil." | |
88 | (cond | |
89 | ;; A list of tags | |
90 | ((and (listp something) | |
91 | (semantic-tag-p (car something))) | |
92 | something) | |
93 | ;; A buffer | |
94 | ((bufferp something) | |
0816d744 | 95 | (with-current-buffer something |
a91e32bc CY |
96 | (semantic-fetch-tags))) |
97 | ;; A Tag: Get that tag's buffer | |
98 | ((and (semantic-tag-with-position-p something) | |
99 | (semantic-tag-in-buffer-p something)) | |
0816d744 | 100 | (with-current-buffer (semantic-tag-buffer something) |
a91e32bc CY |
101 | (semantic-fetch-tags))) |
102 | ;; Tag with a file name in it | |
103 | ((and (semantic-tag-p something) | |
104 | (semantic-tag-file-name something) | |
105 | (file-exists-p (semantic-tag-file-name something))) | |
106 | (semantic-file-tag-table | |
107 | (semantic-tag-file-name something))) | |
108 | ;; A file name | |
109 | ((and (stringp something) | |
110 | (file-exists-p something)) | |
111 | (semantic-file-tag-table something)) | |
112 | ;; A Semanticdb table | |
996bc9bf | 113 | ((and (featurep 'semantic/db) |
a91e32bc CY |
114 | (semanticdb-minor-mode-p) |
115 | (semanticdb-abstract-table-child-p something)) | |
116 | (semanticdb-refresh-table something) | |
117 | (semanticdb-get-tags something)) | |
118 | ;; Semanticdb find-results | |
996bc9bf | 119 | ((and (featurep 'semantic/db) |
a91e32bc | 120 | (semanticdb-minor-mode-p) |
996bc9bf | 121 | (require 'semantic/db-find) |
a91e32bc CY |
122 | (semanticdb-find-results-p something)) |
123 | (semanticdb-strip-find-results something)) | |
124 | ;; NOTE: This commented out since if a search result returns | |
125 | ;; empty, that empty would turn into everything on the next search. | |
126 | ;; Use the current buffer for nil | |
127 | ;; ((null something) | |
128 | ;; (semantic-fetch-tags)) | |
129 | ;; don't know what it is | |
130 | (t nil))) | |
131 | ||
132 | (semantic-alias-obsolete 'semantic-something-to-stream | |
eefa91db | 133 | 'semantic-something-to-tag-table "23.2") |
a91e32bc | 134 | |
a91e32bc CY |
135 | ;;; Completion APIs |
136 | ;; | |
137 | ;; These functions provide minibuffer reading/completion for lists of | |
138 | ;; nonterminals. | |
139 | (defvar semantic-read-symbol-history nil | |
140 | "History for a symbol read.") | |
141 | ||
142 | (defun semantic-read-symbol (prompt &optional default stream filter) | |
143 | "Read a symbol name from the user for the current buffer. | |
144 | PROMPT is the prompt to use. | |
145 | Optional arguments: | |
146 | DEFAULT is the default choice. If no default is given, one is read | |
147 | from under point. | |
148 | STREAM is the list of tokens to complete from. | |
149 | FILTER is provides a filter on the types of things to complete. | |
150 | FILTER must be a function to call on each element." | |
151 | (if (not default) (setq default (thing-at-point 'symbol))) | |
152 | (if (not stream) (setq stream (semantic-fetch-tags))) | |
153 | (setq stream | |
154 | (if filter | |
155 | (semantic--find-tags-by-function filter stream) | |
156 | (semantic-brute-find-tag-standard stream))) | |
157 | (if (and default (string-match ":" prompt)) | |
158 | (setq prompt | |
159 | (concat (substring prompt 0 (match-end 0)) | |
160 | " (default: " default ") "))) | |
161 | (completing-read prompt stream nil t "" | |
162 | 'semantic-read-symbol-history | |
163 | default)) | |
164 | ||
165 | (defun semantic-read-variable (prompt &optional default stream) | |
166 | "Read a variable name from the user for the current buffer. | |
167 | PROMPT is the prompt to use. | |
168 | Optional arguments: | |
169 | DEFAULT is the default choice. If no default is given, one is read | |
170 | from under point. | |
171 | STREAM is the list of tokens to complete from." | |
172 | (semantic-read-symbol | |
173 | prompt default | |
174 | (or (semantic-find-tags-by-class | |
175 | 'variable (or stream (current-buffer))) | |
176 | (error "No local variables")))) | |
177 | ||
178 | (defun semantic-read-function (prompt &optional default stream) | |
179 | "Read a function name from the user for the current buffer. | |
180 | PROMPT is the prompt to use. | |
181 | Optional arguments: | |
182 | DEFAULT is the default choice. If no default is given, one is read | |
183 | from under point. | |
184 | STREAM is the list of tags to complete from." | |
185 | (semantic-read-symbol | |
186 | prompt default | |
187 | (or (semantic-find-tags-by-class | |
188 | 'function (or stream (current-buffer))) | |
189 | (error "No local functions")))) | |
190 | ||
191 | (defun semantic-read-type (prompt &optional default stream) | |
192 | "Read a type name from the user for the current buffer. | |
193 | PROMPT is the prompt to use. | |
194 | Optional arguments: | |
195 | DEFAULT is the default choice. If no default is given, one is read | |
196 | from under point. | |
197 | STREAM is the list of tags to complete from." | |
198 | (semantic-read-symbol | |
199 | prompt default | |
200 | (or (semantic-find-tags-by-class | |
201 | 'type (or stream (current-buffer))) | |
202 | (error "No local types")))) | |
203 | ||
204 | \f | |
205 | ;;; Interactive Functions for | |
206 | ;; | |
207 | (defun semantic-describe-tag (&optional tag) | |
208 | "Describe TAG in the minibuffer. | |
209 | If TAG is nil, describe the tag under the cursor." | |
210 | (interactive) | |
211 | (if (not tag) (setq tag (semantic-current-tag))) | |
212 | (semantic-fetch-tags) | |
213 | (if tag (message (semantic-format-tag-summarize tag)))) | |
214 | ||
215 | \f | |
216 | ;;; Putting keys on tags. | |
217 | ;; | |
218 | (defun semantic-add-label (label value &optional tag) | |
219 | "Add a LABEL with VALUE on TAG. | |
220 | If TAG is not specified, use the tag at point." | |
221 | (interactive "sLabel: \nXValue (eval): ") | |
222 | (if (not tag) | |
223 | (progn | |
224 | (semantic-fetch-tags) | |
225 | (setq tag (semantic-current-tag)))) | |
226 | (semantic--tag-put-property tag (intern label) value) | |
227 | (message "Added label %s with value %S" label value)) | |
228 | ||
229 | (defun semantic-show-label (label &optional tag) | |
230 | "Show the value of LABEL on TAG. | |
231 | If TAG is not specified, use the tag at point." | |
232 | (interactive "sLabel: ") | |
233 | (if (not tag) | |
234 | (progn | |
235 | (semantic-fetch-tags) | |
236 | (setq tag (semantic-current-tag)))) | |
237 | (message "%s: %S" label (semantic--tag-get-property tag (intern label)))) | |
238 | ||
239 | \f | |
240 | ;;; Hacks | |
241 | ;; | |
242 | ;; Some hacks to help me test these functions | |
243 | (defun semantic-describe-buffer-var-helper (varsym buffer) | |
244 | "Display to standard out the value of VARSYM in BUFFER." | |
245 | (require 'data-debug) | |
0816d744 | 246 | (let ((value (with-current-buffer buffer |
a91e32bc CY |
247 | (symbol-value varsym)))) |
248 | (cond | |
249 | ((and (consp value) | |
250 | (< (length value) 10)) | |
251 | ;; Draw the list of things in the list. | |
252 | (princ (format " %s: #<list of %d items>\n" | |
253 | varsym (length value))) | |
254 | (data-debug-insert-stuff-list | |
255 | value " " ) | |
256 | ) | |
257 | (t | |
258 | ;; Else do a one-liner. | |
259 | (data-debug-insert-thing | |
260 | value " " (concat " " (symbol-name varsym) ": ")) | |
261 | )))) | |
262 | ||
263 | (defun semantic-describe-buffer () | |
264 | "Describe the semantic environment for the current buffer." | |
265 | (interactive) | |
266 | (let ((buff (current-buffer)) | |
267 | ) | |
268 | ||
269 | (with-output-to-temp-buffer (help-buffer) | |
2054a44c CY |
270 | (help-setup-xref (list #'semantic-describe-buffer) |
271 | (called-interactively-p 'interactive)) | |
a91e32bc CY |
272 | (with-current-buffer standard-output |
273 | (princ "Semantic Configuration in ") | |
274 | (princ (buffer-name buff)) | |
275 | (princ "\n\n") | |
276 | ||
277 | (princ "Buffer specific configuration items:\n") | |
278 | (let ((vars '(major-mode | |
279 | semantic-case-fold | |
dd9af436 | 280 | semantic-tag-expand-function |
a91e32bc CY |
281 | semantic-parser-name |
282 | semantic-parse-tree-state | |
283 | semantic-lex-analyzer | |
284 | semantic-lex-reset-hooks | |
dd9af436 | 285 | semantic-lex-syntax-modifications |
a91e32bc CY |
286 | ))) |
287 | (dolist (V vars) | |
288 | (semantic-describe-buffer-var-helper V buff))) | |
289 | ||
290 | (princ "\nGeneral configuration items:\n") | |
291 | (let ((vars '(semantic-inhibit-functions | |
29e1a603 CY |
292 | semantic-init-hook |
293 | semantic-init-db-hook | |
a91e32bc CY |
294 | semantic-unmatched-syntax-hook |
295 | semantic--before-fetch-tags-hook | |
296 | semantic-after-toplevel-bovinate-hook | |
297 | semantic-after-toplevel-cache-change-hook | |
298 | semantic-before-toplevel-cache-flush-hook | |
299 | semantic-dump-parse | |
dd9af436 CY |
300 | semantic-type-relation-separator-character |
301 | semantic-command-separation-character | |
a91e32bc CY |
302 | ))) |
303 | (dolist (V vars) | |
304 | (semantic-describe-buffer-var-helper V buff))) | |
305 | ||
306 | (princ "\n\n") | |
307 | (mode-local-describe-bindings-2 buff) | |
308 | ))) | |
309 | ) | |
310 | ||
a91e32bc CY |
311 | (defun semantic-assert-valid-token (tok) |
312 | "Assert that TOK is a valid token." | |
313 | (if (semantic-tag-p tok) | |
314 | (if (semantic-tag-with-position-p tok) | |
315 | (let ((o (semantic-tag-overlay tok))) | |
316 | (if (and (semantic-overlay-p o) | |
317 | (not (semantic-overlay-live-p o))) | |
318 | (let ((debug-on-error t)) | |
319 | (error "Tag %s is invalid!" (semantic-tag-name tok))) | |
320 | ;; else, tag is OK. | |
321 | )) | |
322 | ;; Positionless tags are also ok. | |
323 | ) | |
324 | (let ((debug-on-error t)) | |
325 | (error "Not a semantic tag: %S" tok)))) | |
326 | ||
327 | (defun semantic-sanity-check (&optional cache over notfirst) | |
328 | "Perform a sanity check on the current buffer. | |
329 | The buffer's set of overlays, and those overlays found via the cache | |
330 | are verified against each other. | |
331 | CACHE, and OVER are the semantic cache, and the overlay list. | |
332 | NOTFIRST indicates that this was not the first call in the recursive use." | |
333 | (interactive) | |
334 | (if (and (not cache) (not over) (not notfirst)) | |
335 | (setq cache semantic--buffer-cache | |
336 | over (semantic-overlays-in (point-min) (point-max)))) | |
337 | (while cache | |
338 | (let ((chil (semantic-tag-components-with-overlays (car cache)))) | |
339 | (if (not (memq (semantic-tag-overlay (car cache)) over)) | |
340 | (message "Tag %s not in buffer overlay list." | |
341 | (semantic-format-tag-concise-prototype (car cache)))) | |
342 | (setq over (delq (semantic-tag-overlay (car cache)) over)) | |
343 | (setq over (semantic-sanity-check chil over t)) | |
344 | (setq cache (cdr cache)))) | |
345 | (if (not notfirst) | |
346 | ;; Strip out all overlays which aren't semantic overlays | |
347 | (let ((o nil)) | |
348 | (while over | |
349 | (when (and (semantic-overlay-get (car over) 'semantic) | |
350 | (not (eq (semantic-overlay-get (car over) 'semantic) | |
351 | 'unmatched))) | |
352 | (setq o (cons (car over) o))) | |
353 | (setq over (cdr over))) | |
dd9af436 CY |
354 | (when (called-interactively-p 'any) |
355 | (message "Remaining overlays: %S" o)))) | |
a91e32bc CY |
356 | over) |
357 | ||
af7b5a91 CY |
358 | ;;; Interactive commands (from Senator). |
359 | ||
360 | ;; The Senator library from upstream CEDET is not included in the | |
361 | ;; built-in version of Emacs. The plan is to fold it into the | |
362 | ;; different parts of CEDET and Emacs, so that it works | |
363 | ;; "transparently". Here are some interactive commands based on | |
364 | ;; Senator. | |
365 | ||
29e1a603 CY |
366 | ;; Symbol completion |
367 | ||
af7b5a91 CY |
368 | (defun semantic-find-tag-for-completion (prefix) |
369 | "Find all tags with name starting with PREFIX. | |
370 | This uses `semanticdb' when available." | |
371 | (let (result ctxt) | |
29e1a603 | 372 | ;; Try the Semantic analyzer |
af7b5a91 CY |
373 | (condition-case nil |
374 | (and (featurep 'semantic/analyze) | |
375 | (setq ctxt (semantic-analyze-current-context)) | |
376 | (setq result (semantic-analyze-possible-completions ctxt))) | |
377 | (error nil)) | |
378 | (or result | |
379 | ;; If the analyzer fails, then go into boring completion. | |
b90caf50 CY |
380 | (if (and (featurep 'semantic/db) |
381 | (semanticdb-minor-mode-p) | |
382 | (require 'semantic/db-find)) | |
af7b5a91 CY |
383 | (semanticdb-fast-strip-find-results |
384 | (semanticdb-deep-find-tags-for-completion prefix)) | |
385 | (semantic-deep-find-tags-for-completion prefix (current-buffer)))))) | |
386 | ||
387 | (defun semantic-complete-symbol (&optional predicate) | |
388 | "Complete the symbol under point, using Semantic facilities. | |
389 | When called from a program, optional arg PREDICATE is a predicate | |
390 | determining which symbols are considered." | |
391 | (interactive) | |
b90caf50 | 392 | (require 'semantic/ctxt) |
af7b5a91 CY |
393 | (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds |
394 | (point))))) | |
395 | (pattern (regexp-quote (buffer-substring start (point)))) | |
396 | collection completion) | |
397 | (when start | |
398 | (if (and semantic--completion-cache | |
399 | (eq (nth 0 semantic--completion-cache) (current-buffer)) | |
400 | (= (nth 1 semantic--completion-cache) start) | |
401 | (save-excursion | |
402 | (goto-char start) | |
403 | (looking-at (nth 3 semantic--completion-cache)))) | |
404 | ;; Use cached value. | |
405 | (setq collection (nthcdr 4 semantic--completion-cache)) | |
406 | ;; Perform new query. | |
407 | (setq collection (semantic-find-tag-for-completion pattern)) | |
408 | (setq semantic--completion-cache | |
409 | (append (list (current-buffer) start 0 pattern) | |
410 | collection)))) | |
411 | (if (null collection) | |
412 | (let ((str (if pattern (format " for \"%s\"" pattern) ""))) | |
413 | (if (window-minibuffer-p (selected-window)) | |
414 | (minibuffer-message (format " [No completions%s]" str)) | |
415 | (message "Can't find completion%s" str))) | |
416 | (setq completion (try-completion pattern collection predicate)) | |
417 | (if (string= pattern completion) | |
418 | (let ((list (all-completions pattern collection predicate))) | |
419 | (setq list (sort list 'string<)) | |
420 | (if (> (length list) 1) | |
421 | (with-output-to-temp-buffer "*Completions*" | |
422 | (display-completion-list list pattern)) | |
423 | ;; Bury any out-of-date completions buffer. | |
424 | (let ((win (get-buffer-window "*Completions*" 0))) | |
425 | (if win (with-selected-window win (bury-buffer)))))) | |
426 | ;; Exact match | |
427 | (delete-region start (point)) | |
428 | (insert completion) | |
429 | ;; Bury any out-of-date completions buffer. | |
430 | (let ((win (get-buffer-window "*Completions*" 0))) | |
431 | (if win (with-selected-window win (bury-buffer)))))))) | |
432 | ||
a91e32bc CY |
433 | (provide 'semantic/util) |
434 | ||
435 | ;;; Minor modes | |
436 | ;; | |
437 | (require 'semantic/util-modes) | |
438 | ||
3999968a | 439 | ;; arch-tag: eaa7808d-83b9-43fe-adf0-4fb742dcb956 |
55b522b2 | 440 | ;;; semantic/util.el ends here |