Commit | Line | Data |
---|---|---|
20bfd709 CY |
1 | ;;; semantic/sb.el --- Semantic tag display for speedbar |
2 | ||
ab422c4d | 3 | ;; Copyright (C) 1999-2013 Free Software Foundation, Inc. |
20bfd709 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 | ;; Convert a tag table into speedbar buttons. | |
26 | ||
27 | ;;; TODO: | |
28 | ||
29 | ;; Use semanticdb to find which semanticdb-table is being used for each | |
30 | ;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call | |
31 | ;; children with the new `with-mode-local' instead. | |
32 | ||
33 | (require 'semantic) | |
996bc9bf CY |
34 | (require 'semantic/format) |
35 | (require 'semantic/sort) | |
20bfd709 CY |
36 | (require 'semantic/util) |
37 | (require 'speedbar) | |
b90caf50 | 38 | (declare-function semanticdb-file-stream "semantic/db") |
20bfd709 CY |
39 | |
40 | (defcustom semantic-sb-autoexpand-length 1 | |
41 | "*Length of a semantic bucket to autoexpand in place. | |
9bf6c65c | 42 | This will replace the named bucket that would have usually occurred here." |
20bfd709 CY |
43 | :group 'speedbar |
44 | :type 'integer) | |
45 | ||
e8cc7880 DE |
46 | (defvar semantic-sb-filter-tags-of-class '(code) |
47 | "Tags classes to not display in speedbar. | |
48 | Make this buffer local for modes that have different types of tags | |
49 | that should be ignored.") | |
50 | ||
20bfd709 CY |
51 | (defcustom semantic-sb-button-format-tag-function 'semantic-format-tag-abbreviate |
52 | "*Function called to create the text for a but from a token." | |
53 | :group 'speedbar | |
54 | :type semantic-format-tag-custom-list) | |
55 | ||
56 | (defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize | |
57 | "*Function called to create the text for info display from a token." | |
58 | :group 'speedbar | |
59 | :type semantic-format-tag-custom-list) | |
60 | ||
61 | ;;; Code: | |
62 | ;; | |
63 | ||
64 | ;;; Buffer setting for correct mode manipulation. | |
65 | (defun semantic-sb-tag-set-buffer (tag) | |
66 | "Set the current buffer to something associated with TAG. | |
67 | use the `speedbar-line-file' to get this info if needed." | |
68 | (if (semantic-tag-buffer tag) | |
69 | (set-buffer (semantic-tag-buffer tag)) | |
70 | (let ((f (speedbar-line-file))) | |
71 | (set-buffer (find-file-noselect f))))) | |
72 | ||
73 | (defmacro semantic-sb-with-tag-buffer (tag &rest forms) | |
74 | "Set the current buffer to the origin of TAG and execute FORMS. | |
75 | Restore the old current buffer when completed." | |
76 | `(save-excursion | |
77 | (semantic-sb-tag-set-buffer ,tag) | |
78 | ,@forms)) | |
79 | (put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1) | |
80 | ||
81 | ;;; Button Generation | |
82 | ;; | |
83 | ;; Here are some button groups: | |
84 | ;; | |
85 | ;; +> Function () | |
86 | ;; @ return_type | |
87 | ;; +( arg1 | |
88 | ;; +| arg2 | |
89 | ;; +) arg3 | |
90 | ;; | |
91 | ;; +> Variable[1] = | |
92 | ;; @ type | |
93 | ;; = default value | |
94 | ;; | |
53964682 | 95 | ;; +> keyword Type |
20bfd709 CY |
96 | ;; +> type part |
97 | ;; | |
98 | ;; +> -> click to see additional information | |
99 | ||
100 | (define-overloadable-function semantic-sb-tag-children-to-expand (tag) | |
101 | "For TAG, return a list of children that TAG expands to. | |
102 | If this returns a value, then a +> icon is created. | |
103 | If it returns nil, then a => icon is created.") | |
104 | ||
105 | (defun semantic-sb-tag-children-to-expand-default (tag) | |
106 | "For TAG, the children for type, variable, and function classes." | |
107 | (semantic-sb-with-tag-buffer tag | |
108 | (semantic-tag-components tag))) | |
109 | ||
110 | (defun semantic-sb-one-button (tag depth &optional prefix) | |
111 | "Insert TAG as a speedbar button at DEPTH. | |
112 | Optional PREFIX is used to specify special marker characters." | |
113 | (let* ((class (semantic-tag-class tag)) | |
114 | (edata (semantic-sb-tag-children-to-expand tag)) | |
115 | (type (semantic-tag-type tag)) | |
116 | (abbrev (semantic-sb-with-tag-buffer tag | |
117 | (funcall semantic-sb-button-format-tag-function tag))) | |
118 | (start (point)) | |
119 | (end (progn | |
120 | (insert (int-to-string depth) ":") | |
121 | (point)))) | |
122 | (insert-char ? (1- depth) nil) | |
123 | (put-text-property end (point) 'invisible nil) | |
124 | ;; take care of edata = (nil) -- a yucky but hard to clean case | |
125 | (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata)))) | |
126 | (setq edata nil)) | |
127 | (if (and (not edata) | |
128 | (member class '(variable function)) | |
129 | type) | |
130 | (setq edata t)) | |
131 | ;; types are a bit unique. Variable types can have special meaning. | |
132 | (if edata | |
133 | (speedbar-insert-button (if prefix (concat " +" prefix) " +>") | |
134 | 'speedbar-button-face | |
135 | 'speedbar-highlight-face | |
136 | 'semantic-sb-show-extra | |
137 | tag t) | |
138 | (speedbar-insert-button (if prefix (concat " " prefix) " =>") | |
139 | nil nil nil nil t)) | |
140 | (speedbar-insert-button abbrev | |
141 | 'speedbar-tag-face | |
142 | 'speedbar-highlight-face | |
143 | 'semantic-sb-token-jump | |
144 | tag t) | |
145 | ;; This is very bizarre. When this was just after the insertion | |
146 | ;; of the depth: text, the : would get erased, but only for the | |
147 | ;; auto-expanded short- buckets. Move back for a later version | |
148 | ;; version of Emacs 21 CVS | |
149 | (put-text-property start end 'invisible t) | |
150 | )) | |
151 | ||
152 | (defun semantic-sb-speedbar-data-line (depth button text &optional | |
153 | text-fun text-data) | |
154 | "Insert a semantic token data element. | |
155 | DEPTH is the current depth. BUTTON is the text for the button. | |
156 | TEXT is the actual info with TEXT-FUN to occur when it happens. | |
157 | Argument TEXT-DATA is the token data to pass to TEXT-FUN." | |
158 | (let ((start (point)) | |
159 | (end (progn | |
160 | (insert (int-to-string depth) ":") | |
161 | (point)))) | |
162 | (put-text-property start end 'invisible t) | |
163 | (insert-char ? depth nil) | |
164 | (put-text-property end (point) 'invisible nil) | |
165 | (speedbar-insert-button button nil nil nil nil t) | |
166 | (speedbar-insert-button text | |
167 | 'speedbar-tag-face | |
168 | (if text-fun 'speedbar-highlight-face) | |
169 | text-fun text-data t) | |
170 | )) | |
171 | ||
172 | (defun semantic-sb-maybe-token-to-button (obj indent &optional | |
173 | prefix modifiers) | |
174 | "Convert OBJ, which was returned from the semantic parser, into a button. | |
175 | This OBJ might be a plain string (simple type or untyped variable) | |
176 | or a complete tag. | |
177 | Argument INDENT is the indentation used when making the button. | |
178 | Optional PREFIX is the character to use when marking the line. | |
179 | Optional MODIFIERS is additional text needed for variables." | |
180 | (let ((myprefix (or prefix ">"))) | |
181 | (if (stringp obj) | |
182 | (semantic-sb-speedbar-data-line indent myprefix obj) | |
183 | (if (listp obj) | |
184 | (progn | |
185 | (if (and (stringp (car obj)) | |
186 | (= (length obj) 1)) | |
187 | (semantic-sb-speedbar-data-line indent myprefix | |
188 | (concat | |
189 | (car obj) | |
190 | (or modifiers ""))) | |
191 | (semantic-sb-one-button obj indent prefix))))))) | |
192 | ||
193 | (defun semantic-sb-insert-details (tag indent) | |
194 | "Insert details about TAG at level INDENT." | |
195 | (let ((tt (semantic-tag-class tag)) | |
196 | (type (semantic-tag-type tag))) | |
197 | (cond ((eq tt 'type) | |
198 | (let ((parts (semantic-tag-type-members tag)) | |
199 | (newparts nil)) | |
200 | ;; Lets expect PARTS to be a list of either strings, | |
201 | ;; or variable tokens. | |
202 | (when (semantic-tag-p (car parts)) | |
203 | ;; Bucketize into groups | |
204 | (semantic-sb-with-tag-buffer (car parts) | |
205 | (setq newparts (semantic-bucketize parts))) | |
206 | (when (> (length newparts) semantic-sb-autoexpand-length) | |
207 | ;; More than one bucket, insert inline | |
208 | (semantic-sb-insert-tag-table (1- indent) newparts) | |
209 | (setq parts nil)) | |
210 | ;; Dump the strings in. | |
211 | (while parts | |
212 | (semantic-sb-maybe-token-to-button (car parts) indent) | |
213 | (setq parts (cdr parts)))))) | |
214 | ((eq tt 'variable) | |
215 | (if type | |
216 | (semantic-sb-maybe-token-to-button type indent "@")) | |
217 | (let ((default (semantic-tag-variable-default tag))) | |
218 | (if default | |
219 | (semantic-sb-maybe-token-to-button default indent "="))) | |
220 | ) | |
221 | ((eq tt 'function) | |
222 | (if type | |
223 | (semantic-sb-speedbar-data-line | |
224 | indent "@" | |
225 | (if (stringp type) type | |
226 | (semantic-tag-name type)))) | |
227 | ;; Arguments to the function | |
228 | (let ((args (semantic-tag-function-arguments tag))) | |
229 | (if (and args (car args)) | |
230 | (progn | |
231 | (semantic-sb-maybe-token-to-button (car args) indent "(") | |
232 | (setq args (cdr args)) | |
233 | (while (> (length args) 1) | |
234 | (semantic-sb-maybe-token-to-button (car args) | |
235 | indent | |
236 | "|") | |
237 | (setq args (cdr args))) | |
238 | (if args | |
239 | (semantic-sb-maybe-token-to-button | |
240 | (car args) indent ")")) | |
241 | )))) | |
242 | (t | |
243 | (let ((components | |
244 | (save-excursion | |
245 | (when (and (semantic-tag-overlay tag) | |
246 | (semantic-tag-buffer tag)) | |
247 | (set-buffer (semantic-tag-buffer tag))) | |
248 | (semantic-sb-tag-children-to-expand tag)))) | |
249 | ;; Well, it wasn't one of the many things we expect. | |
250 | ;; Lets just insert them in with no decoration. | |
251 | (while components | |
252 | (semantic-sb-one-button (car components) indent) | |
253 | (setq components (cdr components))) | |
254 | )) | |
255 | ) | |
256 | )) | |
257 | ||
258 | (defun semantic-sb-detail-parent () | |
259 | "Return the first parent token of the current line that includes a location." | |
260 | (save-excursion | |
261 | (beginning-of-line) | |
262 | (let ((dep (if (looking-at "[0-9]+:") | |
263 | (1- (string-to-number (match-string 0))) | |
264 | 0))) | |
265 | (re-search-backward (concat "^" | |
266 | (int-to-string dep) | |
267 | ":") | |
268 | nil t)) | |
269 | (beginning-of-line) | |
270 | (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$") | |
271 | (let ((prop nil)) | |
272 | (goto-char (match-beginning 1)) | |
273 | (setq prop (get-text-property (point) 'speedbar-token)) | |
274 | (if (semantic-tag-with-position-p prop) | |
275 | prop | |
276 | (semantic-sb-detail-parent))) | |
277 | nil))) | |
278 | ||
279 | (defun semantic-sb-show-extra (text token indent) | |
280 | "Display additional information about the token as an expansion. | |
281 | TEXT TOKEN and INDENT are the details." | |
282 | (cond ((string-match "+" text) ;we have to expand this file | |
283 | (speedbar-change-expand-button-char ?-) | |
284 | (speedbar-with-writable | |
285 | (save-excursion | |
286 | (end-of-line) (forward-char 1) | |
287 | (save-restriction | |
288 | (narrow-to-region (point) (point)) | |
289 | ;; Add in stuff specific to this type of token. | |
290 | (semantic-sb-insert-details token (1+ indent)))))) | |
291 | ((string-match "-" text) ;we have to contract this node | |
292 | (speedbar-change-expand-button-char ?+) | |
293 | (speedbar-delete-subblock indent)) | |
294 | (t (error "Ooops... not sure what to do"))) | |
295 | (speedbar-center-buffer-smartly)) | |
296 | ||
297 | (defun semantic-sb-token-jump (text token indent) | |
298 | "Jump to the location specified in token. | |
299 | TEXT TOKEN and INDENT are the details." | |
300 | (let ((file | |
301 | (or | |
302 | (cond ((fboundp 'speedbar-line-path) | |
303 | (speedbar-line-directory indent)) | |
304 | ((fboundp 'speedbar-line-directory) | |
305 | (speedbar-line-directory indent))) | |
306 | ;; If speedbar cannot figure this out, extract the filename from | |
307 | ;; the token. True for Analysis mode. | |
308 | (semantic-tag-file-name token))) | |
309 | (parent (semantic-sb-detail-parent))) | |
310 | (let ((f (selected-frame))) | |
311 | (dframe-select-attached-frame speedbar-frame) | |
312 | (run-hooks 'speedbar-before-visiting-tag-hook) | |
313 | (select-frame f)) | |
314 | ;; Sometimes FILE may be nil here. If you are debugging a problem | |
315 | ;; when this happens, go back and figure out why FILE is nil and try | |
316 | ;; and fix the source. | |
317 | (speedbar-find-file-in-frame file) | |
318 | (save-excursion (speedbar-stealthy-updates)) | |
319 | (semantic-go-to-tag token parent) | |
320 | (switch-to-buffer (current-buffer)) | |
da6062e6 | 321 | ;; Reset the timer with a new timeout when clicking a file |
20bfd709 CY |
322 | ;; in case the user was navigating directories, we can cancel |
323 | ;; that other timer. | |
324 | ;; (speedbar-set-timer dframe-update-speed) | |
325 | ;;(recenter) | |
326 | (speedbar-maybee-jump-to-attached-frame) | |
327 | (run-hooks 'speedbar-visiting-tag-hook))) | |
328 | ||
329 | (defun semantic-sb-expand-group (text token indent) | |
330 | "Expand a group which has semantic tokens. | |
331 | TEXT TOKEN and INDENT are the details." | |
332 | (cond ((string-match "+" text) ;we have to expand this file | |
333 | (speedbar-change-expand-button-char ?-) | |
334 | (speedbar-with-writable | |
335 | (save-excursion | |
336 | (end-of-line) (forward-char 1) | |
337 | (save-restriction | |
338 | (narrow-to-region (point-min) (point)) | |
339 | (semantic-sb-buttons-plain (1+ indent) token))))) | |
340 | ((string-match "-" text) ;we have to contract this node | |
341 | (speedbar-change-expand-button-char ?+) | |
342 | (speedbar-delete-subblock indent)) | |
343 | (t (error "Ooops... not sure what to do"))) | |
344 | (speedbar-center-buffer-smartly)) | |
345 | ||
346 | (defun semantic-sb-buttons-plain (level tokens) | |
347 | "Create buttons at LEVEL using TOKENS." | |
348 | (let ((sordid (speedbar-create-tag-hierarchy tokens))) | |
349 | (while sordid | |
350 | (cond ((null (car-safe sordid)) nil) | |
351 | ((consp (car-safe (cdr-safe (car-safe sordid)))) | |
352 | ;; A group! | |
353 | (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group | |
354 | (cdr (car sordid)) | |
355 | (car (car sordid)) | |
356 | nil nil 'speedbar-tag-face | |
357 | level)) | |
358 | (t ;; Assume that this is a token. | |
359 | (semantic-sb-one-button (car sordid) level))) | |
360 | (setq sordid (cdr sordid))))) | |
361 | ||
362 | (defun semantic-sb-insert-tag-table (level table) | |
363 | "At LEVEL, insert the tag table TABLE. | |
364 | Use arcane knowledge about the semantic tokens in the tagged elements | |
365 | to create much wiser decisions about how to sort and group these items." | |
366 | (semantic-sb-buttons level table)) | |
367 | ||
368 | (defun semantic-sb-buttons (level lst) | |
369 | "Create buttons at LEVEL using LST sorting into type buckets." | |
370 | (save-restriction | |
371 | (narrow-to-region (point-min) (point)) | |
372 | (let (tmp) | |
373 | (while lst | |
374 | (setq tmp (car lst)) | |
375 | (if (cdr tmp) | |
376 | (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length) | |
377 | (semantic-sb-buttons-plain (1+ level) (cdr tmp)) | |
378 | (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group | |
379 | (cdr tmp) | |
380 | (car (car lst)) | |
381 | nil nil 'speedbar-tag-face | |
382 | (1+ level)))) | |
383 | (setq lst (cdr lst)))))) | |
384 | ||
385 | (defun semantic-sb-fetch-tag-table (file) | |
386 | "Load FILE into a buffer, and generate tags using the Semantic parser. | |
387 | Returns the tag list, or t for an error." | |
388 | (let ((out nil)) | |
55b522b2 | 389 | (if (and (featurep 'semantic/db) |
55b522b2 | 390 | (semanticdb-minor-mode-p) |
20bfd709 CY |
391 | (not speedbar-power-click) |
392 | ;; If the database is loaded and running, try to get | |
393 | ;; tokens from it. | |
394 | (setq out (semanticdb-file-stream file))) | |
395 | ;; Successful DB query. | |
396 | nil | |
397 | ;; No database, do it the old way. | |
0816d744 | 398 | (with-current-buffer (find-file-noselect file) |
20bfd709 CY |
399 | (if (or (not (featurep 'semantic)) |
400 | (not semantic--parse-table)) | |
401 | (setq out t) | |
402 | (if speedbar-power-click (semantic-clear-toplevel-cache)) | |
403 | (setq out (semantic-fetch-tags))))) | |
404 | (if (listp out) | |
405 | (condition-case nil | |
406 | (progn | |
4c36be58 | 407 | ;; This brings externally defined methods into |
20bfd709 CY |
408 | ;; their classes, and creates meta classes for |
409 | ;; orphans. | |
410 | (setq out (semantic-adopt-external-members out)) | |
411 | ;; Dump all the tokens into buckets. | |
412 | (semantic-sb-with-tag-buffer (car out) | |
e8cc7880 DE |
413 | (semantic-bucketize out nil |
414 | (lambda (tagsin) | |
415 | ;; Remove all boring tags. | |
416 | (semantic-filter-tags-by-class | |
417 | semantic-sb-filter-tags-of-class | |
418 | tagsin))))) | |
20bfd709 CY |
419 | (error t)) |
420 | t))) | |
421 | ||
422 | ;; Link ourselves into the tagging process. | |
423 | (add-to-list 'speedbar-dynamic-tags-function-list | |
424 | '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table)) | |
425 | ||
426 | (provide 'semantic/sb) | |
427 | ||
428 | ;;; semantic/sb.el ends here |