| 1 | ;;; semantic/sb.el --- Semantic tag display for speedbar |
| 2 | |
| 3 | ;; Copyright (C) 1999-2012 Free Software Foundation, Inc. |
| 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) |
| 34 | (require 'semantic/format) |
| 35 | (require 'semantic/sort) |
| 36 | (require 'semantic/util) |
| 37 | (require 'speedbar) |
| 38 | (declare-function semanticdb-file-stream "semantic/db") |
| 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 occurred 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 | ;; +> keyword 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 clicking 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)) |
| 384 | (if (and (featurep 'semantic/db) |
| 385 | (semanticdb-minor-mode-p) |
| 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 | (with-current-buffer (find-file-noselect file) |
| 394 | (if (or (not (featurep 'semantic)) |
| 395 | (not semantic--parse-table)) |
| 396 | (setq out t) |
| 397 | (if speedbar-power-click (semantic-clear-toplevel-cache)) |
| 398 | (setq out (semantic-fetch-tags))))) |
| 399 | (if (listp out) |
| 400 | (condition-case nil |
| 401 | (progn |
| 402 | ;; This brings externally defined methods into |
| 403 | ;; their classes, and creates meta classes for |
| 404 | ;; orphans. |
| 405 | (setq out (semantic-adopt-external-members out)) |
| 406 | ;; Dump all the tokens into buckets. |
| 407 | (semantic-sb-with-tag-buffer (car out) |
| 408 | (semantic-bucketize out))) |
| 409 | (error t)) |
| 410 | t))) |
| 411 | |
| 412 | ;; Link ourselves into the tagging process. |
| 413 | (add-to-list 'speedbar-dynamic-tags-function-list |
| 414 | '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table)) |
| 415 | |
| 416 | (provide 'semantic/sb) |
| 417 | |
| 418 | ;;; semantic/sb.el ends here |