code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/mru-bookmark.el

   1 ;;; semantic/mru-bookmark.el --- Automatic bookmark tracking
   2
   3 ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Using editing hooks, track the most recently visited or poked tags,
  25 ;; and keep a list of them, with the current point in from, and sorted
  26 ;; by most recently used.
  27 ;;
  28 ;; I envision this would be used in place of switch-buffers once
  29 ;; someone got the hang of it.
  30 ;;
  31 ;; I'd also like to see this used to provide some nice defaults for
  32 ;; other programs where logical destinations or targets are the tags
  33 ;; that have been recently edited.
  34 ;;
  35 ;; Quick Start:
  36 ;;
  37 ;; M-x global-semantic-mru-bookmark-mode RET
  38 ;;
  39 ;; < edit some code >
  40 ;;
  41 ;; C-x B  <select a tag name> RET
  42 ;;
  43 ;; In the above, the history is pre-filled with the tags you recenetly
  44 ;; edited in the order you edited them.
  45
  46 ;;; Code:
  47
  48 (require 'semantic)
  49 (require 'eieio-base)
  50 (require 'ring)
  51
  52 (declare-function data-debug-new-buffer "data-debug")
  53 (declare-function data-debug-insert-object-slots "eieio-datadebug")
  54 (declare-function semantic-momentary-highlight-tag "semantic/decorate")
  55
  56 ;;; TRACKING CORE
  57 ;;
  58 ;; Data structure for tracking MRU tag locations
  59
  60 (defclass semantic-bookmark (eieio-named)
  61   ((tag :initarg :tag
  62         :type semantic-tag
  63         :documentation "The TAG this bookmark belongs to.")
  64    (parent :type (or semantic-tag null)
  65            :documentation "The tag that is the parent of :tag.")
  66    (offset :type number
  67          :documentation "The offset from `tag' start that is
  68 somehow interesting.")
  69    (filename :type string
  70              :documentation "String the tag belongs to.
  71 Set this when the tag gets unlinked from the buffer it belongs to.")
  72    (frequency :type number
  73               :initform 0
  74               :documentation "Track the frequency this tag is visited.")
  75    (reason :type symbol
  76            :initform t
  77            :documentation
  78            "The reason this tag is interesting.
  79 Nice values are 'edit, 'read, 'jump, and 'mark.
  80  edit - created because the tag text was edited.
  81  read - created because point lingered in tag text.
  82  jump - jumped to another tag from this tag.
  83  mark - created a regular mark in this tag.")
  84    )
  85   "A single bookmark.")
  86
  87 (defmethod initialize-instance :AFTER ((sbm semantic-bookmark) &rest fields)
  88   "Initialize the bookmark SBM with details about :tag."
  89   (condition-case nil
  90       (save-excursion
  91         (oset sbm filename (semantic-tag-file-name (oref sbm tag)))
  92         (semantic-go-to-tag (oref sbm tag))
  93         (oset sbm parent (semantic-current-tag-parent)))
  94     (error (message "Error bookmarking tag.")))
  95   )
  96
  97 (defmethod semantic-mrub-visit ((sbm semantic-bookmark))
  98   "Visit the semantic tag bookmark SBM.
  99 Uses `semantic-go-to-tag' and highlighting."
 100   (require 'semantic/decorate)
 101   (with-slots (tag filename) sbm
 102     ;; Go to the tag
 103     (when (not (semantic-tag-in-buffer-p tag))
 104       (let ((fn (or (semantic-tag-file-name tag)
 105                     filename)))
 106         (set-buffer (find-file-noselect fn))))
 107     (semantic-go-to-tag (oref sbm tag) (oref sbm parent))
 108     ;; Go back to the offset.
 109     (condition-case nil
 110         (let ((o (oref sbm offset)))
 111           (forward-char o))
 112       (error nil))
 113     ;; make it visible
 114     (switch-to-buffer (current-buffer))
 115     (semantic-momentary-highlight-tag tag)
 116     ))
 117
 118 (defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason)
 119   "Update the existing bookmark SBM.
 120 POINT is some important location.
 121 REASON is a symbol.  See slot `reason' on `semantic-bookmark'."
 122   (condition-case nil
 123       (progn
 124         (with-slots (tag offset frequency) sbm
 125           (setq offset (- point (semantic-tag-start tag)))
 126           (setq frequency (1+ frequency))
 127           )
 128         (oset sbm reason reason))
 129     ;; This can fail on XEmacs at miscelaneous times.
 130     (error nil))
 131   )
 132
 133 (defmethod semantic-mrub-preflush ((sbm semantic-bookmark))
 134   "Method called on a tag before the current buffer list of tags is flushed.
 135 If there is a buffer match, unlink the tag."
 136   (let ((tag (oref sbm tag))
 137         (parent (when (slot-boundp sbm 'parent)
 138                   (oref sbm parent))))
 139     (let ((b (semantic-tag-in-buffer-p tag)))
 140       (when (and b (eq b (current-buffer)))
 141         (semantic--tag-unlink-from-buffer tag)))
 142
 143     (when parent
 144       (let ((b (semantic-tag-in-buffer-p parent)))
 145         (when (and b (eq b (current-buffer)))
 146           (semantic--tag-unlink-from-buffer parent))))))
 147
 148 (defclass semantic-bookmark-ring ()
 149   ((ring :initarg :ring
 150          :type ring
 151          :documentation
 152          "List of `semantic-bookmark' objects.
 153 This list is maintained as a list with the first item
 154 being the current location, and the rest being a list of
 155 items that were recently visited.")
 156    (current-index :initform 0
 157                   :type number
 158                   :documentation
 159                   "The current index into RING for some operation.
 160 User commands use this to move through the ring, or reset.")
 161    )
 162   "Track the current MRU stack of bookmarks.
 163 We can't use the built-in ring data structure because we need
 164 to delete some items from the ring when we don't have the data.")
 165
 166 (defvar semantic-mru-bookmark-ring (semantic-bookmark-ring
 167                                     "Ring"
 168                                     :ring (make-ring 20))
 169   "The MRU bookmark ring.
 170 This ring tracks the most recent active tags of interest.")
 171
 172 (defun semantic-mrub-find-nearby-tag (point)
 173   "Find a nearby tag to be pushed for this current location.
 174 Argument POINT is where to find the tag near."
 175   ;; I thought this was a good idea, but it is not!
 176   ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date.
 177   (let ((tag (semantic-current-tag)))
 178     (when (or (not tag) (semantic-tag-of-class-p tag 'type))
 179       (let ((nearby (or (semantic-find-tag-by-overlay-next point)
 180                         (semantic-find-tag-by-overlay-prev point))))
 181         (when nearby (setq tag nearby))))
 182     tag))
 183
 184 (defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point
 185                                &optional reason)
 186   "Add a bookmark to the ring SBR from POINT.
 187 REASON is why it is being pushed.  See doc for `semantic-bookmark'
 188 for possible reasons.
 189 The resulting bookmark is then sorted within the ring."
 190   (let* ((ring (oref sbr ring))
 191          (tag (semantic-mrub-find-nearby-tag (point)))
 192          (idx 0))
 193     (when tag
 194       (while (and (not (ring-empty-p ring)) (< idx (ring-size ring)))
 195         (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag)
 196                                     tag)
 197             (ring-remove ring idx))
 198         (setq idx (1+ idx)))
 199       ;; Create a new mark
 200       (let ((sbm (semantic-bookmark (semantic-tag-name tag)
 201                                     :tag tag)))
 202         ;; Take the mark, and update it for the current state.
 203         (ring-insert ring sbm)
 204         (semantic-mrub-update sbm point reason))
 205       )))
 206
 207 (defun semantic-mrub-cache-flush-fcn ()
 208   "Function called in the `semantic-before-toplevel-cache-flush-hook`.
 209 Cause tags in the ring to become unlinked."
 210   (let* ((ring (oref semantic-mru-bookmark-ring ring))
 211          (len (ring-length ring))
 212          (idx 0)
 213          )
 214     (while (< idx len)
 215       (semantic-mrub-preflush (ring-ref ring idx))
 216       (setq idx (1+ idx)))))
 217
 218 (add-hook 'semantic-before-toplevel-cache-flush-hook
 219           'semantic-mrub-cache-flush-fcn)
 220
 221 ;;; EDIT tracker
 222 ;;
 223 (defvar semantic-mrub-last-overlay nil
 224   "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.")
 225
 226 (defun semantic-mru-bookmark-change-hook-fcn (overlay)
 227   "Function set into `semantic-edits-new/move-change-hook's.
 228 Argument OVERLAY is the overlay created to mark the change.
 229 This function pushes tags onto the tag ring."
 230   ;; Dup?
 231   (when (not (eq overlay semantic-mrub-last-overlay))
 232     (setq semantic-mrub-last-overlay overlay)
 233     (semantic-mrub-push semantic-mru-bookmark-ring
 234                         (point)
 235                         'edit)))
 236
 237 ;;; MINOR MODE
 238 ;;
 239 ;; Tracking minor mode.
 240
 241 (defcustom global-semantic-mru-bookmark-mode nil
 242   "*If non-nil enable global use of variable `semantic-mru-bookmark-mode'.
 243 When this mode is enabled, changes made to a buffer are highlighted
 244 until the buffer is reparsed."
 245   :group 'semantic
 246   :group 'semantic-modes
 247   :type 'boolean
 248   :require 'semantic-util-modes
 249   :initialize 'custom-initialize-default
 250   :set (lambda (sym val)
 251          (global-semantic-mru-bookmark-mode (if val 1 -1))))
 252
 253 ;;;###autoload
 254 (defun global-semantic-mru-bookmark-mode (&optional arg)
 255   "Toggle global use of option `semantic-mru-bookmark-mode'.
 256 If ARG is positive, enable, if it is negative, disable.
 257 If ARG is nil, then toggle."
 258   (interactive "P")
 259   (setq global-semantic-mru-bookmark-mode
 260         (semantic-toggle-minor-mode-globally
 261          'semantic-mru-bookmark-mode arg)))
 262
 263 (defcustom semantic-mru-bookmark-mode-hook nil
 264   "*Hook run at the end of function `semantic-mru-bookmark-mode'."
 265   :group 'semantic
 266   :type 'hook)
 267
 268 (defvar semantic-mru-bookmark-mode-map
 269   (let ((km (make-sparse-keymap)))
 270     (define-key km "\C-xB" 'semantic-mrub-switch-tags)
 271     km)
 272   "Keymap for mru-bookmark minor mode.")
 273
 274 (defvar semantic-mru-bookmark-mode nil
 275   "Non-nil if mru-bookmark minor mode is enabled.
 276 Use the command `semantic-mru-bookmark-mode' to change this variable.")
 277 (make-variable-buffer-local 'semantic-mru-bookmark-mode)
 278
 279 (defun semantic-mru-bookmark-mode-setup ()
 280   "Setup option `semantic-mru-bookmark-mode'.
 281 The minor mode can be turned on only if semantic feature is available
 282 and the current buffer was set up for parsing.  When minor mode is
 283 enabled parse the current buffer if needed.  Return non-nil if the
 284 minor mode is enabled."
 285   (if semantic-mru-bookmark-mode
 286       (if (not (and (featurep 'semantic) (semantic-active-p)))
 287           (progn
 288             ;; Disable minor mode if semantic stuff not available
 289             (setq semantic-mru-bookmark-mode nil)
 290             (error "Buffer %s was not set up for parsing"
 291                    (buffer-name)))
 292         (semantic-make-local-hook 'semantic-edits-new-change-hooks)
 293         (add-hook 'semantic-edits-new-change-hooks
 294                   'semantic-mru-bookmark-change-hook-fcn nil t)
 295         (add-hook 'semantic-edits-move-change-hooks
 296                   'semantic-mru-bookmark-change-hook-fcn nil t)
 297         )
 298     ;; Remove hooks
 299     (remove-hook 'semantic-edits-new-change-hooks
 300                  'semantic-mru-bookmark-change-hook-fcn t)
 301     (remove-hook 'semantic-edits-move-change-hooks
 302                  'semantic-mru-bookmark-change-hook-fcn t)
 303     )
 304   semantic-mru-bookmark-mode)
 305
 306 (defun semantic-mru-bookmark-mode (&optional arg)
 307   "Minor mode for tracking tag-based bookmarks automatically.
 308 Tag based bookmarks a tracked based on editing and viewing habits
 309 and can then be navigated via the MRU bookmark keymap.
 310
 311 \\{semantic-mru-bookmark-mode-map}
 312
 313 With prefix argument ARG, turn on if positive, otherwise off.  The
 314 minor mode can be turned on only if semantic feature is available and
 315 the current buffer was set up for parsing.  Return non-nil if the
 316 minor mode is enabled."
 317   (interactive
 318    (list (or current-prefix-arg
 319              (if semantic-mru-bookmark-mode 0 1))))
 320   (setq semantic-mru-bookmark-mode
 321         (if arg
 322             (>
 323              (prefix-numeric-value arg)
 324              0)
 325           (not semantic-mru-bookmark-mode)))
 326   (semantic-mru-bookmark-mode-setup)
 327   (run-hooks 'semantic-mru-bookmark-mode-hook)
 328   (if (interactive-p)
 329       (message "mru-bookmark minor mode %sabled"
 330                (if semantic-mru-bookmark-mode "en" "dis")))
 331   (semantic-mode-line-update)
 332   semantic-mru-bookmark-mode)
 333
 334 (semantic-add-minor-mode 'semantic-mru-bookmark-mode
 335                          "k"
 336                          semantic-mru-bookmark-mode-map)
 337
 338 ;;; COMPLETING READ
 339 ;;
 340 ;; Ask the user for a tag in MRU order.
 341 (defun semantic-mrub-read-history nil
 342   "History of `semantic-mrub-completing-read'.")
 343
 344 (defun semantic-mrub-ring-to-assoc-list (ring)
 345   "Convert RING into an association list for completion."
 346   (let ((idx 0)
 347         (len (ring-length ring))
 348         (al nil))
 349     (while (< idx len)
 350       (let ((r (ring-ref ring idx)))
 351         (setq al (cons (cons (oref r :object-name) r)
 352                        al)))
 353       (setq idx (1+ idx)))
 354     (nreverse al)))
 355
 356 (defun semantic-mrub-completing-read (prompt)
 357   "Do a `completing-read' on elements from the mru bookmark ring.
 358 Argument PROMPT is the promot to use when reading."
 359   (if (ring-empty-p (oref semantic-mru-bookmark-ring ring))
 360       (error "Semantic Bookmark ring is currently empty"))
 361   (let* ((ring (oref semantic-mru-bookmark-ring ring))
 362          (ans nil)
 363          (alist (semantic-mrub-ring-to-assoc-list ring))
 364          (first (cdr (car alist)))
 365          (semantic-mrub-read-history nil)
 366          )
 367     ;; Don't include the current tag.. only those that come after.
 368     (if (semantic-equivalent-tag-p (oref first tag)
 369                                    (semantic-current-tag))
 370         (setq first (cdr (car (cdr alist)))))
 371     ;; Create a fake history list so we don't have to bind
 372     ;; M-p and M-n to our special cause.
 373     (let ((elts (reverse alist)))
 374       (while elts
 375         (setq semantic-mrub-read-history
 376               (cons (car (car elts)) semantic-mrub-read-history))
 377         (setq elts (cdr elts))))
 378     (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history))
 379
 380     ;; Do the read/prompt
 381     (let ((prompt (if first (format "%s (%s): " prompt
 382                                     (semantic-format-tag-name
 383                                      (oref first tag) t)
 384                                     )
 385                     (concat prompt ": ")))
 386           )
 387       (setq ans
 388             (completing-read prompt alist nil nil nil 'semantic-mrub-read-history)))
 389     ;; Calculate the return tag.
 390     (if (string= ans "")
 391         (setq ans first)
 392       ;; Return the bookmark object.
 393       (setq ans (assoc ans alist))
 394       (if ans
 395           (cdr ans)
 396         ;; no match.  Custom word.  Look it up somwhere?
 397         nil)
 398       )))
 399
 400 (defun semantic-mrub-switch-tags (tagmark)
 401   "Switch tags to TAGMARK.
 402 Selects a new tag via promt through the mru tag ring.
 403 Jumps to the tag and highlights it briefly."
 404   (interactive (list (semantic-mrub-completing-read "Switch to tag")))
 405   (if (not (semantic-bookmark-p tagmark))
 406       (signal 'wrong-type-argument tagmark))
 407
 408   (semantic-mrub-push semantic-mru-bookmark-ring
 409                       (point)
 410                       'jump)
 411   (semantic-mrub-visit tagmark)
 412   )
 413
 414 ;;; Debugging
 415 ;;
 416 (defun semantic-adebug-mrub ()
 417   "Display a list of items in the MRU bookmarks list.
 418 Useful for debugging mrub problems."
 419   (interactive)
 420   (require 'eieio-datadebug)
 421   (let* ((out semantic-mru-bookmark-ring))
 422     (data-debug-new-buffer "*TAG RING ADEBUG*")
 423     (data-debug-insert-object-slots out "]")
 424     ))
 425
 426
 427 (provide 'semantic/mru-bookmark)
 428
 429 ;; Local variables:
 430 ;; generated-autoload-file: "loaddefs.el"
 431 ;; generated-autoload-feature: semantic/loaddefs
 432 ;; generated-autoload-load-name: "semantic/mru-bookmark"
 433 ;; End:
 434
 435 ;;; semantic/mru-bookmark.el ends here