Commit | Line | Data |
---|---|---|
7840ced1 GM |
1 | ;;; tooltip.el --- Show tooltip windows |
2 | ||
3 | ;; Copyright (C) 1997 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Gerd Moellmann <gerd@acm.org> | |
6 | ;; Keywords: help c mouse tools | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation; either version 2, or (at your option) | |
13 | ;; any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;; Boston, MA 02111-1307, USA. | |
24 | ||
25 | ;;; Commentary: | |
26 | ||
27 | ;; Put into your `.emacs' | |
28 | ||
29 | ;; (require 'tooltip) | |
30 | ;; (tooltip-mode 1) | |
31 | ||
32 | ||
33 | \f | |
34 | ;;; Code: | |
35 | ||
36 | (eval-when-compile | |
37 | (require 'cl) | |
38 | (require 'comint) | |
39 | (require 'gud)) | |
40 | ||
41 | (provide 'tooltip) | |
42 | ||
43 | \f | |
44 | ;;; Customizable settings | |
45 | ||
46 | (defgroup tooltip nil | |
47 | "Customization group for the `tooltip' package." | |
48 | :group 'help | |
49 | :group 'c | |
50 | :group 'mouse | |
51 | :group 'tools | |
52 | :tag "Tool Tips") | |
53 | ||
54 | ||
55 | (defcustom tooltip-delay 1.0 | |
56 | "Seconds to wait before displaying a tooltip the first time." | |
57 | :tag "Delay" | |
58 | :type 'number | |
59 | :group 'tooltip) | |
60 | ||
61 | ||
62 | (defcustom tooltip-short-delay 0.1 | |
63 | "Seconds to wait between subsequent tooltips on different items." | |
64 | :tag "Short delay" | |
65 | :type 'number | |
66 | :group 'tooltip) | |
67 | ||
68 | ||
69 | (defcustom tooltip-recent-seconds 1 | |
70 | "Display tooltips after `tooltip-short-delay' if changing tip items | |
71 | within this many seconds." | |
72 | :tag "Recent seconds" | |
73 | :type 'number | |
74 | :group 'tooltip) | |
75 | ||
76 | ||
77 | (defcustom tooltip-frame-parameters | |
78 | '((name . "tooltip") | |
79 | (foreground-color . "black") | |
80 | (background-color . "lightyellow") | |
81 | (internal-border-width . 5) | |
82 | (border-color . "lightyellow") | |
83 | (border-width . 1)) | |
84 | "Frame parameters used for tooltips." | |
85 | :type 'sexp | |
86 | :tag "Frame Parameters" | |
87 | :group 'tooltip) | |
88 | ||
89 | ||
90 | (defcustom tooltip-gud-tips-p nil | |
91 | "Non-nil means show tooltips in GUD sessions." | |
92 | :type 'boolean | |
93 | :tag "GUD" | |
94 | :group 'tooltip) | |
95 | ||
96 | ||
97 | (defcustom tooltip-gud-modes '(gud-mode c-mode c++-mode) | |
98 | "List of modes for which to enable GUD tips." | |
99 | :type 'sexp | |
100 | :tag "GUD modes" | |
101 | :group 'tooltip) | |
102 | ||
103 | ||
104 | (defcustom tooltip-gud-display | |
105 | '((eq (tooltip-event-buffer tooltip-gud-event) | |
106 | (marker-buffer overlay-arrow-position))) | |
107 | "List of forms determining where GUD tooltips are displayed. | |
108 | ||
109 | Forms in the list are combined with AND. The default is to display | |
110 | only tooltips in the buffer containing the overlay arrow." | |
111 | :type 'sexp | |
112 | :tag "GUD buffers predicate" | |
113 | :group 'tooltip) | |
114 | ||
115 | ||
116 | \f | |
117 | ;;; Variables that are not customizable. | |
118 | ||
119 | (defvar tooltip-hook nil | |
120 | "Functions to call to display tooltips. | |
121 | Each function is called with one argument EVENT which is a copy of | |
122 | the last mouse movement event that occurred.") | |
123 | ||
124 | ||
125 | (defvar tooltip-timeout-id nil | |
126 | "The id of the timeout started when Emacs becomes idle.") | |
127 | ||
128 | ||
129 | (defvar tooltip-last-mouse-motion-event nil | |
130 | "A copy of the last mouse motion event seen.") | |
131 | ||
132 | ||
133 | (defvar tooltip-hide-time nil | |
134 | "Time when the last tooltip was hidden.") | |
135 | ||
136 | ||
137 | (defvar tooltip-mode nil | |
138 | "Non-nil means tooltip mode is on.") | |
139 | ||
140 | ||
141 | (defvar tooltip-gud-debugger nil | |
142 | "The debugger for which we show tooltips.") | |
143 | ||
144 | ||
145 | \f | |
146 | ;;; Event accessors | |
147 | ||
148 | (defun tooltip-event-buffer (event) | |
149 | "Return the buffer over which event EVENT occurred. | |
150 | This might return nil if the event did not occur over a buffer." | |
151 | (let ((window (posn-window (event-end event)))) | |
152 | (and window (window-buffer window)))) | |
153 | ||
154 | ||
155 | \f | |
156 | ;;; Switching tooltips on/off | |
157 | ||
158 | ;; We don't set track-mouse globally because this is a big redisplay | |
159 | ;; problem in buffers having a pre-command-hook or such installed, | |
160 | ;; which does a set-buffer, like the summary buffer of Gnus. Calling | |
161 | ;; set-buffer prevents redisplay optimizations, so every mouse motion | |
162 | ;; would be accompanied by a full redisplay. | |
163 | ||
164 | ;;;###autoload | |
165 | (defun tooltip-mode (&optional arg) | |
166 | "Mode for tooltip display. | |
167 | With ARG, turn tooltip mode on if and only if ARG is positive." | |
168 | (interactive "P") | |
169 | (let* ((on (if arg | |
170 | (> (prefix-numeric-value arg) 0) | |
171 | (not tooltip-mode))) | |
172 | (hook-fn (if on 'add-hook 'remove-hook))) | |
173 | (setq tooltip-mode on) | |
174 | (funcall hook-fn 'change-major-mode-hook 'tooltip-change-major-mode) | |
175 | (tooltip-activate-mouse-motions-if-enabled) | |
176 | (funcall hook-fn 'pre-command-hook 'tooltip-hide) | |
177 | (funcall hook-fn 'tooltip-hook 'tooltip-gud-tips) | |
178 | (funcall hook-fn 'tooltip-hook 'tooltip-help-tips) | |
179 | (setq show-help-function (if on 'tooltip-show-help-function nil)) | |
180 | ;; `ignore' is the default binding for mouse movements. | |
181 | (define-key global-map [mouse-movement] | |
182 | (if on 'tooltip-mouse-motion 'ignore)) | |
183 | (when (and on tooltip-gud-tips-p) | |
184 | (global-set-key [S-mouse-3] 'tooltip-gud-toggle-dereference) | |
185 | (add-hook 'gdb-mode-hook | |
186 | #'(lambda () (setq tooltip-gud-debugger 'gdb))) | |
187 | (add-hook 'sdb-mode-hook | |
188 | #'(lambda () (setq tooltip-gud-debugger 'sdb))) | |
189 | (add-hook 'dbx-mode-hook | |
190 | #'(lambda () (setq tooltip-gud-debugger 'dbx))) | |
191 | (add-hook 'xdb-mode-hook | |
192 | #'(lambda () (setq tooltip-gud-debugger 'xdb))) | |
193 | (add-hook 'perldb-mode-hook | |
194 | #'(lambda () (setq tooltip-gud-debugger 'perldb)))))) | |
195 | ||
196 | ||
197 | \f | |
198 | ;;; Timeout for tooltip display | |
199 | ||
200 | (defun tooltip-float-time () | |
201 | "Return the values of `current-time' as a float." | |
202 | (let ((now (current-time))) | |
203 | (+ (* 65536.0 (nth 0 now)) | |
204 | (nth 1 now) | |
205 | (/ (nth 2 now) 1000000.0)))) | |
206 | ||
207 | ||
208 | (defun tooltip-delay () | |
209 | "Return the delay in seconds for the next tooltip." | |
210 | (let ((delay tooltip-delay) | |
211 | (now (tooltip-float-time))) | |
212 | (when (and tooltip-hide-time | |
213 | (< (- now tooltip-hide-time) tooltip-recent-seconds)) | |
214 | (setq delay tooltip-short-delay)) | |
215 | delay)) | |
216 | ||
217 | ||
218 | (defun tooltip-disable-timeout () | |
219 | "Disable the tooltip timeout." | |
220 | (when tooltip-timeout-id | |
221 | (disable-timeout tooltip-timeout-id) | |
222 | (setq tooltip-timeout-id nil))) | |
223 | ||
224 | ||
225 | (defun tooltip-add-timeout () | |
226 | "Add a one-shot timeout to call function tooltip-timeout." | |
227 | (setq tooltip-timeout-id | |
228 | (add-timeout (tooltip-delay) 'tooltip-timeout nil))) | |
229 | ||
230 | ||
231 | (defun tooltip-timeout (object) | |
232 | "Function called when timer with id tooltip-timeout-id fires." | |
233 | (run-hook-with-args-until-success 'tooltip-hook | |
234 | tooltip-last-mouse-motion-event)) | |
235 | ||
236 | ||
237 | \f | |
238 | ;;; Reacting on mouse movements | |
239 | ||
240 | (defun tooltip-change-major-mode () | |
241 | "Function added to `change-major-mode-hook' when tooltip mode is on." | |
242 | (add-hook 'post-command-hook 'tooltip-activate-mouse-motions-if-enabled)) | |
243 | ||
244 | ||
245 | (defun tooltip-activate-mouse-motions-if-enabled () | |
246 | "Reconsider for all buffers whether mouse motion events are desired." | |
247 | (remove-hook 'post-command-hook 'tooltip-activate-mouse-motions-if-enabled) | |
248 | (let ((buffers (buffer-list))) | |
249 | (save-excursion | |
250 | (while buffers | |
251 | (set-buffer (car buffers)) | |
252 | (if (and tooltip-mode | |
253 | tooltip-gud-tips-p | |
254 | (memq major-mode tooltip-gud-modes)) | |
255 | (tooltip-activate-mouse-motions t) | |
256 | (tooltip-activate-mouse-motions nil)) | |
257 | (setq buffers (cdr buffers)))))) | |
258 | ||
259 | ||
260 | (defun tooltip-activate-mouse-motions (activatep) | |
261 | "Activate/deactivate mouse motion events for the current buffer. | |
262 | ACTIVATEP non-nil means activate mouse motion events." | |
263 | (if activatep | |
264 | (progn | |
265 | (make-local-variable 'track-mouse) | |
266 | (setq track-mouse t)) | |
267 | (kill-local-variable 'track-mouse))) | |
268 | ||
269 | ||
270 | (defun tooltip-mouse-motion (event) | |
271 | "Command handler for mouse movement events in `global-map'." | |
272 | (interactive "e") | |
273 | (tooltip-hide) | |
274 | (when (car (mouse-pixel-position)) | |
275 | (setq tooltip-last-mouse-motion-event (copy-sequence event)) | |
276 | (tooltip-add-timeout))) | |
277 | ||
278 | ||
279 | \f | |
280 | ;;; Displaying tips | |
281 | ||
282 | (defun tooltip-show (text) | |
283 | "Show a tooltip window at the current mouse position displaying TEXT." | |
284 | (x-show-tip text (selected-frame) tooltip-frame-parameters)) | |
285 | ||
286 | ||
287 | (defun tooltip-hide (&optional ignored-arg) | |
288 | "Hide a tooltip, if one is displayed. | |
289 | Value is non-nil if tooltip was open." | |
290 | (tooltip-disable-timeout) | |
291 | (when (x-hide-tip) | |
292 | (setq tooltip-hide-time (tooltip-float-time)))) | |
293 | ||
294 | ||
295 | \f | |
296 | ;;; Debugger-related functions | |
297 | ||
298 | (defun tooltip-identifier-from-point (point) | |
299 | "Extract the identifier at POINT, if any. | |
300 | Value is nil if no identifier exists at point. Identifier extraction | |
301 | is based on the current syntax table." | |
302 | (save-excursion | |
303 | (goto-char point) | |
304 | (let ((start (progn (skip-syntax-backward "w_") (point)))) | |
305 | (unless (looking-at "[0-9]") | |
306 | (skip-syntax-forward "w_") | |
307 | (when (> (point) start) | |
308 | (buffer-substring start (point))))))) | |
309 | ||
310 | ||
311 | (defmacro tooltip-region-active-p () | |
312 | "Value is non-nil if the region is currently active." | |
313 | (if (string-match "^GNU" (emacs-version)) | |
314 | `(and transient-mark-mode mark-active) | |
315 | `(region-active-p))) | |
316 | ||
317 | ||
318 | (defun tooltip-expr-to-print (event) | |
319 | "Return an expression that should be printed for EVENT. | |
320 | If a region is active and the mouse is inside the region, print | |
321 | the region. Otherwise, figure out the identifier around the point | |
322 | where the mouse is." | |
323 | (save-excursion | |
324 | (set-buffer (tooltip-event-buffer event)) | |
325 | (let ((point (posn-point (event-end event)))) | |
326 | (if (tooltip-region-active-p) | |
327 | (when (and (<= (region-beginning) point) (<= point (region-end))) | |
328 | (buffer-substring (region-beginning) (region-end))) | |
329 | (tooltip-identifier-from-point point))))) | |
330 | ||
331 | ||
332 | (defun tooltip-process-prompt-regexp (process) | |
333 | "Return regexp matching the prompt of PROCESS at the end of a string. | |
334 | The prompt is taken from the value of COMINT-PROMPT-REGEXP in the buffer | |
335 | of PROCESS." | |
336 | (let ((prompt-regexp (save-excursion | |
337 | (set-buffer (process-buffer process)) | |
338 | comint-prompt-regexp))) | |
339 | ;; Most start with `^' but the one for `sdb' cannot be easily | |
340 | ;; stripped. Code the prompt for `sdb' fixed here. | |
341 | (if (= (aref prompt-regexp 0) ?^) | |
342 | (setq prompt-regexp (substring prompt-regexp 1)) | |
343 | (setq prompt-regexp "\\*")) | |
344 | (concat "\n*" prompt-regexp "$"))) | |
345 | ||
346 | ||
347 | (defun tooltip-strip-prompt (process output) | |
348 | "Return OUTPUT with any prompt of PROCESS stripped from its end." | |
349 | (let ((prompt-regexp (tooltip-process-prompt-regexp process))) | |
350 | (save-match-data | |
351 | (when (string-match prompt-regexp output) | |
352 | (setq output (substring output 0 (match-beginning 0))))) | |
353 | output)) | |
354 | ||
355 | ||
356 | \f | |
357 | ;;; Tips for `gud' | |
358 | ||
359 | (defvar tooltip-gud-original-filter nil | |
360 | "Process filter to restore after GUD output has been received.") | |
361 | ||
362 | ||
363 | (defvar tooltip-gud-dereference nil | |
364 | "Non-nil means print expressions with a `*' in front of them. | |
365 | For C this would dereference a pointer expression.") | |
366 | ||
367 | ||
368 | (defvar tooltip-gud-event nil | |
369 | "The mouse movement event that led to a tooltip display. | |
370 | This event can be examined by forms in TOOLTIP-GUD-DISPLAY.") | |
371 | ||
372 | ||
373 | (defvar tooltip-gud-debugger nil | |
374 | "A symbol describing the debugger running under GUD.") | |
375 | ||
376 | ||
377 | (defun tooltip-gud-toggle-dereference () | |
378 | "Toggle whether tooltips should show `* exor' or `expr'." | |
379 | (interactive) | |
380 | (setq tooltip-gud-dereference (not tooltip-gud-dereference)) | |
381 | (when (interactive-p) | |
382 | (message "Dereferencing is now %s." | |
383 | (if tooltip-gud-dereference "on" "off")))) | |
384 | ||
385 | ||
386 | (defun tooltip-gud-process-output (process output) | |
387 | "Process debugger output and show it in a tooltip window." | |
388 | (set-process-filter process tooltip-gud-original-filter) | |
389 | (tooltip-show (tooltip-strip-prompt process output))) | |
390 | ||
391 | ||
392 | (defun tooltip-gud-print-command (expr) | |
393 | "Return a suitable command to print the expression EXPR. | |
394 | If TOOLTIP-GUD-DEREFERENCE is t, also prepend a `*' to EXPR." | |
395 | (when tooltip-gud-dereference | |
396 | (setq expr (concat "*" expr))) | |
397 | (case tooltip-gud-debugger | |
398 | ((gdb dbx) (concat "print " expr)) | |
399 | (xdb (concat "p " expr)) | |
400 | (sdb (concat expr "/")) | |
401 | (perldb expr))) | |
402 | ||
403 | ||
404 | (defun tooltip-gud-tips (event) | |
405 | "Show tip for identifier or selection under the mouse. The mouse | |
406 | must either point at an identifier or inside a selected region for the | |
407 | tip window to be shown. If tooltip-gud-dereference is t, add a `*' in | |
408 | front of the printed expression. | |
409 | ||
410 | This function must return nil if it doesn't handle EVENT." | |
411 | (let (gud-buffer process) | |
412 | (when (and (eventp event) | |
413 | tooltip-gud-tips-p | |
414 | (boundp 'gud-comint-buffer) | |
415 | (setq gud-buffer gud-comint-buffer) | |
416 | (setq process (get-buffer-process gud-buffer)) | |
417 | (posn-point (event-end event)) | |
418 | (progn (setq tooltip-gud-event event) | |
419 | (eval (cons 'and tooltip-gud-display)))) | |
420 | (let ((expr (tooltip-expr-to-print event))) | |
421 | (when expr | |
422 | (setq tooltip-gud-original-filter (process-filter process)) | |
423 | (set-process-filter process 'tooltip-gud-process-output) | |
424 | (process-send-string | |
425 | process (concat (tooltip-gud-print-command expr) "\n")) | |
426 | expr))))) | |
427 | ||
428 | ||
429 | \f | |
430 | ;;; Tooltip help. | |
431 | ||
432 | (defvar tooltip-help-message nil | |
433 | "The last help message received via `tooltip-show-help-function'.") | |
434 | ||
435 | ||
436 | (defun tooltip-show-help-function (msg) | |
437 | "Function installed as `show-help-function'. | |
438 | MSG is either a help string to display, or nil to cancel the display." | |
439 | (let ((previous-help tooltip-help-message)) | |
440 | (setq tooltip-help-message msg) | |
441 | (cond ((null msg) | |
442 | (tooltip-hide)) | |
443 | ((or (not (stringp previous-help)) | |
444 | (not (string= msg previous-help))) | |
445 | (tooltip-hide) | |
446 | (tooltip-add-timeout)) | |
447 | (t | |
448 | (tooltip-disable-timeout) | |
449 | (tooltip-add-timeout))))) | |
450 | ||
451 | ||
452 | (defun tooltip-help-tips (event) | |
453 | "Hook function to display a help tooltip. | |
454 | Value is non-nil if this function handled the tip." | |
455 | (when (stringp tooltip-help-message) | |
456 | (tooltip-show tooltip-help-message) | |
457 | (setq tooltip-help-message nil) | |
458 | t)) | |
459 | ||
460 | ||
461 | \f | |
462 | ;;; Do this after all functions have been defined that are called | |
463 | ;;; from `tooltip-mode'. | |
464 | ||
465 | (defcustom tooltip-active nil | |
466 | "*Non-nil means tooltips are active." | |
467 | :tag "Activate tooltips" | |
468 | :type 'boolean | |
469 | :set #'(lambda (symbol value) | |
470 | (set-default symbol value) | |
471 | (tooltip-mode (or value 0))) | |
472 | :require 'tooltip | |
473 | :group 'tooltip) | |
474 | ||
475 | ||
476 | ;;; tooltip.el ends here |