1 ;;; semantic/mru-bookmark.el --- Automatic bookmark tracking
3 ;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
7 ;; This file is part of GNU Emacs.
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.
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.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
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.
28 ;; I envision this would be used in place of switch-buffers once
29 ;; someone got the hang of it.
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.
37 ;; M-x global-semantic-mru-bookmark-mode RET
41 ;; C-x B <select a tag name> RET
43 ;; In the above, the history is pre-filled with the tags you recently
44 ;; edited in the order you edited them.
48 (eval-when-compile (require 'cl
))
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 (declare-function semantic-tag-similar-p
"semantic/tag-ls")
60 ;; Data structure for tracking MRU tag locations
62 (defclass semantic-bookmark
(eieio-named)
65 :documentation
"The TAG this bookmark belongs to.")
66 (parent :type
(or semantic-tag null
)
67 :documentation
"The tag that is the parent of :tag.")
69 :documentation
"The offset from `tag' start that is
70 somehow interesting.")
71 (filename :type string
72 :documentation
"String the tag belongs to.
73 Set this when the tag gets unlinked from the buffer it belongs to.")
74 (frequency :type number
76 :documentation
"Track the frequency this tag is visited.")
80 "The reason this tag is interesting.
81 Nice values are 'edit, 'read, 'jump, and 'mark.
82 edit - created because the tag text was edited.
83 read - created because point lingered in tag text.
84 jump - jumped to another tag from this tag.
85 mark - created a regular mark in this tag.")
89 (cl-defmethod initialize-instance :after
((sbm semantic-bookmark
) &rest fields
)
90 "Initialize the bookmark SBM with details about :tag."
93 (oset sbm filename
(semantic-tag-file-name (oref sbm tag
)))
94 (semantic-go-to-tag (oref sbm tag
))
95 (oset sbm parent
(semantic-current-tag-parent)))
96 (error (message "Error bookmarking tag.")))
99 (cl-defmethod semantic-mrub-visit ((sbm semantic-bookmark
))
100 "Visit the semantic tag bookmark SBM.
101 Uses `semantic-go-to-tag' and highlighting."
102 (require 'semantic
/decorate
)
103 (with-slots (tag filename
) sbm
105 (when (not (semantic-tag-in-buffer-p tag
))
106 (let ((fn (or (semantic-tag-file-name tag
)
108 (set-buffer (find-file-noselect fn
))))
109 (semantic-go-to-tag (oref sbm tag
) (oref sbm parent
))
110 ;; Go back to the offset.
112 (let ((o (oref sbm offset
)))
116 (switch-to-buffer (current-buffer))
117 (semantic-momentary-highlight-tag tag
)
120 (cl-defmethod semantic-mrub-update ((sbm semantic-bookmark
) point reason
)
121 "Update the existing bookmark SBM.
122 POINT is some important location.
123 REASON is a symbol. See slot `reason' on `semantic-bookmark'."
126 (with-slots (tag offset frequency
) sbm
127 (setq offset
(- point
(semantic-tag-start tag
)))
128 (setq frequency
(1+ frequency
))
130 (oset sbm reason reason
))
131 ;; This can fail on XEmacs at miscellaneous times.
135 (cl-defmethod semantic-mrub-preflush ((sbm semantic-bookmark
))
136 "Method called on a tag before the current buffer list of tags is flushed.
137 If there is a buffer match, unlink the tag."
138 (let ((tag (oref sbm tag
))
139 (parent (when (slot-boundp sbm
'parent
)
141 (let ((b (semantic-tag-in-buffer-p tag
)))
142 (when (and b
(eq b
(current-buffer)))
143 (semantic--tag-unlink-from-buffer tag
)))
146 (let ((b (semantic-tag-in-buffer-p parent
)))
147 (when (and b
(eq b
(current-buffer)))
148 (semantic--tag-unlink-from-buffer parent
))))))
150 (defclass semantic-bookmark-ring
()
151 ((ring :initarg
:ring
154 "List of `semantic-bookmark' objects.
155 This list is maintained as a list with the first item
156 being the current location, and the rest being a list of
157 items that were recently visited.")
158 (current-index :initform
0
161 "The current index into RING for some operation.
162 User commands use this to move through the ring, or reset.")
164 "Track the current MRU stack of bookmarks.
165 We can't use the built-in ring data structure because we need
166 to delete some items from the ring when we don't have the data.")
168 (defvar semantic-mru-bookmark-ring
(semantic-bookmark-ring
170 :ring
(make-ring 20))
171 "The MRU bookmark ring.
172 This ring tracks the most recent active tags of interest.")
174 (defun semantic-mrub-find-nearby-tag (point)
175 "Find a nearby tag to be pushed for this current location.
176 Argument POINT is where to find the tag near."
177 ;; I thought this was a good idea, but it is not!
178 ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date.
179 (let ((tag (semantic-current-tag)))
180 (when (or (not tag
) (semantic-tag-of-class-p tag
'type
))
181 (let ((nearby (or (semantic-find-tag-by-overlay-next point
)
182 (semantic-find-tag-by-overlay-prev point
))))
183 (when nearby
(setq tag nearby
))))
186 (cl-defmethod semantic-mrub-push ((sbr semantic-bookmark-ring
) point
188 "Add a bookmark to the ring SBR from POINT.
189 REASON is why it is being pushed. See doc for `semantic-bookmark'
190 for possible reasons.
191 The resulting bookmark is then sorted within the ring."
192 (let* ((ring (oref sbr ring
))
193 (tag (semantic-mrub-find-nearby-tag (point)))
196 (while (and (not (ring-empty-p ring
)) (< idx
(ring-size ring
)))
197 (if (semantic-tag-similar-p (oref (ring-ref ring idx
) tag
)
199 (ring-remove ring idx
))
202 (let ((sbm (semantic-bookmark (semantic-tag-name tag
)
204 ;; Take the mark, and update it for the current state.
205 (ring-insert ring sbm
)
206 (semantic-mrub-update sbm point reason
))
209 (defun semantic-mrub-cache-flush-fcn ()
210 "Function called in the `semantic-before-toplevel-cache-flush-hook'.
211 Cause tags in the ring to become unlinked."
212 (let* ((ring (oref semantic-mru-bookmark-ring ring
))
213 (len (ring-length ring
))
217 (semantic-mrub-preflush (ring-ref ring idx
))
218 (setq idx
(1+ idx
)))))
220 (add-hook 'semantic-before-toplevel-cache-flush-hook
221 'semantic-mrub-cache-flush-fcn
)
225 (defvar semantic-mrub-last-overlay nil
226 "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.")
228 (defun semantic-mru-bookmark-change-hook-fcn (overlay)
229 "Function set into `semantic-edits-new/move-change-hook's.
230 Argument OVERLAY is the overlay created to mark the change.
231 This function pushes tags onto the tag ring."
233 (when (not (eq overlay semantic-mrub-last-overlay
))
234 (setq semantic-mrub-last-overlay overlay
)
235 (semantic-mrub-push semantic-mru-bookmark-ring
241 ;; Tracking minor mode.
243 (defcustom global-semantic-mru-bookmark-mode nil
244 "If non-nil, enable `semantic-mru-bookmark-mode' globally.
245 When this mode is enabled, Emacs keeps track of which tags have
246 been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
248 :group
'semantic-modes
250 :require
'semantic
/util-modes
251 :initialize
'custom-initialize-default
252 :set
(lambda (sym val
)
253 (global-semantic-mru-bookmark-mode (if val
1 -
1))))
256 (define-minor-mode global-semantic-mru-bookmark-mode
257 "Toggle global use of option `semantic-mru-bookmark-mode'.
258 If ARG is positive or nil, enable, if it is negative, disable."
259 :global t
:group
'semantic
:group
'semantic-modes
260 ;; Not needed because it's autoloaded instead.
261 ;; :require 'semantic-util-modes
262 (semantic-toggle-minor-mode-globally
263 'semantic-mru-bookmark-mode
(if global-semantic-mru-bookmark-mode
1 -
1)))
265 (defcustom semantic-mru-bookmark-mode-hook nil
266 "Hook run at the end of function `semantic-mru-bookmark-mode'."
270 (defvar semantic-mru-bookmark-mode-map
271 (let ((km (make-sparse-keymap)))
272 (define-key km
"\C-xB" 'semantic-mrub-switch-tags
)
274 "Keymap for mru-bookmark minor mode.")
276 (define-minor-mode semantic-mru-bookmark-mode
277 "Minor mode for tracking tag-based bookmarks automatically.
278 When this mode is enabled, Emacs keeps track of which tags have
279 been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
281 \\{semantic-mru-bookmark-mode-map}
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 :keymap semantic-mru-bookmark-mode-map
288 (if semantic-mru-bookmark-mode
289 (if (not (and (featurep 'semantic
) (semantic-active-p)))
291 ;; Disable minor mode if semantic stuff not available
292 (setq semantic-mru-bookmark-mode nil
)
293 (error "Buffer %s was not set up for parsing"
295 (semantic-make-local-hook 'semantic-edits-new-change-functions
)
296 (add-hook 'semantic-edits-new-change-functions
297 'semantic-mru-bookmark-change-hook-fcn nil t
)
298 (add-hook 'semantic-edits-move-change-hooks
299 'semantic-mru-bookmark-change-hook-fcn nil t
))
301 (remove-hook 'semantic-edits-new-change-functions
302 'semantic-mru-bookmark-change-hook-fcn t
)
303 (remove-hook 'semantic-edits-move-change-hooks
304 'semantic-mru-bookmark-change-hook-fcn t
)))
306 (semantic-add-minor-mode 'semantic-mru-bookmark-mode
311 ;; Ask the user for a tag in MRU order.
312 (defun semantic-mrub-read-history nil
313 "History of `semantic-mrub-completing-read'.")
315 (defun semantic-mrub-ring-to-assoc-list (ring)
316 "Convert RING into an association list for completion."
318 (len (ring-length ring
))
321 (let ((r (ring-ref ring idx
)))
322 (setq al
(cons (cons (oref r
:object-name
) r
)
327 (defun semantic-mrub-completing-read (prompt)
328 "Do a `completing-read' on elements from the mru bookmark ring.
329 Argument PROMPT is the prompt to use when reading."
330 (if (ring-empty-p (oref semantic-mru-bookmark-ring ring
))
331 (error "Semantic Bookmark ring is currently empty"))
332 (let* ((ring (oref semantic-mru-bookmark-ring ring
))
334 (alist (semantic-mrub-ring-to-assoc-list ring
))
335 (first (cdr (car alist
)))
336 (semantic-mrub-read-history nil
)
338 ;; Don't include the current tag.. only those that come after.
339 (if (semantic-equivalent-tag-p (oref first tag
)
340 (semantic-current-tag))
341 (setq first
(cdr (car (cdr alist
)))))
342 ;; Create a fake history list so we don't have to bind
343 ;; M-p and M-n to our special cause.
344 (let ((elts (reverse alist
)))
346 (setq semantic-mrub-read-history
347 (cons (car (car elts
)) semantic-mrub-read-history
))
348 (setq elts
(cdr elts
))))
349 (setq semantic-mrub-read-history
(nreverse semantic-mrub-read-history
))
351 ;; Do the read/prompt
352 (let ((prompt (if first
(format "%s (%s): " prompt
353 (semantic-format-tag-name
356 (concat prompt
": ")))
359 (completing-read prompt alist nil nil nil
'semantic-mrub-read-history
)))
360 ;; Calculate the return tag.
363 ;; Return the bookmark object.
364 (setq ans
(assoc ans alist
))
367 ;; no match. Custom word. Look it up somewhere?
371 (defun semantic-mrub-switch-tags (tagmark)
372 "Switch tags to TAGMARK.
373 Selects a new tag via prompt through the mru tag ring.
374 Jumps to the tag and highlights it briefly."
375 (interactive (list (semantic-mrub-completing-read "Switch to tag")))
376 (if (not (semantic-bookmark-p tagmark
))
377 (signal 'wrong-type-argument tagmark
))
379 (semantic-mrub-push semantic-mru-bookmark-ring
382 (semantic-mrub-visit tagmark
)
387 (defun semantic-adebug-mrub ()
388 "Display a list of items in the MRU bookmarks list.
389 Useful for debugging mrub problems."
391 (require 'eieio-datadebug
)
392 (let* ((out semantic-mru-bookmark-ring
))
393 (data-debug-new-buffer "*TAG RING ADEBUG*")
394 (data-debug-insert-object-slots out
"]")
398 (provide 'semantic
/mru-bookmark
)
401 ;; generated-autoload-file: "loaddefs.el"
402 ;; generated-autoload-load-name: "semantic/mru-bookmark"
405 ;;; semantic/mru-bookmark.el ends here