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

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