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