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