--- /dev/null
+;;; semantic/mru-bookmark.el --- Automatic bookmark tracking
+
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Using editing hooks, track the most recently visited or poked tags,
+;; and keep a list of them, with the current point in from, and sorted
+;; by most recently used.
+;;
+;; I envision this would be used in place of switch-buffers once
+;; someone got the hang of it.
+;;
+;; I'd also like to see this used to provide some nice defaults for
+;; other programs where logical destinations or targets are the tags
+;; that have been recently edited.
+;;
+;; Quick Start:
+;;
+;; M-x global-semantic-mru-bookmark-mode RET
+;;
+;; < edit some code >
+;;
+;; C-x B <select a tag name> RET
+;;
+;; In the above, the history is pre-filled with the tags you recenetly
+;; edited in the order you edited them.
+
+;;; Code:
+
+(require 'semantic)
+(require 'eieio-base)
+(require 'ring)
+
+(declare-function data-debug-new-buffer "data-debug")
+(declare-function data-debug-insert-object-slots "eieio-datadebug")
+(declare-function semantic-momentary-highlight-tag "semantic/decorate")
+
+;;; TRACKING CORE
+;;
+;; Data structure for tracking MRU tag locations
+
+(defclass semantic-bookmark (eieio-named)
+ ((tag :initarg :tag
+ :type semantic-tag
+ :documentation "The TAG this bookmark belongs to.")
+ (parent :type (or semantic-tag null)
+ :documentation "The tag that is the parent of :tag.")
+ (offset :type number
+ :documentation "The offset from `tag' start that is
+somehow interesting.")
+ (filename :type string
+ :documentation "String the tag belongs to.
+Set this when the tag gets unlinked from the buffer it belongs to.")
+ (frequency :type number
+ :initform 0
+ :documentation "Track the frequency this tag is visited.")
+ (reason :type symbol
+ :initform t
+ :documentation
+ "The reason this tag is interesting.
+Nice values are 'edit, 'read, 'jump, and 'mark.
+ edit - created because the tag text was edited.
+ read - created because point lingered in tag text.
+ jump - jumped to another tag from this tag.
+ mark - created a regular mark in this tag.")
+ )
+ "A single bookmark.")
+
+(defmethod initialize-instance :AFTER ((sbm semantic-bookmark) &rest fields)
+ "Initialize the bookmark SBM with details about :tag."
+ (condition-case nil
+ (save-excursion
+ (oset sbm filename (semantic-tag-file-name (oref sbm tag)))
+ (semantic-go-to-tag (oref sbm tag))
+ (oset sbm parent (semantic-current-tag-parent)))
+ (error (message "Error bookmarking tag.")))
+ )
+
+(defmethod semantic-mrub-visit ((sbm semantic-bookmark))
+ "Visit the semantic tag bookmark SBM.
+Uses `semantic-go-to-tag' and highlighting."
+ (require 'semantic/decorate)
+ (with-slots (tag filename) sbm
+ ;; Go to the tag
+ (when (not (semantic-tag-in-buffer-p tag))
+ (let ((fn (or (semantic-tag-file-name tag)
+ filename)))
+ (set-buffer (find-file-noselect fn))))
+ (semantic-go-to-tag (oref sbm tag) (oref sbm parent))
+ ;; Go back to the offset.
+ (condition-case nil
+ (let ((o (oref sbm offset)))
+ (forward-char o))
+ (error nil))
+ ;; make it visible
+ (switch-to-buffer (current-buffer))
+ (semantic-momentary-highlight-tag tag)
+ ))
+
+(defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason)
+ "Update the existing bookmark SBM.
+POINT is some important location.
+REASON is a symbol. See slot `reason' on `semantic-bookmark'."
+ (condition-case nil
+ (progn
+ (with-slots (tag offset frequency) sbm
+ (setq offset (- point (semantic-tag-start tag)))
+ (setq frequency (1+ frequency))
+ )
+ (oset sbm reason reason))
+ ;; This can fail on XEmacs at miscelaneous times.
+ (error nil))
+ )
+
+(defmethod semantic-mrub-preflush ((sbm semantic-bookmark))
+ "Method called on a tag before the current buffer list of tags is flushed.
+If there is a buffer match, unlink the tag."
+ (let ((tag (oref sbm tag))
+ (parent (when (slot-boundp sbm 'parent)
+ (oref sbm parent))))
+ (let ((b (semantic-tag-in-buffer-p tag)))
+ (when (and b (eq b (current-buffer)))
+ (semantic--tag-unlink-from-buffer tag)))
+
+ (when parent
+ (let ((b (semantic-tag-in-buffer-p parent)))
+ (when (and b (eq b (current-buffer)))
+ (semantic--tag-unlink-from-buffer parent))))))
+
+(defclass semantic-bookmark-ring ()
+ ((ring :initarg :ring
+ :type ring
+ :documentation
+ "List of `semantic-bookmark' objects.
+This list is maintained as a list with the first item
+being the current location, and the rest being a list of
+items that were recently visited.")
+ (current-index :initform 0
+ :type number
+ :documentation
+ "The current index into RING for some operation.
+User commands use this to move through the ring, or reset.")
+ )
+ "Track the current MRU stack of bookmarks.
+We can't use the built-in ring data structure because we need
+to delete some items from the ring when we don't have the data.")
+
+(defvar semantic-mru-bookmark-ring (semantic-bookmark-ring
+ "Ring"
+ :ring (make-ring 20))
+ "The MRU bookmark ring.
+This ring tracks the most recent active tags of interest.")
+
+(defun semantic-mrub-find-nearby-tag (point)
+ "Find a nearby tag to be pushed for this current location.
+Argument POINT is where to find the tag near."
+ ;; I thought this was a good idea, but it is not!
+ ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date.
+ (let ((tag (semantic-current-tag)))
+ (when (or (not tag) (semantic-tag-of-class-p tag 'type))
+ (let ((nearby (or (semantic-find-tag-by-overlay-next point)
+ (semantic-find-tag-by-overlay-prev point))))
+ (when nearby (setq tag nearby))))
+ tag))
+
+(defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point
+ &optional reason)
+ "Add a bookmark to the ring SBR from POINT.
+REASON is why it is being pushed. See doc for `semantic-bookmark'
+for possible reasons.
+The resulting bookmark is then sorted within the ring."
+ (let* ((ring (oref sbr ring))
+ (tag (semantic-mrub-find-nearby-tag (point)))
+ (idx 0))
+ (when tag
+ (while (and (not (ring-empty-p ring)) (< idx (ring-size ring)))
+ (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag)
+ tag)
+ (ring-remove ring idx))
+ (setq idx (1+ idx)))
+ ;; Create a new mark
+ (let ((sbm (semantic-bookmark (semantic-tag-name tag)
+ :tag tag)))
+ ;; Take the mark, and update it for the current state.
+ (ring-insert ring sbm)
+ (semantic-mrub-update sbm point reason))
+ )))
+
+(defun semantic-mrub-cache-flush-fcn ()
+ "Function called in the `semantic-before-toplevel-cache-flush-hook`.
+Cause tags in the ring to become unlinked."
+ (let* ((ring (oref semantic-mru-bookmark-ring ring))
+ (len (ring-length ring))
+ (idx 0)
+ )
+ (while (< idx len)
+ (semantic-mrub-preflush (ring-ref ring idx))
+ (setq idx (1+ idx)))))
+
+(add-hook 'semantic-before-toplevel-cache-flush-hook
+ 'semantic-mrub-cache-flush-fcn)
+
+;;; EDIT tracker
+;;
+(defvar semantic-mrub-last-overlay nil
+ "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.")
+
+(defun semantic-mru-bookmark-change-hook-fcn (overlay)
+ "Function set into `semantic-edits-new/move-change-hook's.
+Argument OVERLAY is the overlay created to mark the change.
+This function pushes tags onto the tag ring."
+ ;; Dup?
+ (when (not (eq overlay semantic-mrub-last-overlay))
+ (setq semantic-mrub-last-overlay overlay)
+ (semantic-mrub-push semantic-mru-bookmark-ring
+ (point)
+ 'edit)))
+
+;;; MINOR MODE
+;;
+;; Tracking minor mode.
+
+(defcustom global-semantic-mru-bookmark-mode nil
+ "*If non-nil enable global use of variable `semantic-mru-bookmark-mode'.
+When this mode is enabled, changes made to a buffer are highlighted
+until the buffer is reparsed."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic-util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-mru-bookmark-mode (if val 1 -1))))
+
+;;;###autoload
+(defun global-semantic-mru-bookmark-mode (&optional arg)
+ "Toggle global use of option `semantic-mru-bookmark-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-mru-bookmark-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-mru-bookmark-mode arg)))
+
+(defcustom semantic-mru-bookmark-mode-hook nil
+ "*Hook run at the end of function `semantic-mru-bookmark-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-mru-bookmark-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-xB" 'semantic-mrub-switch-tags)
+ km)
+ "Keymap for mru-bookmark minor mode.")
+
+(defvar semantic-mru-bookmark-mode nil
+ "Non-nil if mru-bookmark minor mode is enabled.
+Use the command `semantic-mru-bookmark-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-mru-bookmark-mode)
+
+(defun semantic-mru-bookmark-mode-setup ()
+ "Setup option `semantic-mru-bookmark-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-mru-bookmark-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-mru-bookmark-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn nil t)
+ (add-hook 'semantic-edits-move-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn nil t)
+ )
+ ;; Remove hooks
+ (remove-hook 'semantic-edits-new-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn t)
+ (remove-hook 'semantic-edits-move-change-hooks
+ 'semantic-mru-bookmark-change-hook-fcn t)
+ )
+ semantic-mru-bookmark-mode)
+
+(defun semantic-mru-bookmark-mode (&optional arg)
+ "Minor mode for tracking tag-based bookmarks automatically.
+Tag based bookmarks a tracked based on editing and viewing habits
+and can then be navigated via the MRU bookmark keymap.
+
+\\{semantic-mru-bookmark-mode-map}
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-mru-bookmark-mode 0 1))))
+ (setq semantic-mru-bookmark-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-mru-bookmark-mode)))
+ (semantic-mru-bookmark-mode-setup)
+ (run-hooks 'semantic-mru-bookmark-mode-hook)
+ (if (interactive-p)
+ (message "mru-bookmark minor mode %sabled"
+ (if semantic-mru-bookmark-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-mru-bookmark-mode)
+
+(semantic-add-minor-mode 'semantic-mru-bookmark-mode
+ "k"
+ semantic-mru-bookmark-mode-map)
+
+;;; COMPLETING READ
+;;
+;; Ask the user for a tag in MRU order.
+(defun semantic-mrub-read-history nil
+ "History of `semantic-mrub-completing-read'.")
+
+(defun semantic-mrub-ring-to-assoc-list (ring)
+ "Convert RING into an association list for completion."
+ (let ((idx 0)
+ (len (ring-length ring))
+ (al nil))
+ (while (< idx len)
+ (let ((r (ring-ref ring idx)))
+ (setq al (cons (cons (oref r :object-name) r)
+ al)))
+ (setq idx (1+ idx)))
+ (nreverse al)))
+
+(defun semantic-mrub-completing-read (prompt)
+ "Do a `completing-read' on elements from the mru bookmark ring.
+Argument PROMPT is the promot to use when reading."
+ (if (ring-empty-p (oref semantic-mru-bookmark-ring ring))
+ (error "Semantic Bookmark ring is currently empty"))
+ (let* ((ring (oref semantic-mru-bookmark-ring ring))
+ (ans nil)
+ (alist (semantic-mrub-ring-to-assoc-list ring))
+ (first (cdr (car alist)))
+ (semantic-mrub-read-history nil)
+ )
+ ;; Don't include the current tag.. only those that come after.
+ (if (semantic-equivalent-tag-p (oref first tag)
+ (semantic-current-tag))
+ (setq first (cdr (car (cdr alist)))))
+ ;; Create a fake history list so we don't have to bind
+ ;; M-p and M-n to our special cause.
+ (let ((elts (reverse alist)))
+ (while elts
+ (setq semantic-mrub-read-history
+ (cons (car (car elts)) semantic-mrub-read-history))
+ (setq elts (cdr elts))))
+ (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history))
+
+ ;; Do the read/prompt
+ (let ((prompt (if first (format "%s (%s): " prompt
+ (semantic-format-tag-name
+ (oref first tag) t)
+ )
+ (concat prompt ": ")))
+ )
+ (setq ans
+ (completing-read prompt alist nil nil nil 'semantic-mrub-read-history)))
+ ;; Calculate the return tag.
+ (if (string= ans "")
+ (setq ans first)
+ ;; Return the bookmark object.
+ (setq ans (assoc ans alist))
+ (if ans
+ (cdr ans)
+ ;; no match. Custom word. Look it up somwhere?
+ nil)
+ )))
+
+(defun semantic-mrub-switch-tags (tagmark)
+ "Switch tags to TAGMARK.
+Selects a new tag via promt through the mru tag ring.
+Jumps to the tag and highlights it briefly."
+ (interactive (list (semantic-mrub-completing-read "Switch to tag")))
+ (if (not (semantic-bookmark-p tagmark))
+ (signal 'wrong-type-argument tagmark))
+
+ (semantic-mrub-push semantic-mru-bookmark-ring
+ (point)
+ 'jump)
+ (semantic-mrub-visit tagmark)
+ )
+
+;;; ADVICE
+;;
+;; Advise some commands to help set tag marks.
+;; (defadvice push-mark (around semantic-mru-bookmark activate)
+;; "Push a mark at LOCATION with NOMSG and ACTIVATE passed to `push-mark'.
+;; If `semantic-mru-bookmark-mode' is active, also push a tag onto
+;; the mru bookmark stack."
+;; (semantic-mrub-push semantic-mru-bookmark-ring
+;; (point)
+;; 'mark)
+;; ad-do-it)
+
+;(defadvice set-mark-command (around semantic-mru-bookmark activate)
+; "Set this buffer's mark to POS.
+;If `semantic-mru-bookmark-mode' is active, also push a tag onto
+;the mru bookmark stack."
+; (when (and semantic-mru-bookmark-mode (interactive-p))
+; (semantic-mrub-push semantic-mru-bookmark-ring
+; (point)
+; 'mark))
+; ad-do-it)
+
+
+;;; Debugging
+;;
+(defun semantic-adebug-mrub ()
+ "Display a list of items in the MRU bookmarks list.
+Useful for debugging mrub problems."
+ (interactive)
+ (require 'eieio-datadebug)
+ (let* ((out semantic-mru-bookmark-ring))
+ (data-debug-new-buffer "*TAG RING ADEBUG*")
+ (data-debug-insert-object-slots out "]")
+ ))
+
+
+(provide 'semantic/mru-bookmark)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/mru-bookmark"
+;; End:
+
+;;; semantic/mru-bookmark.el ends here