cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-imenu.el

   1 ;;; semantic-imenu.el --- Use Semantic as an imenu tag generator
   2
   3 ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007 Paul Kinnucan & Eric Ludlam
   4 ;;; Copyright (C) 2001, 2002, 2003 Eric Ludlam
   5
   6 ;; Created By: Paul Kinnucan
   7 ;; Maintainer: Eric Ludlam
   8 ;; X-RCS: $Id: semantic-imenu.el,v 1.56 2007/02/19 02:51:54 zappo Exp $
   9
  10 ;; This file is not part of GNU Emacs.
  11
  12 ;; Semantic-imenu is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; This software is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; This support function can be used in any buffer which supports
  30 ;; the bovinator to create the imenu index.
  31 ;;
  32 ;; To use this in a buffer, do this in a hook.
  33 ;;
  34 ;; (add-hook 'mode-hook
  35 ;;           (lambda ()
  36 ;;             (setq imenu-create-index-function 'semantic-create-imenu-index)
  37 ;;             ))
  38
  39 (require 'semantic)
  40 (require 'semantic-format)
  41 (require 'working)
  42 (eval-when-compile
  43   (condition-case nil
  44       (require 'imenu)
  45     (error nil))
  46   (require 'semanticdb)
  47   )
  48 (condition-case nil
  49     (progn
  50       (require 'imenu)
  51       (if (featurep 'xemacs)
  52           ;; From David Ponce <david@dponce.com>
  53           ;; Advice the XEmacs imenu function `imenu--create-menu-1' to
  54           ;; handle menu separators.
  55           (defadvice imenu--create-menu-1 (around semantic activate)
  56             ;; Create a menu separator item if first argument (title)
  57             ;; contains only hyphens and the second argument (list) is nil.
  58             (if (and (null (ad-get-arg 1))
  59                      (not (string-match "[^-]" (ad-get-arg 0))))
  60                 (setq ad-return-value "-")
  61               ad-do-it)))
  62       )
  63   (error nil))
  64
  65 ;; Because semantic imenu tags will hose the current imenu handling
  66 ;; code in speedbar, force semantic-sb in.
  67 (if (featurep 'speedbar)
  68     (require 'semantic-sb)
  69   (add-hook 'speedbar-load-hook (lambda () (require 'semantic-sb))))
  70
  71 (defgroup semantic-imenu nil
  72   "Parser Generator Imenu interface."
  73   :group 'semantic
  74   :group 'imenu
  75   )
  76
  77 ;;;###autoload
  78 (defcustom semantic-imenu-summary-function 'semantic-format-tag-abbreviate
  79   "*Function to use when creating items in Imenu.
  80 Some useful functions are found in `semantic-format-tag-functions'."
  81   :group 'semantic-imenu
  82   :type semantic-format-tag-custom-list)
  83 (make-variable-buffer-local 'semantic-imenu-summary-function)
  84
  85 ;;;###autoload
  86 (defcustom semantic-imenu-bucketize-file t
  87   "*Non-nil if tags in a file are to be grouped into buckets."
  88   :group 'semantic-imenu
  89   :type 'boolean)
  90 (make-variable-buffer-local 'semantic-imenu-bucketize-file)
  91
  92 (defcustom semantic-imenu-adopt-external-members t
  93   "*Non-nil if types in a file should adopt externally defined members.
  94 C++ and CLOS can define methods that are not in the body of a class
  95 definition."
  96   :group 'semantic-imenu
  97   :type 'boolean)
  98
  99 (defcustom semantic-imenu-buckets-to-submenu t
 100   "*Non-nil if buckets of tags are to be turned into submenus.
 101 This option is ignored if `semantic-imenu-bucketize-file' is nil."
 102   :group 'semantic-imenu
 103   :type 'boolean)
 104 (make-variable-buffer-local 'semantic-imenu-buckets-to-submenu)
 105
 106 ;;;###autoload
 107 (defcustom semantic-imenu-expand-type-members t
 108   "*Non-nil if types should have submenus with members in them."
 109   :group 'semantic-imenu
 110   :type 'boolean)
 111 (make-variable-buffer-local 'semantic-imenu-expand-type-members)
 112 (semantic-varalias-obsolete 'semantic-imenu-expand-type-parts
 113                             'semantic-imenu-expand-type-members)
 114
 115 (defcustom semantic-imenu-bucketize-type-members t
 116   "*Non-nil if members of a type should be grouped into buckets.
 117 nil means to keep them in the same order.
 118 Overriden to nil if `semantic-imenu-bucketize-file' is nil."
 119   :group 'semantic-imenu
 120   :type 'boolean)
 121 (make-variable-buffer-local 'semantic-imenu-bucketize-type-parts)
 122 (semantic-varalias-obsolete 'semantic-imenu-bucketize-type-parts
 123                             'semantic-imenu-bucketize-type-members)
 124
 125 (defcustom semantic-imenu-sort-bucket-function nil
 126   "*Function to use when sorting tags in the buckets of functions.
 127 See `semantic-bucketize' and the FILTER argument for more details on this function."
 128   :group 'semantic-imenu
 129   :type '(radio (const :tag "No Sorting" nil)
 130                 (const semantic-sort-tags-by-name-increasing)
 131                 (const semantic-sort-tags-by-name-decreasing)
 132                 (const semantic-sort-tags-by-type-increasing)
 133                 (const semantic-sort-tags-by-type-decreasing)
 134                 (const semantic-sort-tags-by-name-increasing-ci)
 135                 (const semantic-sort-tags-by-name-decreasing-ci)
 136                 (const semantic-sort-tags-by-type-increasing-ci)
 137                 (const semantic-sort-tags-by-type-decreasing-ci)
 138                 (function)))
 139 (make-variable-buffer-local 'semantic-imenu-sort-bucket-function)
 140
 141 (defcustom semantic-imenu-index-directory nil
 142   "*Non nil to index the entire directory for tags.
 143 Doesn't actually parse the entire directory, but displays tags for all files
 144 currently listed in the current Semantic database.
 145 This variable has no meaning if semanticdb is not active."
 146   :group 'semantic-imenu
 147   :type 'boolean)
 148
 149 (defcustom semantic-imenu-auto-rebuild-directory-indexes nil
 150   "*If non-nil automatically rebuild directory index imenus.
 151 That is when a directory index imenu is updated, automatically rebuild
 152 other buffer local ones based on the same semanticdb."
 153   :group 'semantic-imenu
 154   :type 'boolean)
 155
 156 (defvar semantic-imenu-directory-current-file nil
 157   "When building a file index, this is the file name currently being built.")
 158
 159 (defvar semantic-imenu-auto-rebuild-running nil
 160   "Non-nil if `semantic-imenu-rebuild-directory-indexes' is running.")
 161
 162 ;;;###autoload
 163 (defvar semantic-imenu-expandable-tag-classes '(type)
 164   "List of expandable tag classes.
 165 Tags of those classes will be given submenu with children.
 166 By default, a `type' has interesting children.  In Texinfo, however, a
 167 `section' has interesting children.")
 168 (make-variable-buffer-local 'semantic-imenu-expandable-tag-classes)
 169 (semantic-varalias-obsolete 'semantic-imenu-expandable-token
 170                             'semantic-imenu-expandable-tag-classes)
 171
 172 ;;; Code:
 173 (defun semantic-imenu-tag-overlay (tag)
 174   "Return the overlay belonging to tag.
 175 If TAG doesn't have an overlay, and instead as a vector of positions,
 176 concoct a combination of file name, and position."
 177   (let ((o (semantic-tag-overlay tag)))
 178     (if (not (semantic-overlay-p o))
 179         (let ((v (make-vector 3 nil)))
 180           (aset v 0 semantic-imenu-directory-current-file)
 181           (aset v 1 (aref o 0))
 182           (aset v 2 (aref o 1))
 183           v)
 184       o)))
 185
 186 (defun semantic-imenu-goto-function (name position &optional rest)
 187   "Move point associated with NAME to POSITION.
 188 Used to override function `imenu-default-goto-function' so that we can continue
 189 to use overlays to maintain the current position.
 190 Optional argument REST is some extra stuff."
 191   (if (semantic-overlay-p position)
 192       (let ((os (semantic-overlay-start position))
 193             (ob (semantic-overlay-buffer position)))
 194         (if os
 195             (progn
 196               (if (not (eq ob (current-buffer)))
 197                   (switch-to-buffer ob))
 198               (imenu-default-goto-function name os rest))
 199           ;; This should never happen, but check anyway.
 200           (message "Imenu is out of date, try again. (internal bug)")
 201           (setq imenu--index-alist nil)))
 202     ;; When the POSITION is actually a pair of numbers in an array, then
 203     ;; the file isn't loaded into the current buffer.
 204     (if (vectorp position)
 205         (let ((file (aref position 0))
 206               (pos (aref position 1)))
 207           (and file (find-file file))
 208           (imenu-default-goto-function name pos rest))
 209       ;; When the POSITION is the symbol 'file-only' it means that this
 210       ;; is a directory index entry and there is no tags in this
 211       ;; file. So just jump to the beginning of the file.
 212       (if (eq position 'file-only)
 213           (progn
 214             (find-file name)
 215             (imenu-default-goto-function name (point-min) rest))
 216         ;; Probably POSITION don't came from a semantic imenu.  Try
 217         ;; the default imenu goto function.
 218         (condition-case nil
 219             (imenu-default-goto-function name position rest)
 220           (error
 221            (message "Semantic Imenu override problem. (Internal bug)")
 222            (setq imenu--index-alist nil)))))
 223     ))
 224
 225 (defun semantic-imenu-flush-fcn (&optional ignore)
 226   "This function is called as a hook to clear the imenu cache.
 227 It is cleared after any parsing.
 228 IGNORE arguments."
 229   (if (eq imenu-create-index-function 'semantic-create-imenu-index)
 230       (setq imenu--index-alist nil
 231             imenu-menubar-modified-tick 0))
 232   (remove-hook 'semantic-after-toplevel-cache-change-hook
 233                'semantic-imenu-flush-fcn t)
 234   (remove-hook 'semantic-after-partial-cache-change-hook
 235                'semantic-imenu-flush-fcn t)
 236   )
 237
 238 ;;;###autoload
 239 (defun semantic-create-imenu-index (&optional stream)
 240   "Create an imenu index for any buffer which supports Semantic.
 241 Uses the output of the Semantic parser to create the index.
 242 Optional argument STREAM is an optional stream of tags used to create menus."
 243   (setq imenu-default-goto-function 'semantic-imenu-goto-function)
 244   (prog1
 245       (if (and semantic-imenu-index-directory
 246                (featurep 'semanticdb)
 247                (semanticdb-minor-mode-p))
 248           (semantic-create-imenu-directory-index
 249            (or stream (semantic-fetch-tags)))
 250         (semantic-create-imenu-index-1
 251          (or stream (semantic-fetch-tags)) nil))
 252     (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
 253     (add-hook 'semantic-after-toplevel-cache-change-hook
 254               'semantic-imenu-flush-fcn nil t)
 255     (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
 256     (add-hook 'semantic-after-partial-cache-change-hook
 257               'semantic-imenu-flush-fcn nil t)))
 258
 259 (defun semantic-create-imenu-directory-index (&optional stream)
 260   "Create an IMENU tag index based on all files active in semanticdb.
 261 Optional argument STREAM is the stream of tags for the current buffer."
 262   (if (not semanticdb-current-database)
 263       (semantic-create-imenu-index-1 stream nil)
 264     ;; We have a database, list all files, with the current file on top.
 265     (let ((index (list
 266                   (cons (oref semanticdb-current-table file)
 267                         (or (semantic-create-imenu-index-1 stream nil)
 268                             ;; No tags in this file
 269                             'file-only))))
 270           (tables (semanticdb-get-database-tables semanticdb-current-database)))
 271       (working-status-forms "Imenu Directory Index" "done"
 272         (while tables
 273           (let ((semantic-imenu-directory-current-file
 274                  (oref (car tables) file))
 275                 tags)
 276             (when (and (not (eq (car tables) semanticdb-current-table))
 277                        (semanticdb-live-p (car tables))
 278                        (semanticdb-equivalent-mode (car tables))
 279                        )
 280               (setq tags (oref (car tables) tags)
 281                     index (cons (cons semantic-imenu-directory-current-file
 282                                       (or (and tags
 283                                                ;; don't pass nil stream because
 284                                                ;; it will use the current
 285                                                ;; buffer
 286                                                (semantic-create-imenu-index-1
 287                                                 (oref (car tables) tags)
 288                                                 nil))
 289                                           ;; no tags in the file
 290                                           'file-only))
 291                                 index)))
 292             (setq tables (cdr tables)))
 293           (working-dynamic-status))
 294         (working-dynamic-status t))
 295
 296       ;; If enabled automatically rebuild other imenu directory
 297       ;; indexes based on the same Semantic database
 298       (or (not semantic-imenu-auto-rebuild-directory-indexes)
 299           ;; If auto rebuild already in progress does nothing
 300           semantic-imenu-auto-rebuild-running
 301           (unwind-protect
 302               (progn
 303                 (setq semantic-imenu-auto-rebuild-running t)
 304                 (semantic-imenu-rebuild-directory-indexes
 305                  semanticdb-current-database))
 306             (setq semantic-imenu-auto-rebuild-running nil)))
 307
 308       (nreverse index))))
 309
 310 (defun semantic-create-imenu-index-1 (stream &optional parent)
 311   "Create an imenu index for any buffer which supports Semantic.
 312 Uses the output of the Semantic parser to create the index.
 313 STREAM is a stream of tags used to create menus.
 314 Optional argument PARENT is a tag parent of STREAM."
 315   (let ((tags stream)
 316         (semantic-imenu-adopt-external-members
 317          semantic-imenu-adopt-external-members))
 318     ;; If we should regroup, do so.
 319     (if semantic-imenu-adopt-external-members
 320         (setq tags (semantic-adopt-external-members tags)
 321               ;; Don't allow recursion here.
 322               semantic-imenu-adopt-external-members nil))
 323     ;; Test for bucketing vs not.
 324     (if semantic-imenu-bucketize-file
 325         (let ((buckets (semantic-bucketize
 326                         tags parent
 327                         semantic-imenu-sort-bucket-function))
 328               item name
 329               index)
 330           (cond
 331            ((null buckets)
 332             nil)
 333            ((or (cdr-safe buckets) ;; if buckets has more than one item in it.
 334                 (not semantic-imenu-buckets-to-submenu)) ;; to force separators between buckets
 335             (while buckets
 336               (setq name (car (car buckets))
 337                     item (cdr (car buckets)))
 338               (if semantic-imenu-buckets-to-submenu
 339                   (progn
 340                     ;; Make submenus
 341                     (if item
 342                         (setq index
 343                               (cons (cons name
 344                                           (semantic-create-imenu-subindex item))
 345                                     index))))
 346                 ;; Glom everything together with "---" between
 347                 (if item
 348                     (setq index
 349                           (append index
 350                                   ;; do not create a menu separator in the parent menu
 351                                   ;; when creating a sub-menu
 352                                   (if (memq (semantic-tag-class (car item))
 353                                             semantic-imenu-expandable-tag-classes)
 354                                       (semantic-create-imenu-subindex item)
 355                                     (cons
 356                                      '("---")
 357                                      (semantic-create-imenu-subindex item)))))
 358                   ))
 359               (setq buckets (cdr buckets)))
 360             (if semantic-imenu-buckets-to-submenu
 361                 (nreverse index)
 362               index))
 363            (t
 364             (setq name (car (car buckets))
 365                   item (cdr (car buckets)))
 366             (semantic-create-imenu-subindex item))))
 367       ;; Else, group everything together
 368       (semantic-create-imenu-subindex tags))))
 369
 370 (defun semantic-create-imenu-subindex (tags)
 371   "From TAGS, create an imenu index of interesting things."
 372   (let ((notypecheck (not semantic-imenu-expand-type-members))
 373         children index tag parts)
 374     (while tags
 375       (setq tag (car tags)
 376             children (semantic-tag-components-with-overlays tag))
 377       (if (and (not notypecheck)
 378                (memq (semantic-tag-class tag)
 379                      semantic-imenu-expandable-tag-classes)
 380                children
 381                )
 382           ;; to keep an homogeneous menu organisation, type menu items
 383           ;; always have a sub-menu with at least the *definition*
 384           ;; item (even if the tag has no type components)
 385           (progn
 386             (setq parts children)
 387             ;; There is options which create the submenu
 388             ;;  * Type has an overlay, but children do.
 389             ;; The type doesn't have to have it's own overlay,
 390             ;; but a type with no overlay and no children should be
 391             ;; invalid.
 392             (setq index
 393                   (cons
 394                    (cons
 395                     (funcall semantic-imenu-summary-function tag)
 396                     ;; Add a menu for getting at the type definitions
 397                     (if (and parts
 398                              ;; Note to self: enable menu items for
 399                              ;; sub parts even if they are not proper
 400                              ;; tags.
 401                              (semantic-tag-p (car parts)))
 402                         (let ((submenu
 403                                (if (and semantic-imenu-bucketize-type-members
 404                                         semantic-imenu-bucketize-file)
 405                                    (semantic-create-imenu-index-1 parts tag)
 406                                  (semantic-create-imenu-subindex parts))))
 407                           ;; Only add a *definition* if we have a postion
 408                           ;; in that type tag.
 409                           (if (semantic-tag-with-position-p tag)
 410                               (cons
 411                                (cons "*definition*"
 412                                      (semantic-imenu-tag-overlay tag))
 413                                submenu)
 414                             submenu))
 415                       ;; There were no parts, or something like that, so
 416                       ;; instead just put the definition here.
 417                       (if (semantic-tag-with-position-p tag)
 418                           (semantic-imenu-tag-overlay tag)
 419                         nil)
 420                       ))
 421                    index)))
 422         (if (semantic-tag-with-position-p tag)
 423             (setq index (cons
 424                          (cons
 425                           (funcall semantic-imenu-summary-function tag)
 426                           (semantic-imenu-tag-overlay tag))
 427                          index))))
 428       (setq tags (cdr tags)))
 429     ;; `imenu--split-submenus' sort submenus according to
 430     ;; `imenu-sort-function' setting and split them up if they are
 431     ;; longer than `imenu-max-items'.
 432     (imenu--split-submenus (nreverse index))))
 433
 434 ;;; directory imenu rebuilding.
 435 ;;
 436 (defun semantic-imenu-rebuild-directory-indexes (db)
 437   "Rebuild directory index imenus based on Semantic database DB."
 438   (let ((l (buffer-list))
 439         b)
 440     (while l
 441       (setq b (car l)
 442             l (cdr l))
 443       (if (and (not (eq b (current-buffer)))
 444                (buffer-live-p b))
 445           (with-current-buffer b
 446             ;; If there is a buffer local Semantic index directory
 447             ;; imenu
 448             (when (and (eq imenu-create-index-function
 449                            'semantic-create-imenu-index)
 450                        semanticdb-current-database
 451                        (eq semanticdb-current-database db))
 452               (working-temp-message
 453                "Building %s Semantic directory index imenu"
 454                (buffer-name b))
 455               ;; Rebuild the imenu
 456               (imenu--cleanup)
 457               (setq imenu--index-alist nil)
 458               (funcall
 459                (if (fboundp 'imenu-menu-filter)
 460                    ;; XEmacs imenu
 461                    'imenu-menu-filter
 462                  ;; Emacs imenu
 463                  'imenu-update-menubar))))))))
 464
 465 (defun semantic-imenu-semanticdb-hook ()
 466   "Function to be called from `semanticdb-mode-hooks'.
 467 Clears all imenu menus that may be depending on the database."
 468   (semantic-map-buffers
 469    #'(lambda ()
 470        ;; Set up semanticdb environment if enabled.
 471        (if (semanticdb-minor-mode-p)
 472            (semanticdb-semantic-init-hook-fcn))
 473        ;; Clear imenu cache to redraw the imenu.
 474        (semantic-imenu-flush-fcn))))
 475
 476 (add-hook 'semanticdb-mode-hooks 'semantic-imenu-semanticdb-hook)
 477
 478 ;;; Interactive Utilities
 479 ;;
 480 (defun semantic-imenu-toggle-bucketize-file ()
 481   "Toggle the ability of imenu to bucketize the current file."
 482   (interactive)
 483   (setq semantic-imenu-bucketize-file (not semantic-imenu-bucketize-file))
 484   ;; Force a rescan
 485   (setq imenu--index-alist nil))
 486
 487 (defun semantic-imenu-toggle-buckets-to-submenu ()
 488   "Toggle the ability of imenu to turn buckets into submenus."
 489   (interactive)
 490   (setq semantic-imenu-buckets-to-submenu (not semantic-imenu-buckets-to-submenu))
 491   ;; Force a rescan
 492   (setq imenu--index-alist nil))
 493
 494 (defun semantic-imenu-toggle-bucketize-type-parts ()
 495   "Toggle the ability of imenu to bucketize the current file."
 496   (interactive)
 497   (setq semantic-imenu-bucketize-type-members (not semantic-imenu-bucketize-type-members))
 498   ;; Force a rescan
 499   (setq imenu--index-alist nil))
 500
 501 ;;; Which function support
 502 ;;
 503 ;; The which-function library will display the current function in the
 504 ;; mode line.  It tries do do this through imenu.  With a semantic parsed
 505 ;; buffer, there is a much more efficient way of doing this.
 506 ;; Advise `which-function' so that we optionally use semantic tags
 507 ;; instead, and get better stuff.
 508 (require 'advice)
 509
 510 (defvar semantic-which-function 'semantic-default-which-function
 511   "Function to convert semantic tags into `which-function' text.")
 512
 513 (defcustom semantic-which-function-use-color nil
 514   "*Use color when displaying the current function with `which-function'."
 515   :group 'semantic-imenu
 516   :type 'boolean)
 517
 518 (defun semantic-default-which-function (taglist)
 519   "Convert TAGLIST into a string usable by `which-function'.
 520 Returns the first tag name in the list, unless it is a type,
 521 in which case it concatenates them together."
 522   (cond ((eq (length taglist) 1)
 523          (semantic-format-tag-abbreviate
 524           (car taglist) nil semantic-which-function-use-color))
 525         ((memq (semantic-tag-class (car taglist))
 526                semantic-imenu-expandable-tag-classes)
 527          (concat (semantic-format-tag-name
 528                   (car taglist) semantic-which-function-use-color) "."
 529                  ;; recurse until we no longer have a type
 530                  ;; or any tags left.
 531                  (semantic-default-which-function (cdr taglist))))
 532         (t (semantic-format-tag-abbreviate
 533             (car taglist) nil semantic-which-function-use-color))))
 534
 535 (defadvice which-function (around semantic-which activate)
 536   "Choose the function to display via semantic if it is currently active."
 537   (if (and (featurep 'semantic) semantic--buffer-cache)
 538       (let ((ol (semantic-find-tag-by-overlay)))
 539         (setq ad-return-value (funcall semantic-which-function ol)))
 540     ad-do-it))
 541
 542 (provide 'semantic-imenu)
 543
 544 ;;; semantic-imenu.el ends here