Mercurial > emacs
comparison lisp/cedet/semantic/mru-bookmark.el @ 104507:51e316109fba
lisp/cedet/semantic/mru-bookmark.el: New file.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Mon, 21 Sep 2009 02:26:07 +0000 |
parents | |
children | 32af6b5a433d |
comparison
equal
deleted
inserted
replaced
104506:801834237f9c | 104507:51e316109fba |
---|---|
1 ;;; semantic/mru-bookmark.el --- Automatic bookmark tracking | |
2 | |
3 ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Eric M. Ludlam <eric@siege-engine.com> | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
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. | |
13 | |
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. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
21 | |
22 ;;; Commentary: | |
23 ;; | |
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. | |
27 ;; | |
28 ;; I envision this would be used in place of switch-buffers once | |
29 ;; someone got the hang of it. | |
30 ;; | |
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. | |
34 ;; | |
35 ;; Quick Start: | |
36 ;; | |
37 ;; M-x global-semantic-mru-bookmark-mode RET | |
38 ;; | |
39 ;; < edit some code > | |
40 ;; | |
41 ;; C-x B <select a tag name> RET | |
42 ;; | |
43 ;; In the above, the history is pre-filled with the tags you recenetly | |
44 ;; edited in the order you edited them. | |
45 | |
46 ;;; Code: | |
47 | |
48 (require 'semantic) | |
49 (require 'eieio-base) | |
50 (require 'ring) | |
51 | |
52 (declare-function data-debug-new-buffer "data-debug") | |
53 (declare-function data-debug-insert-object-slots "eieio-datadebug") | |
54 (declare-function semantic-momentary-highlight-tag "semantic/decorate") | |
55 | |
56 ;;; TRACKING CORE | |
57 ;; | |
58 ;; Data structure for tracking MRU tag locations | |
59 | |
60 (defclass semantic-bookmark (eieio-named) | |
61 ((tag :initarg :tag | |
62 :type semantic-tag | |
63 :documentation "The TAG this bookmark belongs to.") | |
64 (parent :type (or semantic-tag null) | |
65 :documentation "The tag that is the parent of :tag.") | |
66 (offset :type number | |
67 :documentation "The offset from `tag' start that is | |
68 somehow interesting.") | |
69 (filename :type string | |
70 :documentation "String the tag belongs to. | |
71 Set this when the tag gets unlinked from the buffer it belongs to.") | |
72 (frequency :type number | |
73 :initform 0 | |
74 :documentation "Track the frequency this tag is visited.") | |
75 (reason :type symbol | |
76 :initform t | |
77 :documentation | |
78 "The reason this tag is interesting. | |
79 Nice values are 'edit, 'read, 'jump, and 'mark. | |
80 edit - created because the tag text was edited. | |
81 read - created because point lingered in tag text. | |
82 jump - jumped to another tag from this tag. | |
83 mark - created a regular mark in this tag.") | |
84 ) | |
85 "A single bookmark.") | |
86 | |
87 (defmethod initialize-instance :AFTER ((sbm semantic-bookmark) &rest fields) | |
88 "Initialize the bookmark SBM with details about :tag." | |
89 (condition-case nil | |
90 (save-excursion | |
91 (oset sbm filename (semantic-tag-file-name (oref sbm tag))) | |
92 (semantic-go-to-tag (oref sbm tag)) | |
93 (oset sbm parent (semantic-current-tag-parent))) | |
94 (error (message "Error bookmarking tag."))) | |
95 ) | |
96 | |
97 (defmethod semantic-mrub-visit ((sbm semantic-bookmark)) | |
98 "Visit the semantic tag bookmark SBM. | |
99 Uses `semantic-go-to-tag' and highlighting." | |
100 (require 'semantic/decorate) | |
101 (with-slots (tag filename) sbm | |
102 ;; Go to the tag | |
103 (when (not (semantic-tag-in-buffer-p tag)) | |
104 (let ((fn (or (semantic-tag-file-name tag) | |
105 filename))) | |
106 (set-buffer (find-file-noselect fn)))) | |
107 (semantic-go-to-tag (oref sbm tag) (oref sbm parent)) | |
108 ;; Go back to the offset. | |
109 (condition-case nil | |
110 (let ((o (oref sbm offset))) | |
111 (forward-char o)) | |
112 (error nil)) | |
113 ;; make it visible | |
114 (switch-to-buffer (current-buffer)) | |
115 (semantic-momentary-highlight-tag tag) | |
116 )) | |
117 | |
118 (defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason) | |
119 "Update the existing bookmark SBM. | |
120 POINT is some important location. | |
121 REASON is a symbol. See slot `reason' on `semantic-bookmark'." | |
122 (condition-case nil | |
123 (progn | |
124 (with-slots (tag offset frequency) sbm | |
125 (setq offset (- point (semantic-tag-start tag))) | |
126 (setq frequency (1+ frequency)) | |
127 ) | |
128 (oset sbm reason reason)) | |
129 ;; This can fail on XEmacs at miscelaneous times. | |
130 (error nil)) | |
131 ) | |
132 | |
133 (defmethod semantic-mrub-preflush ((sbm semantic-bookmark)) | |
134 "Method called on a tag before the current buffer list of tags is flushed. | |
135 If there is a buffer match, unlink the tag." | |
136 (let ((tag (oref sbm tag)) | |
137 (parent (when (slot-boundp sbm 'parent) | |
138 (oref sbm parent)))) | |
139 (let ((b (semantic-tag-in-buffer-p tag))) | |
140 (when (and b (eq b (current-buffer))) | |
141 (semantic--tag-unlink-from-buffer tag))) | |
142 | |
143 (when parent | |
144 (let ((b (semantic-tag-in-buffer-p parent))) | |
145 (when (and b (eq b (current-buffer))) | |
146 (semantic--tag-unlink-from-buffer parent)))))) | |
147 | |
148 (defclass semantic-bookmark-ring () | |
149 ((ring :initarg :ring | |
150 :type ring | |
151 :documentation | |
152 "List of `semantic-bookmark' objects. | |
153 This list is maintained as a list with the first item | |
154 being the current location, and the rest being a list of | |
155 items that were recently visited.") | |
156 (current-index :initform 0 | |
157 :type number | |
158 :documentation | |
159 "The current index into RING for some operation. | |
160 User commands use this to move through the ring, or reset.") | |
161 ) | |
162 "Track the current MRU stack of bookmarks. | |
163 We can't use the built-in ring data structure because we need | |
164 to delete some items from the ring when we don't have the data.") | |
165 | |
166 (defvar semantic-mru-bookmark-ring (semantic-bookmark-ring | |
167 "Ring" | |
168 :ring (make-ring 20)) | |
169 "The MRU bookmark ring. | |
170 This ring tracks the most recent active tags of interest.") | |
171 | |
172 (defun semantic-mrub-find-nearby-tag (point) | |
173 "Find a nearby tag to be pushed for this current location. | |
174 Argument POINT is where to find the tag near." | |
175 ;; I thought this was a good idea, but it is not! | |
176 ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date. | |
177 (let ((tag (semantic-current-tag))) | |
178 (when (or (not tag) (semantic-tag-of-class-p tag 'type)) | |
179 (let ((nearby (or (semantic-find-tag-by-overlay-next point) | |
180 (semantic-find-tag-by-overlay-prev point)))) | |
181 (when nearby (setq tag nearby)))) | |
182 tag)) | |
183 | |
184 (defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point | |
185 &optional reason) | |
186 "Add a bookmark to the ring SBR from POINT. | |
187 REASON is why it is being pushed. See doc for `semantic-bookmark' | |
188 for possible reasons. | |
189 The resulting bookmark is then sorted within the ring." | |
190 (let* ((ring (oref sbr ring)) | |
191 (tag (semantic-mrub-find-nearby-tag (point))) | |
192 (idx 0)) | |
193 (when tag | |
194 (while (and (not (ring-empty-p ring)) (< idx (ring-size ring))) | |
195 (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag) | |
196 tag) | |
197 (ring-remove ring idx)) | |
198 (setq idx (1+ idx))) | |
199 ;; Create a new mark | |
200 (let ((sbm (semantic-bookmark (semantic-tag-name tag) | |
201 :tag tag))) | |
202 ;; Take the mark, and update it for the current state. | |
203 (ring-insert ring sbm) | |
204 (semantic-mrub-update sbm point reason)) | |
205 ))) | |
206 | |
207 (defun semantic-mrub-cache-flush-fcn () | |
208 "Function called in the `semantic-before-toplevel-cache-flush-hook`. | |
209 Cause tags in the ring to become unlinked." | |
210 (let* ((ring (oref semantic-mru-bookmark-ring ring)) | |
211 (len (ring-length ring)) | |
212 (idx 0) | |
213 ) | |
214 (while (< idx len) | |
215 (semantic-mrub-preflush (ring-ref ring idx)) | |
216 (setq idx (1+ idx))))) | |
217 | |
218 (add-hook 'semantic-before-toplevel-cache-flush-hook | |
219 'semantic-mrub-cache-flush-fcn) | |
220 | |
221 ;;; EDIT tracker | |
222 ;; | |
223 (defvar semantic-mrub-last-overlay nil | |
224 "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.") | |
225 | |
226 (defun semantic-mru-bookmark-change-hook-fcn (overlay) | |
227 "Function set into `semantic-edits-new/move-change-hook's. | |
228 Argument OVERLAY is the overlay created to mark the change. | |
229 This function pushes tags onto the tag ring." | |
230 ;; Dup? | |
231 (when (not (eq overlay semantic-mrub-last-overlay)) | |
232 (setq semantic-mrub-last-overlay overlay) | |
233 (semantic-mrub-push semantic-mru-bookmark-ring | |
234 (point) | |
235 'edit))) | |
236 | |
237 ;;; MINOR MODE | |
238 ;; | |
239 ;; Tracking minor mode. | |
240 | |
241 (defcustom global-semantic-mru-bookmark-mode nil | |
242 "*If non-nil enable global use of variable `semantic-mru-bookmark-mode'. | |
243 When this mode is enabled, changes made to a buffer are highlighted | |
244 until the buffer is reparsed." | |
245 :group 'semantic | |
246 :group 'semantic-modes | |
247 :type 'boolean | |
248 :require 'semantic-util-modes | |
249 :initialize 'custom-initialize-default | |
250 :set (lambda (sym val) | |
251 (global-semantic-mru-bookmark-mode (if val 1 -1)))) | |
252 | |
253 ;;;###autoload | |
254 (defun global-semantic-mru-bookmark-mode (&optional arg) | |
255 "Toggle global use of option `semantic-mru-bookmark-mode'. | |
256 If ARG is positive, enable, if it is negative, disable. | |
257 If ARG is nil, then toggle." | |
258 (interactive "P") | |
259 (setq global-semantic-mru-bookmark-mode | |
260 (semantic-toggle-minor-mode-globally | |
261 'semantic-mru-bookmark-mode arg))) | |
262 | |
263 (defcustom semantic-mru-bookmark-mode-hook nil | |
264 "*Hook run at the end of function `semantic-mru-bookmark-mode'." | |
265 :group 'semantic | |
266 :type 'hook) | |
267 | |
268 (defvar semantic-mru-bookmark-mode-map | |
269 (let ((km (make-sparse-keymap))) | |
270 (define-key km "\C-xB" 'semantic-mrub-switch-tags) | |
271 km) | |
272 "Keymap for mru-bookmark minor mode.") | |
273 | |
274 (defvar semantic-mru-bookmark-mode nil | |
275 "Non-nil if mru-bookmark minor mode is enabled. | |
276 Use the command `semantic-mru-bookmark-mode' to change this variable.") | |
277 (make-variable-buffer-local 'semantic-mru-bookmark-mode) | |
278 | |
279 (defun semantic-mru-bookmark-mode-setup () | |
280 "Setup option `semantic-mru-bookmark-mode'. | |
281 The minor mode can be turned on only if semantic feature is available | |
282 and the current buffer was set up for parsing. When minor mode is | |
283 enabled parse the current buffer if needed. Return non-nil if the | |
284 minor mode is enabled." | |
285 (if semantic-mru-bookmark-mode | |
286 (if (not (and (featurep 'semantic) (semantic-active-p))) | |
287 (progn | |
288 ;; Disable minor mode if semantic stuff not available | |
289 (setq semantic-mru-bookmark-mode nil) | |
290 (error "Buffer %s was not set up for parsing" | |
291 (buffer-name))) | |
292 (semantic-make-local-hook 'semantic-edits-new-change-hooks) | |
293 (add-hook 'semantic-edits-new-change-hooks | |
294 'semantic-mru-bookmark-change-hook-fcn nil t) | |
295 (add-hook 'semantic-edits-move-change-hooks | |
296 'semantic-mru-bookmark-change-hook-fcn nil t) | |
297 ) | |
298 ;; Remove hooks | |
299 (remove-hook 'semantic-edits-new-change-hooks | |
300 'semantic-mru-bookmark-change-hook-fcn t) | |
301 (remove-hook 'semantic-edits-move-change-hooks | |
302 'semantic-mru-bookmark-change-hook-fcn t) | |
303 ) | |
304 semantic-mru-bookmark-mode) | |
305 | |
306 (defun semantic-mru-bookmark-mode (&optional arg) | |
307 "Minor mode for tracking tag-based bookmarks automatically. | |
308 Tag based bookmarks a tracked based on editing and viewing habits | |
309 and can then be navigated via the MRU bookmark keymap. | |
310 | |
311 \\{semantic-mru-bookmark-mode-map} | |
312 | |
313 With prefix argument ARG, turn on if positive, otherwise off. The | |
314 minor mode can be turned on only if semantic feature is available and | |
315 the current buffer was set up for parsing. Return non-nil if the | |
316 minor mode is enabled." | |
317 (interactive | |
318 (list (or current-prefix-arg | |
319 (if semantic-mru-bookmark-mode 0 1)))) | |
320 (setq semantic-mru-bookmark-mode | |
321 (if arg | |
322 (> | |
323 (prefix-numeric-value arg) | |
324 0) | |
325 (not semantic-mru-bookmark-mode))) | |
326 (semantic-mru-bookmark-mode-setup) | |
327 (run-hooks 'semantic-mru-bookmark-mode-hook) | |
328 (if (interactive-p) | |
329 (message "mru-bookmark minor mode %sabled" | |
330 (if semantic-mru-bookmark-mode "en" "dis"))) | |
331 (semantic-mode-line-update) | |
332 semantic-mru-bookmark-mode) | |
333 | |
334 (semantic-add-minor-mode 'semantic-mru-bookmark-mode | |
335 "k" | |
336 semantic-mru-bookmark-mode-map) | |
337 | |
338 ;;; COMPLETING READ | |
339 ;; | |
340 ;; Ask the user for a tag in MRU order. | |
341 (defun semantic-mrub-read-history nil | |
342 "History of `semantic-mrub-completing-read'.") | |
343 | |
344 (defun semantic-mrub-ring-to-assoc-list (ring) | |
345 "Convert RING into an association list for completion." | |
346 (let ((idx 0) | |
347 (len (ring-length ring)) | |
348 (al nil)) | |
349 (while (< idx len) | |
350 (let ((r (ring-ref ring idx))) | |
351 (setq al (cons (cons (oref r :object-name) r) | |
352 al))) | |
353 (setq idx (1+ idx))) | |
354 (nreverse al))) | |
355 | |
356 (defun semantic-mrub-completing-read (prompt) | |
357 "Do a `completing-read' on elements from the mru bookmark ring. | |
358 Argument PROMPT is the promot to use when reading." | |
359 (if (ring-empty-p (oref semantic-mru-bookmark-ring ring)) | |
360 (error "Semantic Bookmark ring is currently empty")) | |
361 (let* ((ring (oref semantic-mru-bookmark-ring ring)) | |
362 (ans nil) | |
363 (alist (semantic-mrub-ring-to-assoc-list ring)) | |
364 (first (cdr (car alist))) | |
365 (semantic-mrub-read-history nil) | |
366 ) | |
367 ;; Don't include the current tag.. only those that come after. | |
368 (if (semantic-equivalent-tag-p (oref first tag) | |
369 (semantic-current-tag)) | |
370 (setq first (cdr (car (cdr alist))))) | |
371 ;; Create a fake history list so we don't have to bind | |
372 ;; M-p and M-n to our special cause. | |
373 (let ((elts (reverse alist))) | |
374 (while elts | |
375 (setq semantic-mrub-read-history | |
376 (cons (car (car elts)) semantic-mrub-read-history)) | |
377 (setq elts (cdr elts)))) | |
378 (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history)) | |
379 | |
380 ;; Do the read/prompt | |
381 (let ((prompt (if first (format "%s (%s): " prompt | |
382 (semantic-format-tag-name | |
383 (oref first tag) t) | |
384 ) | |
385 (concat prompt ": "))) | |
386 ) | |
387 (setq ans | |
388 (completing-read prompt alist nil nil nil 'semantic-mrub-read-history))) | |
389 ;; Calculate the return tag. | |
390 (if (string= ans "") | |
391 (setq ans first) | |
392 ;; Return the bookmark object. | |
393 (setq ans (assoc ans alist)) | |
394 (if ans | |
395 (cdr ans) | |
396 ;; no match. Custom word. Look it up somwhere? | |
397 nil) | |
398 ))) | |
399 | |
400 (defun semantic-mrub-switch-tags (tagmark) | |
401 "Switch tags to TAGMARK. | |
402 Selects a new tag via promt through the mru tag ring. | |
403 Jumps to the tag and highlights it briefly." | |
404 (interactive (list (semantic-mrub-completing-read "Switch to tag"))) | |
405 (if (not (semantic-bookmark-p tagmark)) | |
406 (signal 'wrong-type-argument tagmark)) | |
407 | |
408 (semantic-mrub-push semantic-mru-bookmark-ring | |
409 (point) | |
410 'jump) | |
411 (semantic-mrub-visit tagmark) | |
412 ) | |
413 | |
414 ;;; ADVICE | |
415 ;; | |
416 ;; Advise some commands to help set tag marks. | |
417 ;; (defadvice push-mark (around semantic-mru-bookmark activate) | |
418 ;; "Push a mark at LOCATION with NOMSG and ACTIVATE passed to `push-mark'. | |
419 ;; If `semantic-mru-bookmark-mode' is active, also push a tag onto | |
420 ;; the mru bookmark stack." | |
421 ;; (semantic-mrub-push semantic-mru-bookmark-ring | |
422 ;; (point) | |
423 ;; 'mark) | |
424 ;; ad-do-it) | |
425 | |
426 ;(defadvice set-mark-command (around semantic-mru-bookmark activate) | |
427 ; "Set this buffer's mark to POS. | |
428 ;If `semantic-mru-bookmark-mode' is active, also push a tag onto | |
429 ;the mru bookmark stack." | |
430 ; (when (and semantic-mru-bookmark-mode (interactive-p)) | |
431 ; (semantic-mrub-push semantic-mru-bookmark-ring | |
432 ; (point) | |
433 ; 'mark)) | |
434 ; ad-do-it) | |
435 | |
436 | |
437 ;;; Debugging | |
438 ;; | |
439 (defun semantic-adebug-mrub () | |
440 "Display a list of items in the MRU bookmarks list. | |
441 Useful for debugging mrub problems." | |
442 (interactive) | |
443 (require 'eieio-datadebug) | |
444 (let* ((out semantic-mru-bookmark-ring)) | |
445 (data-debug-new-buffer "*TAG RING ADEBUG*") | |
446 (data-debug-insert-object-slots out "]") | |
447 )) | |
448 | |
449 | |
450 (provide 'semantic/mru-bookmark) | |
451 | |
452 ;; Local variables: | |
453 ;; generated-autoload-file: "loaddefs.el" | |
454 ;; generated-autoload-feature: semantic/loaddefs | |
455 ;; generated-autoload-load-name: "semantic/mru-bookmark" | |
456 ;; End: | |
457 | |
458 ;;; semantic/mru-bookmark.el ends here |