Source

semantic / semantic-sb.el

Diff from to

semantic-sb.el

 ;;; semantic-sb.el --- Semantic tag display for speedbar
 
-;;; Copyright (C) 1999, 2000, 2001, 2002 Eric M. Ludlam
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Eric M. Ludlam
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.1
 ;; Keywords: syntax
 ;; X-RCS: $Id$
 
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 ;;
-;; Convert a bovinated token list into speedbar buttons.
+;; Convert a tag table into speedbar buttons.
 
-;;; History:
+;;; 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 'speedbar)
+(require 'semantic-util)
+(require 'inversion)
+(eval-and-compile
+  (inversion-require 'speedbar "0.15beta1"))
 
 (defcustom semantic-sb-autoexpand-length 1
   "*Length of a semantic bucket to autoexpand in place.
   :group 'speedbar
   :type 'integer)
 
-(defcustom semantic-sb-button-token->text-function 'semantic-abbreviate-nonterminal
+(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-token->text-custom-list)
+  :type semantic-format-tag-custom-list)
 
-(defcustom semantic-sb-info-token->text-function 'semantic-summarize-nonterminal
+(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-token->text-custom-list)
+  :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
 ;;
 ;;
 ;;  +>  -> click to see additional information
 
-(defun semantic-sb-one-button (token depth &optional prefix)
-  "Insert TOKEN as a speedbar button at DEPTH.
+(define-overload 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* ((type (semantic-token-token token))
-	 (edata (cond ((eq type 'type)
-		        (semantic-token-type-parts token))
-		      ((eq type 'variable)
-		       (semantic-token-variable-default token))
-		      ((eq type 'function)
-		       (semantic-token-function-args token))
-		      ))
-	 (abbrev (funcall semantic-sb-button-token->text-function token))
+  (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) ":")
     ;; 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
-				token t)
+				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
-			    token t)
+			    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
 
 (defun semantic-sb-maybe-token-to-button (obj indent &optional
 					      prefix modifiers)
-  "Convert OBJ, which was returned from the bovinator, into a button.
+  "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 bovinator type.
+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."
 						 (or modifiers "")))
 	      (semantic-sb-one-button obj indent prefix)))))))
 
-(defun semantic-sb-insert-details (token indent)
-  "Insert details about TOKEN at level INDENT."
-  (let ((tt (semantic-token-token token))
-	(type (semantic-token-type token)))
+(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-token-type-parts token))
+	   (let ((parts (semantic-tag-type-members tag))
 		 (newparts nil))
 	     ;; Lets expect PARTS to be a list of either strings,
 	     ;; or variable tokens.
-	     (when (semantic-token-p (car parts))
+	     (when (semantic-tag-p (car parts))
 	       ;; Bucketize into groups
-	       (setq newparts (semantic-bucketize parts))
+	       (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-insert-bovine-list (1- indent) newparts)
+		 (semantic-sb-insert-tag-table (1- indent) newparts)
 		 (setq parts nil))
 	       ;; Dump the strings in.
 	       (while parts
 		 (setq parts (cdr parts))))))
 	  ((eq tt 'variable)
 	   (if type
-	       (let ((mods (semantic-token-variable-extra-spec token 'typemodifiers)))
-		 (semantic-sb-maybe-token-to-button type indent "@" mods)))
-	   ;; default value here
+	       (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-token-name type))))
+		  (semantic-tag-name type))))
 	   ;; Arguments to the function
-	   (let ((args (semantic-token-function-args token)))
+	   (let ((args (semantic-tag-function-arguments tag)))
 	     (if (and args (car args))
 		 (progn
 		   (semantic-sb-maybe-token-to-button (car args) indent "(")
 		   (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 like that includes a location."
+  "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-int (match-string 0)))
+		   (1- (string-to-number (match-string 0)))
 		 0)))
       (re-search-backward (concat "^"
 				  (int-to-string dep)
 	(let ((prop nil))
 	  (goto-char (match-beginning 1))
 	  (setq prop (get-text-property (point) 'speedbar-token))
-	  (if (numberp (semantic-token-start prop))
+	  (if (semantic-tag-with-position-p prop)
 	      prop
 	    (semantic-sb-detail-parent)))
       nil)))
 (defun semantic-sb-token-jump (text token indent)
   "Jump to the location specified in token.
 TEXT TOKEN and INDENT are the details."
-  (let ((file (speedbar-line-path indent))
+  (let ((file
+	 (or
+	  (cond ((fboundp 'speedbar-line-path)
+		 (speedbar-line-path 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-find-nonterminal token parent)
+    (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.
 	     (semantic-sb-one-button (car sordid) level)))
       (setq sordid (cdr sordid)))))
 
-(defun semantic-insert-bovine-list (level lst)
-  "At LEVEL, insert the bovine parsed list LST.
+(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 lst))
+  (semantic-sb-buttons level table))
 
 (defun semantic-sb-buttons (level lst)
   "Create buttons at LEVEL using LST sorting into type buckets."
 				      (1+ level))))
 	(setq lst (cdr lst))))))
 
-(defun semantic-fetch-dynamic-bovine (file)
-  "Load FILE into a buffer, and generate tags using the Semantic Bovinator.
+(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 'semanticdb) (semanticdb-minor-mode-p)
       (save-excursion
 	(set-buffer (find-file-noselect file))
 	(if (or (not (featurep 'semantic))
-		(not semantic-toplevel-bovine-table))
+		(not semantic--parse-table))
 	    (setq out t)
 	  (if speedbar-power-click (semantic-clear-toplevel-cache))
-	  (setq out (semantic-bovinate-toplevel)))))
+	  (setq out (semantic-fetch-tags)))))
     (if (listp out)
 	(condition-case nil
 	    (progn
 	      ;; orphans.
 	      (setq out (semantic-adopt-external-members out))
 	      ;; Dump all the tokens into buckets.
-	      (semantic-bucketize out))
+	      (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-fetch-dynamic-bovine  . semantic-insert-bovine-list))
+	     '(semantic-sb-fetch-tag-table  . semantic-sb-insert-tag-table))
 
 (provide 'semantic-sb)