Mercurial > emacs
diff lisp/cedet/semantic/sb.el @ 105260:bbd7017a25d9
CEDET (development tools) package merged.
* cedet/*.el:
* cedet/ede/*.el:
* cedet/semantic/*.el:
* cedet/srecode/*.el: New files.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Mon, 28 Sep 2009 15:15:00 +0000 |
parents | 273e528a9f9b |
children | 108a3a6d8be0 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/sb.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,420 @@ +;;; semantic/sb.el --- Semantic tag display for speedbar + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Convert a tag table into speedbar buttons. + +;;; TODO: + +;; Use semanticdb to find which semanticdb-table is being used for each +;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call +;; children with the new `with-mode-local' instead. + +(require 'semantic) +(require 'semantic/format) +(require 'semantic/sort) +(require 'semantic/util) +(require 'speedbar) +(declare-function semanticdb-file-stream "semantic/db") + +(defcustom semantic-sb-autoexpand-length 1 + "*Length of a semantic bucket to autoexpand in place. +This will replace the named bucket that would have usually occured here." + :group 'speedbar + :type 'integer) + +(defcustom semantic-sb-button-format-tag-function 'semantic-format-tag-abbreviate + "*Function called to create the text for a but from a token." + :group 'speedbar + :type semantic-format-tag-custom-list) + +(defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize + "*Function called to create the text for info display from a token." + :group 'speedbar + :type semantic-format-tag-custom-list) + +;;; Code: +;; + +;;; Buffer setting for correct mode manipulation. +(defun semantic-sb-tag-set-buffer (tag) + "Set the current buffer to something associated with TAG. +use the `speedbar-line-file' to get this info if needed." + (if (semantic-tag-buffer tag) + (set-buffer (semantic-tag-buffer tag)) + (let ((f (speedbar-line-file))) + (set-buffer (find-file-noselect f))))) + +(defmacro semantic-sb-with-tag-buffer (tag &rest forms) + "Set the current buffer to the origin of TAG and execute FORMS. +Restore the old current buffer when completed." + `(save-excursion + (semantic-sb-tag-set-buffer ,tag) + ,@forms)) +(put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1) + +;;; Button Generation +;; +;; Here are some button groups: +;; +;; +> Function () +;; @ return_type +;; +( arg1 +;; +| arg2 +;; +) arg3 +;; +;; +> Variable[1] = +;; @ type +;; = default value +;; +;; +> keywrd Type +;; +> type part +;; +;; +> -> click to see additional information + +(define-overloadable-function semantic-sb-tag-children-to-expand (tag) + "For TAG, return a list of children that TAG expands to. +If this returns a value, then a +> icon is created. +If it returns nil, then a => icon is created.") + +(defun semantic-sb-tag-children-to-expand-default (tag) + "For TAG, the children for type, variable, and function classes." + (semantic-sb-with-tag-buffer tag + (semantic-tag-components tag))) + +(defun semantic-sb-one-button (tag depth &optional prefix) + "Insert TAG as a speedbar button at DEPTH. +Optional PREFIX is used to specify special marker characters." + (let* ((class (semantic-tag-class tag)) + (edata (semantic-sb-tag-children-to-expand tag)) + (type (semantic-tag-type tag)) + (abbrev (semantic-sb-with-tag-buffer tag + (funcall semantic-sb-button-format-tag-function tag))) + (start (point)) + (end (progn + (insert (int-to-string depth) ":") + (point)))) + (insert-char ? (1- depth) nil) + (put-text-property end (point) 'invisible nil) + ;; take care of edata = (nil) -- a yucky but hard to clean case + (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata)))) + (setq edata nil)) + (if (and (not edata) + (member class '(variable function)) + type) + (setq edata t)) + ;; types are a bit unique. Variable types can have special meaning. + (if edata + (speedbar-insert-button (if prefix (concat " +" prefix) " +>") + 'speedbar-button-face + 'speedbar-highlight-face + 'semantic-sb-show-extra + tag t) + (speedbar-insert-button (if prefix (concat " " prefix) " =>") + nil nil nil nil t)) + (speedbar-insert-button abbrev + 'speedbar-tag-face + 'speedbar-highlight-face + 'semantic-sb-token-jump + tag t) + ;; This is very bizarre. When this was just after the insertion + ;; of the depth: text, the : would get erased, but only for the + ;; auto-expanded short- buckets. Move back for a later version + ;; version of Emacs 21 CVS + (put-text-property start end 'invisible t) + )) + +(defun semantic-sb-speedbar-data-line (depth button text &optional + text-fun text-data) + "Insert a semantic token data element. +DEPTH is the current depth. BUTTON is the text for the button. +TEXT is the actual info with TEXT-FUN to occur when it happens. +Argument TEXT-DATA is the token data to pass to TEXT-FUN." + (let ((start (point)) + (end (progn + (insert (int-to-string depth) ":") + (point)))) + (put-text-property start end 'invisible t) + (insert-char ? depth nil) + (put-text-property end (point) 'invisible nil) + (speedbar-insert-button button nil nil nil nil t) + (speedbar-insert-button text + 'speedbar-tag-face + (if text-fun 'speedbar-highlight-face) + text-fun text-data t) + )) + +(defun semantic-sb-maybe-token-to-button (obj indent &optional + prefix modifiers) + "Convert OBJ, which was returned from the semantic parser, into a button. +This OBJ might be a plain string (simple type or untyped variable) +or a complete tag. +Argument INDENT is the indentation used when making the button. +Optional PREFIX is the character to use when marking the line. +Optional MODIFIERS is additional text needed for variables." + (let ((myprefix (or prefix ">"))) + (if (stringp obj) + (semantic-sb-speedbar-data-line indent myprefix obj) + (if (listp obj) + (progn + (if (and (stringp (car obj)) + (= (length obj) 1)) + (semantic-sb-speedbar-data-line indent myprefix + (concat + (car obj) + (or modifiers ""))) + (semantic-sb-one-button obj indent prefix))))))) + +(defun semantic-sb-insert-details (tag indent) + "Insert details about TAG at level INDENT." + (let ((tt (semantic-tag-class tag)) + (type (semantic-tag-type tag))) + (cond ((eq tt 'type) + (let ((parts (semantic-tag-type-members tag)) + (newparts nil)) + ;; Lets expect PARTS to be a list of either strings, + ;; or variable tokens. + (when (semantic-tag-p (car parts)) + ;; Bucketize into groups + (semantic-sb-with-tag-buffer (car parts) + (setq newparts (semantic-bucketize parts))) + (when (> (length newparts) semantic-sb-autoexpand-length) + ;; More than one bucket, insert inline + (semantic-sb-insert-tag-table (1- indent) newparts) + (setq parts nil)) + ;; Dump the strings in. + (while parts + (semantic-sb-maybe-token-to-button (car parts) indent) + (setq parts (cdr parts)))))) + ((eq tt 'variable) + (if type + (semantic-sb-maybe-token-to-button type indent "@")) + (let ((default (semantic-tag-variable-default tag))) + (if default + (semantic-sb-maybe-token-to-button default indent "="))) + ) + ((eq tt 'function) + (if type + (semantic-sb-speedbar-data-line + indent "@" + (if (stringp type) type + (semantic-tag-name type)))) + ;; Arguments to the function + (let ((args (semantic-tag-function-arguments tag))) + (if (and args (car args)) + (progn + (semantic-sb-maybe-token-to-button (car args) indent "(") + (setq args (cdr args)) + (while (> (length args) 1) + (semantic-sb-maybe-token-to-button (car args) + indent + "|") + (setq args (cdr args))) + (if args + (semantic-sb-maybe-token-to-button + (car args) indent ")")) + )))) + (t + (let ((components + (save-excursion + (when (and (semantic-tag-overlay tag) + (semantic-tag-buffer tag)) + (set-buffer (semantic-tag-buffer tag))) + (semantic-sb-tag-children-to-expand tag)))) + ;; Well, it wasn't one of the many things we expect. + ;; Lets just insert them in with no decoration. + (while components + (semantic-sb-one-button (car components) indent) + (setq components (cdr components))) + )) + ) + )) + +(defun semantic-sb-detail-parent () + "Return the first parent token of the current line that includes a location." + (save-excursion + (beginning-of-line) + (let ((dep (if (looking-at "[0-9]+:") + (1- (string-to-number (match-string 0))) + 0))) + (re-search-backward (concat "^" + (int-to-string dep) + ":") + nil t)) + (beginning-of-line) + (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$") + (let ((prop nil)) + (goto-char (match-beginning 1)) + (setq prop (get-text-property (point) 'speedbar-token)) + (if (semantic-tag-with-position-p prop) + prop + (semantic-sb-detail-parent))) + nil))) + +(defun semantic-sb-show-extra (text token indent) + "Display additional information about the token as an expansion. +TEXT TOKEN and INDENT are the details." + (cond ((string-match "+" text) ;we have to expand this file + (speedbar-change-expand-button-char ?-) + (speedbar-with-writable + (save-excursion + (end-of-line) (forward-char 1) + (save-restriction + (narrow-to-region (point) (point)) + ;; Add in stuff specific to this type of token. + (semantic-sb-insert-details token (1+ indent)))))) + ((string-match "-" text) ;we have to contract this node + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defun semantic-sb-token-jump (text token indent) + "Jump to the location specified in token. +TEXT TOKEN and INDENT are the details." + (let ((file + (or + (cond ((fboundp 'speedbar-line-path) + (speedbar-line-directory indent)) + ((fboundp 'speedbar-line-directory) + (speedbar-line-directory indent))) + ;; If speedbar cannot figure this out, extract the filename from + ;; the token. True for Analysis mode. + (semantic-tag-file-name token))) + (parent (semantic-sb-detail-parent))) + (let ((f (selected-frame))) + (dframe-select-attached-frame speedbar-frame) + (run-hooks 'speedbar-before-visiting-tag-hook) + (select-frame f)) + ;; Sometimes FILE may be nil here. If you are debugging a problem + ;; when this happens, go back and figure out why FILE is nil and try + ;; and fix the source. + (speedbar-find-file-in-frame file) + (save-excursion (speedbar-stealthy-updates)) + (semantic-go-to-tag token parent) + (switch-to-buffer (current-buffer)) + ;; Reset the timer with a new timeout when cliking a file + ;; in case the user was navigating directories, we can cancel + ;; that other timer. + ;; (speedbar-set-timer dframe-update-speed) + ;;(recenter) + (speedbar-maybee-jump-to-attached-frame) + (run-hooks 'speedbar-visiting-tag-hook))) + +(defun semantic-sb-expand-group (text token indent) + "Expand a group which has semantic tokens. +TEXT TOKEN and INDENT are the details." + (cond ((string-match "+" text) ;we have to expand this file + (speedbar-change-expand-button-char ?-) + (speedbar-with-writable + (save-excursion + (end-of-line) (forward-char 1) + (save-restriction + (narrow-to-region (point-min) (point)) + (semantic-sb-buttons-plain (1+ indent) token))))) + ((string-match "-" text) ;we have to contract this node + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defun semantic-sb-buttons-plain (level tokens) + "Create buttons at LEVEL using TOKENS." + (let ((sordid (speedbar-create-tag-hierarchy tokens))) + (while sordid + (cond ((null (car-safe sordid)) nil) + ((consp (car-safe (cdr-safe (car-safe sordid)))) + ;; A group! + (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group + (cdr (car sordid)) + (car (car sordid)) + nil nil 'speedbar-tag-face + level)) + (t ;; Assume that this is a token. + (semantic-sb-one-button (car sordid) level))) + (setq sordid (cdr sordid))))) + +(defun semantic-sb-insert-tag-table (level table) + "At LEVEL, insert the tag table TABLE. +Use arcane knowledge about the semantic tokens in the tagged elements +to create much wiser decisions about how to sort and group these items." + (semantic-sb-buttons level table)) + +(defun semantic-sb-buttons (level lst) + "Create buttons at LEVEL using LST sorting into type buckets." + (save-restriction + (narrow-to-region (point-min) (point)) + (let (tmp) + (while lst + (setq tmp (car lst)) + (if (cdr tmp) + (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length) + (semantic-sb-buttons-plain (1+ level) (cdr tmp)) + (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group + (cdr tmp) + (car (car lst)) + nil nil 'speedbar-tag-face + (1+ level)))) + (setq lst (cdr lst)))))) + +(defun semantic-sb-fetch-tag-table (file) + "Load FILE into a buffer, and generate tags using the Semantic parser. +Returns the tag list, or t for an error." + (let ((out nil)) + (if (and (featurep 'semantic/db) + (semanticdb-minor-mode-p) + (not speedbar-power-click) + ;; If the database is loaded and running, try to get + ;; tokens from it. + (setq out (semanticdb-file-stream file))) + ;; Successful DB query. + nil + ;; No database, do it the old way. + (save-excursion + (set-buffer (find-file-noselect file)) + (if (or (not (featurep 'semantic)) + (not semantic--parse-table)) + (setq out t) + (if speedbar-power-click (semantic-clear-toplevel-cache)) + (setq out (semantic-fetch-tags))))) + (if (listp out) + (condition-case nil + (progn + ;; This brings externally defind methods into + ;; their classes, and creates meta classes for + ;; orphans. + (setq out (semantic-adopt-external-members out)) + ;; Dump all the tokens into buckets. + (semantic-sb-with-tag-buffer (car out) + (semantic-bucketize out))) + (error t)) + t))) + +;; Link ourselves into the tagging process. +(add-to-list 'speedbar-dynamic-tags-function-list + '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table)) + +(provide 'semantic/sb) + +;;; semantic/sb.el ends here