;;; semantic-mru-bookmark.el --- Automatic bookmark tracking

;; Copyright (C) 2007 Eric M. Ludlam

;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; X-RCS: $Id: semantic-mru-bookmark.el,v 1.1 2007-11-26 15:10:41 michaels Exp $

;; This program 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 2, or (at
;; your option) any later version.

;; This program 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 this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; 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:

;;; 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
      (progn
	(oset sbm filename (semantic-tag-file-name (oref sbm tag)))
	(save-excursion
	  (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."
  (with-slots (tag filename) sbm
    ;; Go to the tag
    (when (not (semantic-tag-buffer 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))
    ;; 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'."
  (with-slots (tag offset frequency) sbm
    (setq offset (- point (semantic-tag-start tag)))
    (setq frequency (1+ frequency))
    )
  (oset sbm reason reason)
  )

(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 (oref sbm parent)))
    (let ((b (semantic-tag-buffer tag)))
      (when (and b (eq b (current-buffer)))
	(semantic--tag-unlink-from-buffer tag)))

    (when parent
      (let ((b (semantic-tag-buffer 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.")

(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-current-tag))
	 (elts (ring-elements ring))
	 (sbm (object-assoc tag 'tag elts)))
    (if sbm
	;; Delete the old mark from the ringn
	(let ((idx (- (length elts) (length (memq sbm elts)))))
	  (ring-remove ring idx))
      ;; Create a new mark
      (setq 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 ((elts (ring-elements (oref semantic-mru-bookmark-ring ring)))
	(buf (current-buffer)))
    (dolist (e elts)
      (semantic-mrub-preflush e))))

(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 will set the face property on this overlay."
  ;; 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.

;;;###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)))

;;;###autoload
(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))))

(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)

;;;###autoload
(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-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* ((elts (ring-elements (oref semantic-mru-bookmark-ring ring)))
	 (first (car elts))
	 (ans nil)
	 (alist (object-assoc-list :object-name elts))
	 (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 (car (cdr elts))))
    ;; Create a fake history list so we don't have to bind
    ;; M-p and M-n to our special cause.
    (while elts
      (setq semantic-mrub-read-history (cons (oref (car elts) :object-name)
					     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 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)
  (let* ((out semantic-mru-bookmark-ring)
	 (ab (semantic-adebug-new-buffer "*TAG RING ADEBUG*"))
	 )

    (semantic-adebug-insert-object-fields out "]")
    ))


(provide 'semantic-mru-bookmark)

;;; semantic-mru-bookmark.el ends here