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 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 ;;;###autoload
 243 (define-minor-mode global-semantic-mru-bookmark-mode
 244   "Toggle global use of option `semantic-mru-bookmark-mode'.
 245 If ARG is positive or nil, enable, if it is negative, disable."
 246   :global t :group 'semantic :group 'semantic-modes
 247   ;; Not needed because it's autoloaded instead.
 248   ;; :require 'semantic-util-modes
 249   (semantic-toggle-minor-mode-globally
 250    'semantic-mru-bookmark-mode (if global-semantic-mru-bookmark-mode 1 -1)))
 251
 252 (defcustom semantic-mru-bookmark-mode-hook nil
 253   "*Hook run at the end of function `semantic-mru-bookmark-mode'."
 254   :group 'semantic
 255   :type 'hook)
 256
 257 (defvar semantic-mru-bookmark-mode-map
 258   (let ((km (make-sparse-keymap)))
 259     (define-key km "\C-xB" 'semantic-mrub-switch-tags)
 260     km)
 261   "Keymap for mru-bookmark minor mode.")
 262
 263 (define-minor-mode semantic-mru-bookmark-mode
 264   "Minor mode for tracking tag-based bookmarks automatically.
 265 When this mode is enabled, Emacs keeps track of which tags have
 266 been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
 267
 268 \\{semantic-mru-bookmark-mode-map}
 269
 270 With prefix argument ARG, turn on if positive, otherwise off.  The
 271 minor mode can be turned on only if semantic feature is available and
 272 the current buffer was set up for parsing.  Return non-nil if the
 273 minor mode is enabled."
 274   :keymap semantic-mru-bookmark-mode-map
 275   (if semantic-mru-bookmark-mode
 276       (if (not (and (featurep 'semantic) (semantic-active-p)))
 277           (progn
 278             ;; Disable minor mode if semantic stuff not available
 279             (setq semantic-mru-bookmark-mode nil)
 280             (error "Buffer %s was not set up for parsing"
 281                    (buffer-name)))
 282         (semantic-make-local-hook 'semantic-edits-new-change-hooks)
 283         (add-hook 'semantic-edits-new-change-hooks
 284                   'semantic-mru-bookmark-change-hook-fcn nil t)
 285         (add-hook 'semantic-edits-move-change-hooks
 286                   'semantic-mru-bookmark-change-hook-fcn nil t))
 287     ;; Remove hooks
 288     (remove-hook 'semantic-edits-new-change-hooks
 289                  'semantic-mru-bookmark-change-hook-fcn t)
 290     (remove-hook 'semantic-edits-move-change-hooks
 291                  'semantic-mru-bookmark-change-hook-fcn t)))
 292
 293 (semantic-add-minor-mode 'semantic-mru-bookmark-mode
 294                          "k")
 295
 296 ;;; COMPLETING READ
 297 ;;
 298 ;; Ask the user for a tag in MRU order.
 299 (defun semantic-mrub-read-history nil
 300   "History of `semantic-mrub-completing-read'.")
 301
 302 (defun semantic-mrub-ring-to-assoc-list (ring)
 303   "Convert RING into an association list for completion."
 304   (let ((idx 0)
 305         (len (ring-length ring))
 306         (al nil))
 307     (while (< idx len)
 308       (let ((r (ring-ref ring idx)))
 309         (setq al (cons (cons (oref r :object-name) r)
 310                        al)))
 311       (setq idx (1+ idx)))
 312     (nreverse al)))
 313
 314 (defun semantic-mrub-completing-read (prompt)
 315   "Do a `completing-read' on elements from the mru bookmark ring.
 316 Argument PROMPT is the prompt to use when reading."
 317   (if (ring-empty-p (oref semantic-mru-bookmark-ring ring))
 318       (error "Semantic Bookmark ring is currently empty"))
 319   (let* ((ring (oref semantic-mru-bookmark-ring ring))
 320          (ans nil)
 321          (alist (semantic-mrub-ring-to-assoc-list ring))
 322          (first (cdr (car alist)))
 323          (semantic-mrub-read-history nil)
 324          )
 325     ;; Don't include the current tag.. only those that come after.
 326     (if (semantic-equivalent-tag-p (oref first tag)
 327                                    (semantic-current-tag))
 328         (setq first (cdr (car (cdr alist)))))
 329     ;; Create a fake history list so we don't have to bind
 330     ;; M-p and M-n to our special cause.
 331     (let ((elts (reverse alist)))
 332       (while elts
 333         (setq semantic-mrub-read-history
 334               (cons (car (car elts)) semantic-mrub-read-history))
 335         (setq elts (cdr elts))))
 336     (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history))
 337
 338     ;; Do the read/prompt
 339     (let ((prompt (if first (format "%s (%s): " prompt
 340                                     (semantic-format-tag-name
 341                                      (oref first tag) t)
 342                                     )
 343                     (concat prompt ": ")))
 344           )
 345       (setq ans
 346             (completing-read prompt alist nil nil nil 'semantic-mrub-read-history)))
 347     ;; Calculate the return tag.
 348     (if (string= ans "")
 349         (setq ans first)
 350       ;; Return the bookmark object.
 351       (setq ans (assoc ans alist))
 352       (if ans
 353           (cdr ans)
 354         ;; no match.  Custom word.  Look it up somwhere?
 355         nil)
 356       )))
 357
 358 (defun semantic-mrub-switch-tags (tagmark)
 359   "Switch tags to TAGMARK.
 360 Selects a new tag via prompt through the mru tag ring.
 361 Jumps to the tag and highlights it briefly."
 362   (interactive (list (semantic-mrub-completing-read "Switch to tag")))
 363   (if (not (semantic-bookmark-p tagmark))
 364       (signal 'wrong-type-argument tagmark))
 365
 366   (semantic-mrub-push semantic-mru-bookmark-ring
 367                       (point)
 368                       'jump)
 369   (semantic-mrub-visit tagmark)
 370   )
 371
 372 ;;; Debugging
 373 ;;
 374 (defun semantic-adebug-mrub ()
 375   "Display a list of items in the MRU bookmarks list.
 376 Useful for debugging mrub problems."
 377   (interactive)
 378   (require 'eieio-datadebug)
 379   (let* ((out semantic-mru-bookmark-ring))
 380     (data-debug-new-buffer "*TAG RING ADEBUG*")
 381     (data-debug-insert-object-slots out "]")
 382     ))
 383
 384
 385 (provide 'semantic/mru-bookmark)
 386
 387 ;; Local variables:
 388 ;; generated-autoload-file: "loaddefs.el"
 389 ;; generated-autoload-load-name: "semantic/mru-bookmark"
 390 ;; End:
 391
 392 ;; arch-tag: 297fa190-2942-460b-941d-f117db4e1fbf
 393 ;;; semantic/mru-bookmark.el ends here