Mercurial > emacs

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/cedet/semantic/mru-bookmark.el	Mon Sep 21 02:26:07 2009 +0000
@@ -0,0 +1,458 @@
+;;; 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