changeset 107497:b09401cc9d96

* cedet/semantic/imenu.el: New file from the CEDET repository (Bug#5412).

--- a/lisp/ChangeLog	Thu Mar 11 19:19:17 2010 -0800
+++ b/lisp/ChangeLog	Sat Mar 13 10:49:54 2010 -0500
@@ -1,3 +1,8 @@
[phone]  Eric M. Ludlam  <[e-mail]>
+
+	* cedet/semantic/imenu.el: New file, from the CEDET repository
+	(Bug#5412).
+
 2010-03-12  Glenn Morris  <[e-mail]>
 
 	* emacs-lisp/cl-macs.el (defsubst*): Add autoload cookie.  (Bug#4427)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/cedet/semantic/imenu.el	Sat Mar 13 10:49:54 2010 -0500
@@ -0,0 +1,539 @@
+;;; semantic/imenu.el --- Use Semantic as an imenu tag generator
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2010
+;;   Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <[e-mail]>
+;; Maintainer: Eric Ludlam
+
+;; This file is not part of GNU Emacs.
+
+;; 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:
+;;
+;; This support function can be used in any buffer which supports
+;; the bovinator to create the imenu index.
+;;
+;; To use this in a buffer, do this in a hook.
+;;
+;; (add-hook 'mode-hook
+;;           (lambda ()
+;;             (setq imenu-create-index-function 'semantic-create-imenu-index)
+;;             ))
+
+(require 'semantic)
+(require 'semantic/format)
+(require 'semantic/db)
+(require 'semantic/db-file)
+(require 'semantic/sort)
+(require 'imenu)
+
+(declare-function pulse-momentary-highlight-one-line "pulse" (o &optional face))
+(declare-function semanticdb-semantic-init-hook-fcn "db-mode")
+
+;; Because semantic imenu tags will hose the current imenu handling
+;; code in speedbar, force semantic/sb in.
+(if (featurep 'speedbar)
+    (require 'semantic/sb)
+  (add-hook 'speedbar-load-hook (lambda () (require 'semantic/sb))))
+
+(defgroup semantic-imenu nil
+  "Semantic interface to Imenu."
+  :group 'semantic
+  :group 'imenu
+  )
+
+;;;###autoload
+(defcustom semantic-imenu-summary-function 'semantic-format-tag-abbreviate
+  "*Function to use when creating items in Imenu.
+Some useful functions are found in `semantic-format-tag-functions'."
+  :group 'semantic-imenu
+  :type semantic-format-tag-custom-list)
+(make-variable-buffer-local 'semantic-imenu-summary-function)
+
+;;;###autoload
+(defcustom semantic-imenu-bucketize-file t
+  "*Non-nil if tags in a file are to be grouped into buckets."
+  :group 'semantic-imenu
+  :type 'boolean)
+(make-variable-buffer-local 'semantic-imenu-bucketize-file)
+
+(defcustom semantic-imenu-adopt-external-members t
+  "*Non-nil if types in a file should adopt externally defined members.
+C++ and CLOS can define methods that are not in the body of a class
+definition."
+  :group 'semantic-imenu
+  :type 'boolean)
+
+(defcustom semantic-imenu-buckets-to-submenu t
+  "*Non-nil if buckets of tags are to be turned into submenus.
+This option is ignored if `semantic-imenu-bucketize-file' is nil."
+  :group 'semantic-imenu
+  :type 'boolean)
+(make-variable-buffer-local 'semantic-imenu-buckets-to-submenu)
+
+;;;###autoload
+(defcustom semantic-imenu-expand-type-members t
+  "*Non-nil if types should have submenus with members in them."
+  :group 'semantic-imenu
+  :type 'boolean)
+(make-variable-buffer-local 'semantic-imenu-expand-type-members)
+(semantic-varalias-obsolete 'semantic-imenu-expand-type-parts
+                            'semantic-imenu-expand-type-members "23.2")
+
+(defcustom semantic-imenu-bucketize-type-members t
+  "*Non-nil if members of a type should be grouped into buckets.
+nil means to keep them in the same order.
+Overriden to nil if `semantic-imenu-bucketize-file' is nil."
+  :group 'semantic-imenu
+  :type 'boolean)
+(make-variable-buffer-local 'semantic-imenu-bucketize-type-parts)
+(semantic-varalias-obsolete 'semantic-imenu-bucketize-type-parts
+                            'semantic-imenu-bucketize-type-members "23.2")
+
+(defcustom semantic-imenu-sort-bucket-function nil
+  "*Function to use when sorting tags in the buckets of functions.
+See `semantic-bucketize' and the FILTER argument for more details on this function."
+  :group 'semantic-imenu
+  :type '(radio (const :tag "No Sorting" nil)
+		(const semantic-sort-tags-by-name-increasing)
+		(const semantic-sort-tags-by-name-decreasing)
+		(const semantic-sort-tags-by-type-increasing)
+		(const semantic-sort-tags-by-type-decreasing)
+		(const semantic-sort-tags-by-name-increasing-ci)
+		(const semantic-sort-tags-by-name-decreasing-ci)
+		(const semantic-sort-tags-by-type-increasing-ci)
+		(const semantic-sort-tags-by-type-decreasing-ci)
+		(function)))
+(make-variable-buffer-local 'semantic-imenu-sort-bucket-function)
+
+(defcustom semantic-imenu-index-directory nil
+  "*Non nil to index the entire directory for tags.
+Doesn't actually parse the entire directory, but displays tags for all files
+currently listed in the current Semantic database.
+This variable has no meaning if semanticdb is not active."
+  :group 'semantic-imenu
+  :type 'boolean)
+
+(defcustom semantic-imenu-auto-rebuild-directory-indexes nil
+  "*If non-nil automatically rebuild directory index imenus.
+That is when a directory index imenu is updated, automatically rebuild
+other buffer local ones based on the same semanticdb."
+  :group 'semantic-imenu
+  :type 'boolean)
+
+(defvar semantic-imenu-directory-current-file nil
+  "When building a file index, this is the file name currently being built.")
+
+(defvar semantic-imenu-auto-rebuild-running nil
+  "Non-nil if `semantic-imenu-rebuild-directory-indexes' is running.")
+
+;;;###autoload
+(defvar semantic-imenu-expandable-tag-classes '(type)
+  "List of expandable tag classes.
+Tags of those classes will be given submenu with children.
+By default, a `type' has interesting children.  In Texinfo, however, a
+`section' has interesting children.")
+(make-variable-buffer-local 'semantic-imenu-expandable-tag-classes)
+(semantic-varalias-obsolete 'semantic-imenu-expandable-token
+                            'semantic-imenu-expandable-tag-classes "23.2")
+
+;;; Code:
+(defun semantic-imenu-tag-overlay (tag)
+  "Return the overlay belonging to tag.
+If TAG doesn't have an overlay, and instead as a vector of positions,
+concoct a combination of file name, and position."
+  (let ((o (semantic-tag-overlay tag)))
+    (if (not (semantic-overlay-p o))
+	(let ((v (make-vector 3 nil)))
+	  (aset v 0 semantic-imenu-directory-current-file)
+	  (aset v 1 (aref o 0))
+	  (aset v 2 (aref o 1))
+	  v)
+      o)))
+
+
+(defun semantic-imenu-goto-function (name position &optional rest)
+  "Move point associated with NAME to POSITION.
+Used to override function `imenu-default-goto-function' so that we can continue
+to use overlays to maintain the current position.
+Optional argument REST is some extra stuff."
+  (require 'pulse)
+  (if (semantic-overlay-p position)
+      (let ((os (semantic-overlay-start position))
+	    (ob (semantic-overlay-buffer position)))
+	(if os
+	    (progn
+	      (if (not (eq ob (current-buffer)))
+		  (switch-to-buffer ob))
+	      (imenu-default-goto-function name os rest)
+	      (pulse-momentary-highlight-one-line (point))
+	      )
+	  ;; This should never happen, but check anyway.
+	  (message "Imenu is out of date, try again. (internal bug)")
+	  (setq imenu--index-alist nil)))
+    ;; When the POSITION is actually a pair of numbers in an array, then
+    ;; the file isn't loaded into the current buffer.
+    (if (vectorp position)
+	(let ((file (aref position 0))
+	      (pos (aref position 1)))
+	  (and file (find-file file))
+	  (imenu-default-goto-function name pos rest)
+	  (pulse-momentary-highlight-one-line (point))
+	  )
+      ;; When the POSITION is the symbol 'file-only' it means that this
+      ;; is a directory index entry and there is no tags in this
+      ;; file. So just jump to the beginning of the file.
+      (if (eq position 'file-only)
+	  (progn
+	    (find-file name)
+	    (imenu-default-goto-function name (point-min) rest)
+	    (pulse-momentary-highlight-one-line (point))
+	    )
+        ;; Probably POSITION don't came from a semantic imenu.  Try
+        ;; the default imenu goto function.
+        (condition-case nil
+	    (progn
+	      (imenu-default-goto-function name position rest)
+	      (pulse-momentary-highlight-one-line (point))
+	      )
+          (error
+           (message "Semantic Imenu override problem. (Internal bug)")
+           (setq imenu--index-alist nil)))))
+    ))
+
+(defun semantic-imenu-flush-fcn (&optional ignore)
+  "This function is called as a hook to clear the imenu cache.
+It is cleared after any parsing.
+IGNORE arguments."
+  (if (eq imenu-create-index-function 'semantic-create-imenu-index)
+      (setq imenu--index-alist nil
+            imenu-menubar-modified-tick 0))
+  (remove-hook 'semantic-after-toplevel-cache-change-hook
+               'semantic-imenu-flush-fcn t)
+  (remove-hook 'semantic-after-partial-cache-change-hook
+               'semantic-imenu-flush-fcn t)
+  )
+
+;;;###autoload
+(defun semantic-create-imenu-index (&optional stream)
+  "Create an imenu index for any buffer which supports Semantic.
+Uses the output of the Semantic parser to create the index.
+Optional argument STREAM is an optional stream of tags used to create menus."
+  (setq imenu-default-goto-function 'semantic-imenu-goto-function)
+  (prog1
+      (if (and semantic-imenu-index-directory
+               (featurep 'semanticdb)
+               (semanticdb-minor-mode-p))
+          (semantic-create-imenu-directory-index
+	   (or stream (semantic-fetch-tags-fast)))
+        (semantic-create-imenu-index-1
+	 (or stream (semantic-fetch-tags-fast)) nil))
+    (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
+    (add-hook 'semantic-after-toplevel-cache-change-hook
+              'semantic-imenu-flush-fcn nil t)
+    (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
+    (add-hook 'semantic-after-partial-cache-change-hook
+              'semantic-imenu-flush-fcn nil t)))
+
+(defun semantic-create-imenu-directory-index (&optional stream)
+  "Create an IMENU tag index based on all files active in semanticdb.
+Optional argument STREAM is the stream of tags for the current buffer."
+  (if (not semanticdb-current-database)
+      (semantic-create-imenu-index-1 stream nil)
+    ;; We have a database, list all files, with the current file on top.
+    (let ((index (list
+		  (cons (oref semanticdb-current-table file)
+			(or (semantic-create-imenu-index-1 stream nil)
+			    ;; No tags in this file
+			    'file-only))))
+	  (tables (semanticdb-get-database-tables semanticdb-current-database)))
+	(while tables
+	  (let ((semantic-imenu-directory-current-file
+		 (oref (car tables) file))
+		tags)
+	    (when (and (not (eq (car tables) semanticdb-current-table))
+		       (semanticdb-live-p (car tables))
+		       (semanticdb-equivalent-mode (car tables))
+		       )
+	      (setq tags (oref (car tables) tags)
+		    index (cons (cons semantic-imenu-directory-current-file
+				      (or (and tags
+					       ;; don't pass nil stream because
+					       ;; it will use the current
+					       ;; buffer
+					       (semantic-create-imenu-index-1
+						(oref (car tables) tags)
+						nil))
+					  ;; no tags in the file
+					  'file-only))
+				index)))
+	    (setq tables (cdr tables))))
+
+      ;; If enabled automatically rebuild other imenu directory
+      ;; indexes based on the same Semantic database
+      (or (not semantic-imenu-auto-rebuild-directory-indexes)
+          ;; If auto rebuild already in progress does nothing
+          semantic-imenu-auto-rebuild-running
+          (unwind-protect
+              (progn
+                (setq semantic-imenu-auto-rebuild-running t)
+                (semantic-imenu-rebuild-directory-indexes
+                 semanticdb-current-database))
+            (setq semantic-imenu-auto-rebuild-running nil)))
+
+      (nreverse index))))
+
+(defun semantic-create-imenu-index-1 (stream &optional parent)
+  "Create an imenu index for any buffer which supports Semantic.
+Uses the output of the Semantic parser to create the index.
+STREAM is a stream of tags used to create menus.
+Optional argument PARENT is a tag parent of STREAM."
+  (let ((tags stream)
+	(semantic-imenu-adopt-external-members
+	 semantic-imenu-adopt-external-members))
+    ;; If we should regroup, do so.
+    (if semantic-imenu-adopt-external-members
+ 	(setq tags (semantic-adopt-external-members tags)
+	      ;; Don't allow recursion here.
+	      semantic-imenu-adopt-external-members nil))
+    ;; Test for bucketing vs not.
+    (if semantic-imenu-bucketize-file
+	(let ((buckets (semantic-bucketize
+			tags parent
+			semantic-imenu-sort-bucket-function))
+	      item name
+	      index)
+	  (cond
+	   ((null buckets)
+	    nil)
+	   ((or (cdr-safe buckets) ;; if buckets has more than one item in it.
+                (not semantic-imenu-buckets-to-submenu)) ;; to force separators between buckets
+	    (while buckets
+	      (setq name (car (car buckets))
+		    item (cdr (car buckets)))
+	      (if semantic-imenu-buckets-to-submenu
+		  (progn
+		    ;; Make submenus
+		    (if item
+			(setq index
+			      (cons (cons name
+					  (semantic-create-imenu-subindex item))
+				    index))))
+		;; Glom everything together with "---" between
+		(if item
+		    (setq index
+			  (append index
+				  ;; do not create a menu separator in the parent menu
+				  ;; when creating a sub-menu
+				  (if (memq (semantic-tag-class (car item))
+                                            semantic-imenu-expandable-tag-classes)
+				      (semantic-create-imenu-subindex item)
+				    (cons
+				     '("---")
+				     (semantic-create-imenu-subindex item)))))
+		  ))
+	      (setq buckets (cdr buckets)))
+	    (if semantic-imenu-buckets-to-submenu
+		(nreverse index)
+	      index))
+	   (t
+	    (setq name (car (car buckets))
+		  item (cdr (car buckets)))
+	    (semantic-create-imenu-subindex item))))
+      ;; Else, group everything together
+      (semantic-create-imenu-subindex tags))))
+
+(defun semantic-create-imenu-subindex (tags)
+  "From TAGS, create an imenu index of interesting things."
+  (let ((notypecheck (not semantic-imenu-expand-type-members))
+	children index tag parts)
+    (while tags
+      (setq tag (car tags)
+	    children (semantic-tag-components-with-overlays tag))
+      (if (and (not notypecheck)
+               (memq (semantic-tag-class tag)
+                     semantic-imenu-expandable-tag-classes)
+	       children
+               )
+          ;; to keep an homogeneous menu organisation, type menu items
+          ;; always have a sub-menu with at least the *definition*
+          ;; item (even if the tag has no type components)
+	  (progn
+	    (setq parts children)
+	    ;; There is options which create the submenu
+	    ;;  * Type has an overlay, but children do.
+	    ;; The type doesn't have to have it's own overlay,
+	    ;; but a type with no overlay and no children should be
+	    ;; invalid.
+	    (setq index
+		  (cons
+		   (cons
+		    (funcall semantic-imenu-summary-function tag)
+		    ;; Add a menu for getting at the type definitions
+		    (if (and parts
+			     ;; Note to self: enable menu items for
+			     ;; sub parts even if they are not proper
+			     ;; tags.
+			     (semantic-tag-p (car parts)))
+			(let ((submenu
+			       (if (and semantic-imenu-bucketize-type-members
+					semantic-imenu-bucketize-file)
+				   (semantic-create-imenu-index-1 parts tag)
+				 (semantic-create-imenu-subindex parts))))
+			  ;; Only add a *definition* if we have a postion
+			  ;; in that type tag.
+			  (if (semantic-tag-with-position-p tag)
+			      (cons
+			       (cons "*definition*"
+				     (semantic-imenu-tag-overlay tag))
+			       submenu)
+			    submenu))
+		      ;; There were no parts, or something like that, so
+		      ;; instead just put the definition here.
+		      (if (semantic-tag-with-position-p tag)
+			  (semantic-imenu-tag-overlay tag)
+			nil)
+		      ))
+		   index)))
+	(if (semantic-tag-with-position-p tag)
+	    (setq index (cons
+			 (cons
+			  (funcall semantic-imenu-summary-function tag)
+			  (semantic-imenu-tag-overlay tag))
+			 index))))
+      (setq tags (cdr tags)))
+    ;; `imenu--split-submenus' sort submenus according to
+    ;; `imenu-sort-function' setting and split them up if they are
+    ;; longer than `imenu-max-items'.
+    (imenu--split-submenus (nreverse index))))
+
+;;; directory imenu rebuilding.
+;;
+(defun semantic-imenu-rebuild-directory-indexes (db)
+  "Rebuild directory index imenus based on Semantic database DB."
+  (let ((l (buffer-list))
+        b)
+    (while l
+      (setq b (car l)
+            l (cdr l))
+      (if (and (not (eq b (current-buffer)))
+               (buffer-live-p b))
+          (with-current-buffer b
+            ;; If there is a buffer local Semantic index directory
+            ;; imenu
+            (when (and (eq imenu-create-index-function
+                           'semantic-create-imenu-index)
+                       semanticdb-current-database
+                       (eq semanticdb-current-database db))
+              ;; Rebuild the imenu
+              (imenu--cleanup)
+              (setq imenu--index-alist nil)
+              (funcall
+               (if (fboundp 'imenu-menu-filter)
+                   ;; XEmacs imenu
+                   'imenu-menu-filter
+                 ;; Emacs imenu
+                 'imenu-update-menubar))))))))
+
+(defun semantic-imenu-semanticdb-hook ()
+  "Function to be called from `semanticdb-mode-hook'.
+Clears all imenu menus that may be depending on the database."
+  (require 'semantic/db-mode)
+  (semantic-map-buffers
+   #'(lambda ()
+       ;; Set up semanticdb environment if enabled.
+       (if (semanticdb-minor-mode-p)
+           (semanticdb-semantic-init-hook-fcn))
+       ;; Clear imenu cache to redraw the imenu.
+       (semantic-imenu-flush-fcn))))
+
+(add-hook 'semanticdb-mode-hook 'semantic-imenu-semanticdb-hook)
+
+;;; Interactive Utilities
+;;
+(defun semantic-imenu-toggle-bucketize-file ()
+  "Toggle the ability of imenu to bucketize the current file."
+  (interactive)
+  (setq semantic-imenu-bucketize-file (not semantic-imenu-bucketize-file))
+  ;; Force a rescan
+  (setq imenu--index-alist nil))
+
+(defun semantic-imenu-toggle-buckets-to-submenu ()
+  "Toggle the ability of imenu to turn buckets into submenus."
+  (interactive)
+  (setq semantic-imenu-buckets-to-submenu (not semantic-imenu-buckets-to-submenu))
+  ;; Force a rescan
+  (setq imenu--index-alist nil))
+
+(defun semantic-imenu-toggle-bucketize-type-parts ()
+  "Toggle the ability of imenu to bucketize the current file."
+  (interactive)
+  (setq semantic-imenu-bucketize-type-members (not semantic-imenu-bucketize-type-members))
+  ;; Force a rescan
+  (setq imenu--index-alist nil))
+
+;;; Which function support
+;;
+;; The which-function library will display the current function in the
+;; mode line.  It tries do do this through imenu.  With a semantic parsed
+;; buffer, there is a much more efficient way of doing this.
+;; Advise `which-function' so that we optionally use semantic tags
+;; instead, and get better stuff.
+(require 'advice)
+
+(defvar semantic-which-function 'semantic-default-which-function
+  "Function to convert semantic tags into `which-function' text.")
+
+(defcustom semantic-which-function-use-color nil
+  "*Use color when displaying the current function with `which-function'."
+  :group 'semantic-imenu
+  :type 'boolean)
+
+(defun semantic-default-which-function (taglist)
+  "Convert TAGLIST into a string usable by `which-function'.
+Returns the first tag name in the list, unless it is a type,
+in which case it concatenates them together."
+  (cond ((eq (length taglist) 1)
+	 (semantic-format-tag-abbreviate
+          (car taglist) nil semantic-which-function-use-color))
+	((memq (semantic-tag-class (car taglist))
+               semantic-imenu-expandable-tag-classes)
+	 (concat (semantic-format-tag-name
+                  (car taglist) nil semantic-which-function-use-color)
+		 (car semantic-type-relation-separator-character)
+		 ;; recurse until we no longer have a type
+		 ;; or any tags left.
+		 (semantic-default-which-function (cdr taglist))))
+	(t (semantic-format-tag-abbreviate
+            (car taglist) nil semantic-which-function-use-color))))
+
+;; (defadvice which-function (around semantic-which activate)
+;;   "Choose the function to display via semantic if it is currently active."
+;;   (if (and (featurep 'semantic) semantic--buffer-cache)
+;;       (let ((ol (semantic-find-tag-by-overlay)))
+;; 	(setq ad-return-value (funcall semantic-which-function ol)))
+;;     ad-do-it))
+
+(provide 'semantic/imenu)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-load-name: "semantic/imenu"
+;; End:
+
+;;; semantic/imenu.el ends here