Commit | Line | Data |
---|---|---|
55b522b2 | 1 | ;;; semantic/util.el --- Utilities for use with semantic tag tables |
a91e32bc | 2 | |
acaf905b | 3 | ;;; Copyright (C) 1999-2005, 2007-2012 Free Software Foundation, Inc. |
a91e32bc CY |
4 | |
5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
6 | ;; Keywords: syntax | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation, either version 3 of the License, or | |
13 | ;; (at your option) any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | ;;; Commentary: | |
24 | ;; | |
25 | ;; Semantic utility API for use with semantic tag tables. | |
26 | ;; | |
27 | ||
a91e32bc | 28 | (require 'semantic) |
996bc9bf | 29 | |
b90caf50 CY |
30 | (eval-when-compile |
31 | (require 'semantic/db-find) | |
32 | ;; For semantic-find-tags-by-class, semantic--find-tags-by-function, | |
33 | ;; and semantic-brute-find-tag-standard: | |
34 | (require 'semantic/find)) | |
35 | ||
996bc9bf CY |
36 | (declare-function data-debug-insert-stuff-list "data-debug") |
37 | (declare-function data-debug-insert-thing "data-debug") | |
b90caf50 | 38 | (declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt") |
a91e32bc CY |
39 | |
40 | ;;; Code: | |
41 | ||
42 | (defvar semantic-type-relation-separator-character '(".") | |
43 | "Character strings used to separate a parent/child relationship. | |
44 | This list of strings are used for displaying or finding separators | |
45 | in variable field dereferencing. The first character will be used for | |
46 | display. In C, a type field is separated like this: \"type.field\" | |
47 | thus, the character is a \".\". In C, and additional value of \"->\" | |
48 | would be in the list, so that \"type->field\" could be found.") | |
49 | (make-variable-buffer-local 'semantic-type-relation-separator-character) | |
50 | ||
51 | (defvar semantic-equivalent-major-modes nil | |
52 | "List of major modes which are considered equivalent. | |
53 | Equivalent modes share a parser, and a set of override methods. | |
54 | A value of nil means that the current major mode is the only one.") | |
55 | (make-variable-buffer-local 'semantic-equivalent-major-modes) | |
56 | ||
57 | ;; These semanticdb calls will throw warnings in the byte compiler. | |
58 | ;; Doing the right thing to make them available at compile time | |
59 | ;; really messes up the compilation sequence. | |
60 | (defun semantic-file-tag-table (file) | |
61 | "Return a tag table for FILE. | |
62 | If it is loaded, return the stream after making sure it's ok. | |
63 | If FILE is not loaded, check to see if `semanticdb' feature exists, | |
64 | and use it to get tags from files not in memory. | |
65 | If FILE is not loaded, and semanticdb is not available, find the file | |
66 | and parse it." | |
1eac105a CY |
67 | (save-match-data |
68 | (if (find-buffer-visiting file) | |
0816d744 | 69 | (with-current-buffer (find-buffer-visiting file) |
1eac105a CY |
70 | (semantic-fetch-tags)) |
71 | ;; File not loaded | |
72 | (if (and (require 'semantic/db-mode) | |
73 | (semanticdb-minor-mode-p)) | |
74 | ;; semanticdb is around, use it. | |
75 | (semanticdb-file-stream file) | |
76 | ;; Get the stream ourselves. | |
0816d744 | 77 | (with-current-buffer (find-file-noselect file) |
1eac105a | 78 | (semantic-fetch-tags)))))) |
a91e32bc CY |
79 | |
80 | (semantic-alias-obsolete 'semantic-file-token-stream | |
eefa91db | 81 | 'semantic-file-tag-table "23.2") |
a91e32bc CY |
82 | |
83 | (defun semantic-something-to-tag-table (something) | |
84 | "Convert SOMETHING into a semantic tag table. | |
85 | Something can be a tag with a valid BUFFER property, a tag table, a | |
86 | buffer, or a filename. If SOMETHING is nil return nil." | |
87 | (cond | |
88 | ;; A list of tags | |
89 | ((and (listp something) | |
90 | (semantic-tag-p (car something))) | |
91 | something) | |
92 | ;; A buffer | |
93 | ((bufferp something) | |
0816d744 | 94 | (with-current-buffer something |
a91e32bc CY |
95 | (semantic-fetch-tags))) |
96 | ;; A Tag: Get that tag's buffer | |
97 | ((and (semantic-tag-with-position-p something) | |
98 | (semantic-tag-in-buffer-p something)) | |
0816d744 | 99 | (with-current-buffer (semantic-tag-buffer something) |
a91e32bc CY |
100 | (semantic-fetch-tags))) |
101 | ;; Tag with a file name in it | |
102 | ((and (semantic-tag-p something) | |
103 | (semantic-tag-file-name something) | |
104 | (file-exists-p (semantic-tag-file-name something))) | |
105 | (semantic-file-tag-table | |
106 | (semantic-tag-file-name something))) | |
107 | ;; A file name | |
108 | ((and (stringp something) | |
109 | (file-exists-p something)) | |
110 | (semantic-file-tag-table something)) | |
111 | ;; A Semanticdb table | |
996bc9bf | 112 | ((and (featurep 'semantic/db) |
a91e32bc CY |
113 | (semanticdb-minor-mode-p) |
114 | (semanticdb-abstract-table-child-p something)) | |
115 | (semanticdb-refresh-table something) | |
116 | (semanticdb-get-tags something)) | |
117 | ;; Semanticdb find-results | |
996bc9bf | 118 | ((and (featurep 'semantic/db) |
a91e32bc | 119 | (semanticdb-minor-mode-p) |
996bc9bf | 120 | (require 'semantic/db-find) |
a91e32bc CY |
121 | (semanticdb-find-results-p something)) |
122 | (semanticdb-strip-find-results something)) | |
123 | ;; NOTE: This commented out since if a search result returns | |
124 | ;; empty, that empty would turn into everything on the next search. | |
125 | ;; Use the current buffer for nil | |
126 | ;; ((null something) | |
127 | ;; (semantic-fetch-tags)) | |
128 | ;; don't know what it is | |
129 | (t nil))) | |
130 | ||
131 | (semantic-alias-obsolete 'semantic-something-to-stream | |
eefa91db | 132 | 'semantic-something-to-tag-table "23.2") |
a91e32bc | 133 | |
a91e32bc CY |
134 | ;;; Completion APIs |
135 | ;; | |
136 | ;; These functions provide minibuffer reading/completion for lists of | |
137 | ;; nonterminals. | |
138 | (defvar semantic-read-symbol-history nil | |
139 | "History for a symbol read.") | |
140 | ||
141 | (defun semantic-read-symbol (prompt &optional default stream filter) | |
142 | "Read a symbol name from the user for the current buffer. | |
143 | PROMPT is the prompt to use. | |
144 | Optional arguments: | |
145 | DEFAULT is the default choice. If no default is given, one is read | |
146 | from under point. | |
147 | STREAM is the list of tokens to complete from. | |
148 | FILTER is provides a filter on the types of things to complete. | |
149 | FILTER must be a function to call on each element." | |
150 | (if (not default) (setq default (thing-at-point 'symbol))) | |
151 | (if (not stream) (setq stream (semantic-fetch-tags))) | |
152 | (setq stream | |
153 | (if filter | |
154 | (semantic--find-tags-by-function filter stream) | |
155 | (semantic-brute-find-tag-standard stream))) | |
156 | (if (and default (string-match ":" prompt)) | |
157 | (setq prompt | |
158 | (concat (substring prompt 0 (match-end 0)) | |
159 | " (default: " default ") "))) | |
160 | (completing-read prompt stream nil t "" | |
161 | 'semantic-read-symbol-history | |
162 | default)) | |
163 | ||
164 | (defun semantic-read-variable (prompt &optional default stream) | |
165 | "Read a variable name from the user for the current buffer. | |
166 | PROMPT is the prompt to use. | |
167 | Optional arguments: | |
168 | DEFAULT is the default choice. If no default is given, one is read | |
169 | from under point. | |
170 | STREAM is the list of tokens to complete from." | |
171 | (semantic-read-symbol | |
172 | prompt default | |
173 | (or (semantic-find-tags-by-class | |
174 | 'variable (or stream (current-buffer))) | |
175 | (error "No local variables")))) | |
176 | ||
177 | (defun semantic-read-function (prompt &optional default stream) | |
178 | "Read a function name from the user for the current buffer. | |
179 | PROMPT is the prompt to use. | |
180 | Optional arguments: | |
181 | DEFAULT is the default choice. If no default is given, one is read | |
182 | from under point. | |
183 | STREAM is the list of tags to complete from." | |
184 | (semantic-read-symbol | |
185 | prompt default | |
186 | (or (semantic-find-tags-by-class | |
187 | 'function (or stream (current-buffer))) | |
188 | (error "No local functions")))) | |
189 | ||
190 | (defun semantic-read-type (prompt &optional default stream) | |
191 | "Read a type name from the user for the current buffer. | |
192 | PROMPT is the prompt to use. | |
193 | Optional arguments: | |
194 | DEFAULT is the default choice. If no default is given, one is read | |
195 | from under point. | |
196 | STREAM is the list of tags to complete from." | |
197 | (semantic-read-symbol | |
198 | prompt default | |
199 | (or (semantic-find-tags-by-class | |
200 | 'type (or stream (current-buffer))) | |
201 | (error "No local types")))) | |
202 | ||
203 | \f | |
204 | ;;; Interactive Functions for | |
205 | ;; | |
206 | (defun semantic-describe-tag (&optional tag) | |
207 | "Describe TAG in the minibuffer. | |
208 | If TAG is nil, describe the tag under the cursor." | |
209 | (interactive) | |
210 | (if (not tag) (setq tag (semantic-current-tag))) | |
211 | (semantic-fetch-tags) | |
212 | (if tag (message (semantic-format-tag-summarize tag)))) | |
213 | ||
214 | \f | |
215 | ;;; Putting keys on tags. | |
216 | ;; | |
217 | (defun semantic-add-label (label value &optional tag) | |
218 | "Add a LABEL with VALUE on TAG. | |
219 | If TAG is not specified, use the tag at point." | |
220 | (interactive "sLabel: \nXValue (eval): ") | |
221 | (if (not tag) | |
222 | (progn | |
223 | (semantic-fetch-tags) | |
224 | (setq tag (semantic-current-tag)))) | |
225 | (semantic--tag-put-property tag (intern label) value) | |
226 | (message "Added label %s with value %S" label value)) | |
227 | ||
228 | (defun semantic-show-label (label &optional tag) | |
229 | "Show the value of LABEL on TAG. | |
230 | If TAG is not specified, use the tag at point." | |
231 | (interactive "sLabel: ") | |
232 | (if (not tag) | |
233 | (progn | |
234 | (semantic-fetch-tags) | |
235 | (setq tag (semantic-current-tag)))) | |
236 | (message "%s: %S" label (semantic--tag-get-property tag (intern label)))) | |
237 | ||
238 | \f | |
239 | ;;; Hacks | |
240 | ;; | |
241 | ;; Some hacks to help me test these functions | |
242 | (defun semantic-describe-buffer-var-helper (varsym buffer) | |
243 | "Display to standard out the value of VARSYM in BUFFER." | |
244 | (require 'data-debug) | |
0816d744 | 245 | (let ((value (with-current-buffer buffer |
a91e32bc CY |
246 | (symbol-value varsym)))) |
247 | (cond | |
248 | ((and (consp value) | |
249 | (< (length value) 10)) | |
250 | ;; Draw the list of things in the list. | |
251 | (princ (format " %s: #<list of %d items>\n" | |
252 | varsym (length value))) | |
253 | (data-debug-insert-stuff-list | |
254 | value " " ) | |
255 | ) | |
256 | (t | |
257 | ;; Else do a one-liner. | |
258 | (data-debug-insert-thing | |
259 | value " " (concat " " (symbol-name varsym) ": ")) | |
260 | )))) | |
261 | ||
262 | (defun semantic-describe-buffer () | |
263 | "Describe the semantic environment for the current buffer." | |
264 | (interactive) | |
265 | (let ((buff (current-buffer)) | |
266 | ) | |
267 | ||
268 | (with-output-to-temp-buffer (help-buffer) | |
2054a44c CY |
269 | (help-setup-xref (list #'semantic-describe-buffer) |
270 | (called-interactively-p 'interactive)) | |
a91e32bc CY |
271 | (with-current-buffer standard-output |
272 | (princ "Semantic Configuration in ") | |
273 | (princ (buffer-name buff)) | |
274 | (princ "\n\n") | |
275 | ||
276 | (princ "Buffer specific configuration items:\n") | |
277 | (let ((vars '(major-mode | |
278 | semantic-case-fold | |
dd9af436 | 279 | semantic-tag-expand-function |
a91e32bc CY |
280 | semantic-parser-name |
281 | semantic-parse-tree-state | |
282 | semantic-lex-analyzer | |
283 | semantic-lex-reset-hooks | |
dd9af436 | 284 | semantic-lex-syntax-modifications |
a91e32bc CY |
285 | ))) |
286 | (dolist (V vars) | |
287 | (semantic-describe-buffer-var-helper V buff))) | |
288 | ||
289 | (princ "\nGeneral configuration items:\n") | |
290 | (let ((vars '(semantic-inhibit-functions | |
29e1a603 CY |
291 | semantic-init-hook |
292 | semantic-init-db-hook | |
a91e32bc CY |
293 | semantic-unmatched-syntax-hook |
294 | semantic--before-fetch-tags-hook | |
295 | semantic-after-toplevel-bovinate-hook | |
296 | semantic-after-toplevel-cache-change-hook | |
297 | semantic-before-toplevel-cache-flush-hook | |
298 | semantic-dump-parse | |
dd9af436 CY |
299 | semantic-type-relation-separator-character |
300 | semantic-command-separation-character | |
62a81506 | 301 | semantic-new-buffer-fcn-was-run |
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 | ||
55b522b2 | 439 | ;;; semantic/util.el ends here |