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, 2010, 2011 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 recently
  44 ;; edited in the order you edited them.
  45
  46 ;;; Code:
  47
  48 (eval-when-compile (require 'cl))
  49 (require 'semantic)
  50 (require 'eieio-base)
  51 (require 'ring)
  52
  53 (declare-function data-debug-new-buffer "data-debug")
  54 (declare-function data-debug-insert-object-slots "eieio-datadebug")
  55 (declare-function semantic-momentary-highlight-tag "semantic/decorate")
  56
  57 ;;; TRACKING CORE
  58 ;;
  59 ;; Data structure for tracking MRU tag locations
  60
  61 (defclass semantic-bookmark (eieio-named)
  62   ((tag :initarg :tag
  63         :type semantic-tag
  64         :documentation "The TAG this bookmark belongs to.")
  65    (parent :type (or semantic-tag null)
  66            :documentation "The tag that is the parent of :tag.")
  67    (offset :type number
  68          :documentation "The offset from `tag' start that is
  69 somehow interesting.")
  70    (filename :type string
  71              :documentation "String the tag belongs to.
  72 Set this when the tag gets unlinked from the buffer it belongs to.")
  73    (frequency :type number
  74               :initform 0
  75               :documentation "Track the frequency this tag is visited.")
  76    (reason :type symbol
  77            :initform t
  78            :documentation
  79            "The reason this tag is interesting.
  80 Nice values are 'edit, 'read, 'jump, and 'mark.
  81  edit - created because the tag text was edited.
  82  read - created because point lingered in tag text.
  83  jump - jumped to another tag from this tag.
  84  mark - created a regular mark in this tag.")
  85    )
  86   "A single bookmark.")
  87
  88 (defmethod initialize-instance :AFTER ((sbm semantic-bookmark) &rest fields)
  89   "Initialize the bookmark SBM with details about :tag."
  90   (condition-case nil
  91       (save-excursion
  92         (oset sbm filename (semantic-tag-file-name (oref sbm tag)))
  93         (semantic-go-to-tag (oref sbm tag))
  94         (oset sbm parent (semantic-current-tag-parent)))
  95     (error (message "Error bookmarking tag.")))
  96   )
  97
  98 (defmethod semantic-mrub-visit ((sbm semantic-bookmark))
  99   "Visit the semantic tag bookmark SBM.
 100 Uses `semantic-go-to-tag' and highlighting."
 101   (require 'semantic/decorate)
 102   (with-slots (tag filename) sbm
 103     ;; Go to the tag
 104     (when (not (semantic-tag-in-buffer-p tag))
 105       (let ((fn (or (semantic-tag-file-name tag)
 106                     filename)))
 107         (set-buffer (find-file-noselect fn))))
 108     (semantic-go-to-tag (oref sbm tag) (oref sbm parent))
 109     ;; Go back to the offset.
 110     (condition-case nil
 111         (let ((o (oref sbm offset)))
 112           (forward-char o))
 113       (error nil))
 114     ;; make it visible
 115     (switch-to-buffer (current-buffer))
 116     (semantic-momentary-highlight-tag tag)
 117     ))
 118
 119 (defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason)
 120   "Update the existing bookmark SBM.
 121 POINT is some important location.
 122 REASON is a symbol.  See slot `reason' on `semantic-bookmark'."
 123   (condition-case nil
 124       (progn
 125         (with-slots (tag offset frequency) sbm
 126           (setq offset (- point (semantic-tag-start tag)))
 127           (setq frequency (1+ frequency))
 128           )
 129         (oset sbm reason reason))
 130     ;; This can fail on XEmacs at miscellaneous times.
 131     (error nil))
 132   )
 133
 134 (defmethod semantic-mrub-preflush ((sbm semantic-bookmark))
 135   "Method called on a tag before the current buffer list of tags is flushed.
 136 If there is a buffer match, unlink the tag."
 137   (let ((tag (oref sbm tag))
 138         (parent (when (slot-boundp sbm 'parent)
 139                   (oref sbm parent))))
 140     (let ((b (semantic-tag-in-buffer-p tag)))
 141       (when (and b (eq b (current-buffer)))
 142         (semantic--tag-unlink-from-buffer tag)))
 143
 144     (when parent
 145       (let ((b (semantic-tag-in-buffer-p parent)))
 146         (when (and b (eq b (current-buffer)))
 147           (semantic--tag-unlink-from-buffer parent))))))
 148
 149 (defclass semantic-bookmark-ring ()
 150   ((ring :initarg :ring
 151          :type ring
 152          :documentation
 153          "List of `semantic-bookmark' objects.
 154 This list is maintained as a list with the first item
 155 being the current location, and the rest being a list of
 156 items that were recently visited.")
 157    (current-index :initform 0
 158                   :type number
 159                   :documentation
 160                   "The current index into RING for some operation.
 161 User commands use this to move through the ring, or reset.")
 162    )
 163   "Track the current MRU stack of bookmarks.
 164 We can't use the built-in ring data structure because we need
 165 to delete some items from the ring when we don't have the data.")
 166
 167 (defvar semantic-mru-bookmark-ring (semantic-bookmark-ring
 168                                     "Ring"
 169                                     :ring (make-ring 20))
 170   "The MRU bookmark ring.
 171 This ring tracks the most recent active tags of interest.")
 172
 173 (defun semantic-mrub-find-nearby-tag (point)
 174   "Find a nearby tag to be pushed for this current location.
 175 Argument POINT is where to find the tag near."
 176   ;; I thought this was a good idea, but it is not!
 177   ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date.
 178   (let ((tag (semantic-current-tag)))
 179     (when (or (not tag) (semantic-tag-of-class-p tag 'type))
 180       (let ((nearby (or (semantic-find-tag-by-overlay-next point)
 181                         (semantic-find-tag-by-overlay-prev point))))
 182         (when nearby (setq tag nearby))))
 183     tag))
 184
 185 (defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point
 186                                &optional reason)
 187   "Add a bookmark to the ring SBR from POINT.
 188 REASON is why it is being pushed.  See doc for `semantic-bookmark'
 189 for possible reasons.
 190 The resulting bookmark is then sorted within the ring."
 191   (let* ((ring (oref sbr ring))
 192          (tag (semantic-mrub-find-nearby-tag (point)))
 193          (idx 0))
 194     (when tag
 195       (while (and (not (ring-empty-p ring)) (< idx (ring-size ring)))
 196         (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag)
 197                                     tag)
 198             (ring-remove ring idx))
 199         (setq idx (1+ idx)))
 200       ;; Create a new mark
 201       (let ((sbm (semantic-bookmark (semantic-tag-name tag)
 202                                     :tag tag)))
 203         ;; Take the mark, and update it for the current state.
 204         (ring-insert ring sbm)
 205         (semantic-mrub-update sbm point reason))
 206       )))
 207
 208 (defun semantic-mrub-cache-flush-fcn ()
 209   "Function called in the `semantic-before-toplevel-cache-flush-hook`.
 210 Cause tags in the ring to become unlinked."
 211   (let* ((ring (oref semantic-mru-bookmark-ring ring))
 212          (len (ring-length ring))
 213          (idx 0)
 214          )
 215     (while (< idx len)
 216       (semantic-mrub-preflush (ring-ref ring idx))
 217       (setq idx (1+ idx)))))
 218
 219 (add-hook 'semantic-before-toplevel-cache-flush-hook
 220           'semantic-mrub-cache-flush-fcn)
 221
 222 ;;; EDIT tracker
 223 ;;
 224 (defvar semantic-mrub-last-overlay nil
 225   "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.")
 226
 227 (defun semantic-mru-bookmark-change-hook-fcn (overlay)
 228   "Function set into `semantic-edits-new/move-change-hook's.
 229 Argument OVERLAY is the overlay created to mark the change.
 230 This function pushes tags onto the tag ring."
 231   ;; Dup?
 232   (when (not (eq overlay semantic-mrub-last-overlay))
 233     (setq semantic-mrub-last-overlay overlay)
 234     (semantic-mrub-push semantic-mru-bookmark-ring
 235                         (point)
 236                         'edit)))
 237
 238 ;;; MINOR MODE
 239 ;;
 240 ;; Tracking minor mode.
 241
 242 (defcustom global-semantic-mru-bookmark-mode nil
 243   "If non-nil, enable `semantic-mru-bookmark-mode' globally.
 244 When this mode is enabled, Emacs keeps track of which tags have
 245 been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
 246   :group 'semantic
 247   :group 'semantic-modes
 248   :type 'boolean
 249   :require 'semantic/util-modes
 250   :initialize 'custom-initialize-default
 251   :set (lambda (sym val)
 252          (global-semantic-mru-bookmark-mode (if val 1 -1))))
 253
 254 ;;;###autoload
 255 (define-minor-mode global-semantic-mru-bookmark-mode
 256   "Toggle global use of option `semantic-mru-bookmark-mode'.
 257 If ARG is positive or nil, enable, if it is negative, disable."
 258   :global t :group 'semantic :group 'semantic-modes
 259   ;; Not needed because it's autoloaded instead.
 260   ;; :require 'semantic-util-modes
 261   (semantic-toggle-minor-mode-globally
 262    'semantic-mru-bookmark-mode (if global-semantic-mru-bookmark-mode 1 -1)))
 263
 264 (defcustom semantic-mru-bookmark-mode-hook nil
 265   "*Hook run at the end of function `semantic-mru-bookmark-mode'."
 266   :group 'semantic
 267   :type 'hook)
 268
 269 (defvar semantic-mru-bookmark-mode-map
 270   (let ((km (make-sparse-keymap)))
 271     (define-key km "\C-xB" 'semantic-mrub-switch-tags)
 272     km)
 273   "Keymap for mru-bookmark minor mode.")
 274
 275 (define-minor-mode semantic-mru-bookmark-mode
 276   "Minor mode for tracking tag-based bookmarks automatically.
 277 When this mode is enabled, Emacs keeps track of which tags have
 278 been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
 279
 280 \\{semantic-mru-bookmark-mode-map}
 281
 282 With prefix argument ARG, turn on if positive, otherwise off.  The
 283 minor mode can be turned on only if semantic feature is available and
 284 the current buffer was set up for parsing.  Return non-nil if the
 285 minor mode is enabled."
 286   :keymap semantic-mru-bookmark-mode-map
 287   (if semantic-mru-bookmark-mode
 288       (if (not (and (featurep 'semantic) (semantic-active-p)))
 289           (progn
 290             ;; Disable minor mode if semantic stuff not available
 291             (setq semantic-mru-bookmark-mode nil)
 292             (error "Buffer %s was not set up for parsing"
 293                    (buffer-name)))
 294         (semantic-make-local-hook 'semantic-edits-new-change-hooks)
 295         (add-hook 'semantic-edits-new-change-hooks
 296                   'semantic-mru-bookmark-change-hook-fcn nil t)
 297         (add-hook 'semantic-edits-move-change-hooks
 298                   'semantic-mru-bookmark-change-hook-fcn nil t))
 299     ;; Remove hooks
 300     (remove-hook 'semantic-edits-new-change-hooks
 301                  'semantic-mru-bookmark-change-hook-fcn t)
 302     (remove-hook 'semantic-edits-move-change-hooks
 303                  'semantic-mru-bookmark-change-hook-fcn t)))
 304
 305 (semantic-add-minor-mode 'semantic-mru-bookmark-mode
 306                          "k")
 307
 308 ;;; COMPLETING READ
 309 ;;
 310 ;; Ask the user for a tag in MRU order.
 311 (defun semantic-mrub-read-history nil
 312   "History of `semantic-mrub-completing-read'.")
 313
 314 (defun semantic-mrub-ring-to-assoc-list (ring)
 315   "Convert RING into an association list for completion."
 316   (let ((idx 0)
 317         (len (ring-length ring))
 318         (al nil))
 319     (while (< idx len)
 320       (let ((r (ring-ref ring idx)))
 321         (setq al (cons (cons (oref r :object-name) r)
 322                        al)))
 323       (setq idx (1+ idx)))
 324     (nreverse al)))
 325
 326 (defun semantic-mrub-completing-read (prompt)
 327   "Do a `completing-read' on elements from the mru bookmark ring.
 328 Argument PROMPT is the prompt to use when reading."
 329   (if (ring-empty-p (oref semantic-mru-bookmark-ring ring))
 330       (error "Semantic Bookmark ring is currently empty"))
 331   (let* ((ring (oref semantic-mru-bookmark-ring ring))
 332          (ans nil)
 333          (alist (semantic-mrub-ring-to-assoc-list ring))
 334          (first (cdr (car alist)))
 335          (semantic-mrub-read-history nil)
 336          )
 337     ;; Don't include the current tag.. only those that come after.
 338     (if (semantic-equivalent-tag-p (oref first tag)
 339                                    (semantic-current-tag))
 340         (setq first (cdr (car (cdr alist)))))
 341     ;; Create a fake history list so we don't have to bind
 342     ;; M-p and M-n to our special cause.
 343     (let ((elts (reverse alist)))
 344       (while elts
 345         (setq semantic-mrub-read-history
 346               (cons (car (car elts)) semantic-mrub-read-history))
 347         (setq elts (cdr elts))))
 348     (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history))
 349
 350     ;; Do the read/prompt
 351     (let ((prompt (if first (format "%s (%s): " prompt
 352                                     (semantic-format-tag-name
 353                                      (oref first tag) t)
 354                                     )
 355                     (concat prompt ": ")))
 356           )
 357       (setq ans
 358             (completing-read prompt alist nil nil nil 'semantic-mrub-read-history)))
 359     ;; Calculate the return tag.
 360     (if (string= ans "")
 361         (setq ans first)
 362       ;; Return the bookmark object.
 363       (setq ans (assoc ans alist))
 364       (if ans
 365           (cdr ans)
 366         ;; no match.  Custom word.  Look it up somwhere?
 367         nil)
 368       )))
 369
 370 (defun semantic-mrub-switch-tags (tagmark)
 371   "Switch tags to TAGMARK.
 372 Selects a new tag via prompt through the mru tag ring.
 373 Jumps to the tag and highlights it briefly."
 374   (interactive (list (semantic-mrub-completing-read "Switch to tag")))
 375   (if (not (semantic-bookmark-p tagmark))
 376       (signal 'wrong-type-argument tagmark))
 377
 378   (semantic-mrub-push semantic-mru-bookmark-ring
 379                       (point)
 380                       'jump)
 381   (semantic-mrub-visit tagmark)
 382   )
 383
 384 ;;; Debugging
 385 ;;
 386 (defun semantic-adebug-mrub ()
 387   "Display a list of items in the MRU bookmarks list.
 388 Useful for debugging mrub problems."
 389   (interactive)
 390   (require 'eieio-datadebug)
 391   (let* ((out semantic-mru-bookmark-ring))
 392     (data-debug-new-buffer "*TAG RING ADEBUG*")
 393     (data-debug-insert-object-slots out "]")
 394     ))
 395
 396
 397 (provide 'semantic/mru-bookmark)
 398
 399 ;; Local variables:
 400 ;; generated-autoload-file: "loaddefs.el"
 401 ;; generated-autoload-load-name: "semantic/mru-bookmark"
 402 ;; End:
 403
 404 ;; arch-tag: 297fa190-2942-460b-941d-f117db4e1fbf
 405 ;;; semantic/mru-bookmark.el ends here