lisp/tooltip.el

   1 ;;; tooltip.el --- Show tooltip windows
   2
   3 ;; Copyright (C) 1997, 1999, 2000, 2001 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   :version "21.1"
  53   :tag "Tool Tips")
  54
  55 (defvar tooltip-mode)
  56
  57 (defcustom tooltip-delay 1.0
  58   "Seconds to wait before displaying a tooltip the first time."
  59   :tag "Delay"
  60   :type 'number
  61   :group 'tooltip)
  62
  63
  64 (defcustom tooltip-short-delay 0.1
  65   "Seconds to wait between subsequent tooltips on different items."
  66   :tag "Short delay"
  67   :type 'number
  68   :group 'tooltip)
  69
  70
  71 (defcustom tooltip-recent-seconds 1
  72   "Display tooltips if changing tip items within this many seconds.
  73 Do so after `tooltip-short-delay'."
  74   :tag "Recent seconds"
  75   :type 'number
  76   :group 'tooltip)
  77
  78
  79 (defcustom tooltip-hide-delay 5
  80   "Hide tooltips automatically after this many seconds."
  81   :tag "Hide delay"
  82   :type 'number
  83   :group 'tooltip)
  84
  85
  86 (defcustom tooltip-x-offset nil
  87   "Specify an X offset for the display of tooltips.
  88 The offset is relative to the position of the mouse.  It must
  89 be chosen so that the tooltip window doesn't contain the mouse
  90 when it pops up."
  91   :tag "X offset"
  92   :type '(choice (const :tag "Default" nil)
  93                  (integer :tag "Offset" :value 1))
  94   :group 'tooltip)
  95
  96
  97 (defcustom tooltip-y-offset nil
  98   "Specify an Y offset for the display of tooltips.
  99 The offset is relative to the position of the mouse.  It must
 100 be chosen so that the tooltip window doesn't contain the mouse
 101 when it pops up."
 102   :tag "Y offset"
 103   :type '(choice (const :tag "Default" nil)
 104                  (integer :tag "Offset" :value 1))
 105   :group 'tooltip)
 106
 107
 108 (defcustom tooltip-frame-parameters
 109   '((name . "tooltip")
 110     (internal-border-width . 5)
 111     (border-width . 1))
 112   "Frame parameters used for tooltips."
 113   :type 'sexp
 114   :tag "Frame Parameters"
 115   :group 'tooltip)
 116
 117
 118 (defface tooltip
 119   '((((class color))
 120      (:background "lightyellow" :foreground "black"))
 121     (t ()))
 122   "Face for tooltips."
 123   :group 'tooltip)
 124
 125
 126 (defcustom tooltip-gud-tips-p nil
 127   "*Non-nil means show tooltips in GUD sessions."
 128   :type 'boolean
 129   :tag "GUD"
 130   :set #'(lambda (symbol on)
 131            (setq tooltip-gud-tips-p on)
 132            (if on (tooltip-gud-tips-setup)))
 133   :group 'tooltip)
 134
 135
 136 (defcustom tooltip-gud-modes '(gud-mode c-mode c++-mode)
 137   "List of modes for which to enable GUD tips."
 138   :type 'sexp
 139   :tag "GUD modes"
 140   :group 'tooltip)
 141
 142
 143 (defcustom tooltip-gud-display
 144   '((eq (tooltip-event-buffer tooltip-gud-event)
 145         (marker-buffer overlay-arrow-position)))
 146   "List of forms determining where GUD tooltips are displayed.
 147
 148 Forms in the list are combined with AND.  The default is to display
 149 only tooltips in the buffer containing the overlay arrow."
 150   :type 'sexp
 151   :tag "GUD buffers predicate"
 152   :group 'tooltip)
 153
 154
 155 (defcustom tooltip-use-echo-area nil
 156   "Use the echo area instead of tooltip frames.
 157 This is only relevant GUD display, since otherwise it is equivalent to
 158 turning off Tooltip mode."
 159   :type 'boolean
 160   :tag "Use echo area"
 161   :group 'tooltip)
 162
 163 \f
 164 ;;; Variables that are not customizable.
 165
 166 (defvar tooltip-hook nil
 167   "Functions to call to display tooltips.
 168 Each function is called with one argument EVENT which is a copy of
 169 the last mouse movement event that occurred.")
 170
 171
 172 (defvar tooltip-timeout-id nil
 173   "The id of the timeout started when Emacs becomes idle.")
 174
 175
 176 (defvar tooltip-last-mouse-motion-event nil
 177   "A copy of the last mouse motion event seen.")
 178
 179
 180 (defvar tooltip-hide-time nil
 181   "Time when the last tooltip was hidden.")
 182
 183
 184 (defvar tooltip-gud-debugger nil
 185   "The debugger for which we show tooltips.")
 186
 187
 188 \f
 189 ;;; Event accessors
 190
 191 (defun tooltip-event-buffer (event)
 192   "Return the buffer over which event EVENT occurred.
 193 This might return nil if the event did not occur over a buffer."
 194   (let ((window (posn-window (event-end event))))
 195     (and window (window-buffer window))))
 196
 197
 198 \f
 199 ;;; Switching tooltips on/off
 200
 201 ;; We don't set track-mouse globally because this is a big redisplay
 202 ;; problem in buffers having a pre-command-hook or such installed,
 203 ;; which does a set-buffer, like the summary buffer of Gnus.  Calling
 204 ;; set-buffer prevents redisplay optimizations, so every mouse motion
 205 ;; would be accompanied by a full redisplay.
 206
 207 ;;;###autoload
 208 (defun tooltip-mode (&optional arg)
 209   "Mode for tooltip display.
 210 With ARG, turn tooltip mode on if and only if ARG is positive."
 211   (interactive "P")
 212   (unless (fboundp 'x-show-tip)
 213     (error "Sorry, tooltips are not yet available on this system"))
 214   (let* ((on (if arg
 215                  (> (prefix-numeric-value arg) 0)
 216                (not tooltip-mode)))
 217          (hook-fn (if on 'add-hook 'remove-hook)))
 218     (setq tooltip-mode on)
 219     (funcall hook-fn 'change-major-mode-hook 'tooltip-change-major-mode)
 220     (tooltip-activate-mouse-motions-if-enabled)
 221     (funcall hook-fn 'pre-command-hook 'tooltip-hide)
 222     (funcall hook-fn 'tooltip-hook 'tooltip-gud-tips)
 223     (funcall hook-fn 'tooltip-hook 'tooltip-help-tips)
 224     (setq show-help-function (if on 'tooltip-show-help-function nil))
 225     ;; `ignore' is the default binding for mouse movements.
 226     (define-key global-map [mouse-movement]
 227       (if on 'tooltip-mouse-motion 'ignore))
 228     (tooltip-gud-tips-setup)))
 229
 230 (defun tooltip-gud-tips-setup ()
 231   "Setup debugger mode-hooks for tooltips."
 232   (when (and tooltip-mode tooltip-gud-tips-p)
 233     (global-set-key [S-mouse-3] 'tooltip-gud-toggle-dereference)
 234     (add-hook 'gdb-mode-hook
 235               #'(lambda () (setq tooltip-gud-debugger 'gdb)))
 236     (add-hook 'sdb-mode-hook
 237               #'(lambda () (setq tooltip-gud-debugger 'sdb)))
 238     (add-hook 'dbx-mode-hook
 239               #'(lambda () (setq tooltip-gud-debugger 'dbx)))
 240     (add-hook 'xdb-mode-hook
 241               #'(lambda () (setq tooltip-gud-debugger 'xdb)))
 242     (add-hook 'perldb-mode-hook
 243               #'(lambda () (setq tooltip-gud-debugger 'perldb)))))
 244 \f
 245 ;;; Timeout for tooltip display
 246
 247 (defun tooltip-delay ()
 248   "Return the delay in seconds for the next tooltip."
 249   (let ((delay tooltip-delay)
 250         (now (float-time)))
 251     (when (and tooltip-hide-time
 252                (< (- now tooltip-hide-time) tooltip-recent-seconds))
 253       (setq delay tooltip-short-delay))
 254     delay))
 255
 256
 257 (defun tooltip-cancel-delayed-tip ()
 258   "Disable the tooltip timeout."
 259   (when tooltip-timeout-id
 260     (disable-timeout tooltip-timeout-id)
 261     (setq tooltip-timeout-id nil)))
 262
 263
 264 (defun tooltip-start-delayed-tip ()
 265   "Add a one-shot timeout to call function tooltip-timeout."
 266   (setq tooltip-timeout-id
 267         (add-timeout (tooltip-delay) 'tooltip-timeout nil)))
 268
 269
 270 (defun tooltip-timeout (object)
 271   "Function called when timer with id tooltip-timeout-id fires."
 272   (run-hook-with-args-until-success 'tooltip-hook
 273                                     tooltip-last-mouse-motion-event))
 274
 275
 276 \f
 277 ;;; Reacting on mouse movements
 278
 279 (defun tooltip-change-major-mode ()
 280   "Function added to `change-major-mode-hook' when tooltip mode is on."
 281   (add-hook 'post-command-hook 'tooltip-activate-mouse-motions-if-enabled))
 282
 283
 284 (defun tooltip-activate-mouse-motions-if-enabled ()
 285   "Reconsider for all buffers whether mouse motion events are desired."
 286   (remove-hook 'post-command-hook 'tooltip-activate-mouse-motions-if-enabled)
 287   (let ((buffers (buffer-list)))
 288     (save-excursion
 289       (while buffers
 290         (set-buffer (car buffers))
 291         (if (and tooltip-mode
 292                  tooltip-gud-tips-p
 293                  (memq major-mode tooltip-gud-modes))
 294             (tooltip-activate-mouse-motions t)
 295           (tooltip-activate-mouse-motions nil))
 296         (setq buffers (cdr buffers))))))
 297
 298
 299 (defun tooltip-activate-mouse-motions (activatep)
 300   "Activate/deactivate mouse motion events for the current buffer.
 301 ACTIVATEP non-nil means activate mouse motion events."
 302   (if activatep
 303       (progn
 304         (make-local-variable 'track-mouse)
 305         (setq track-mouse t))
 306     (kill-local-variable 'track-mouse)))
 307
 308
 309 (defun tooltip-mouse-motion (event)
 310   "Command handler for mouse movement events in `global-map'."
 311   (interactive "e")
 312   (tooltip-hide)
 313   (when (car (mouse-pixel-position))
 314     (setq tooltip-last-mouse-motion-event (copy-sequence event))
 315     (tooltip-start-delayed-tip)))
 316
 317
 318 \f
 319 ;;; Displaying tips
 320
 321 (defun tooltip-set-param (alist key value)
 322   "Change the value of KEY in alist ALIAS to VALUE.
 323 If there's no association for KEY in ALIST, add one, otherwise
 324 change the existing association.  Value is the resulting alist."
 325   (let ((param (assq key alist)))
 326     (if (consp param)
 327         (setcdr param value)
 328       (push (cons key value) alist))
 329     alist))
 330
 331
 332 (defun tooltip-show (text)
 333   "Show a tooltip window at the current mouse position displaying TEXT."
 334   (if tooltip-use-echo-area
 335       (message "%s" text)
 336     (condition-case error
 337         (let ((params (copy-sequence tooltip-frame-parameters))
 338               (fg (face-attribute 'tooltip :foreground))
 339               (bg (face-attribute 'tooltip :background)))
 340           (when (stringp fg)
 341             (setq params (tooltip-set-param params 'foreground-color fg))
 342             (setq params (tooltip-set-param params 'border-color fg)))
 343           (when (stringp bg)
 344             (setq params (tooltip-set-param params 'background-color bg)))
 345           (x-show-tip (propertize text 'face 'tooltip)
 346                       (selected-frame)
 347                       params
 348                       tooltip-hide-delay
 349                       tooltip-x-offset
 350                       tooltip-y-offset))
 351       (error
 352        (message "Error while displaying tooltip: %s" error)
 353        (sit-for 1)
 354        (message "%s" text)))))
 355
 356
 357 (defun tooltip-hide (&optional ignored-arg)
 358   "Hide a tooltip, if one is displayed.
 359 Value is non-nil if tooltip was open."
 360   (tooltip-cancel-delayed-tip)
 361   (when (x-hide-tip)
 362     (setq tooltip-hide-time (float-time))))
 363
 364
 365 \f
 366 ;;; Debugger-related functions
 367
 368 (defun tooltip-identifier-from-point (point)
 369   "Extract the identifier at POINT, if any.
 370 Value is nil if no identifier exists at point.  Identifier extraction
 371 is based on the current syntax table."
 372   (save-excursion
 373     (goto-char point)
 374     (let ((start (progn (skip-syntax-backward "w_") (point))))
 375       (unless (looking-at "[0-9]")
 376         (skip-syntax-forward "w_")
 377         (when (> (point) start)
 378           (buffer-substring start (point)))))))
 379
 380
 381 (defmacro tooltip-region-active-p ()
 382   "Value is non-nil if the region is currently active."
 383   (if (string-match "^GNU" (emacs-version))
 384       `(and transient-mark-mode mark-active)
 385     `(region-active-p)))
 386
 387
 388 (defun tooltip-expr-to-print (event)
 389   "Return an expression that should be printed for EVENT.
 390 If a region is active and the mouse is inside the region, print
 391 the region.  Otherwise, figure out the identifier around the point
 392 where the mouse is."
 393   (save-excursion
 394     (set-buffer (tooltip-event-buffer event))
 395     (let ((point (posn-point (event-end event))))
 396       (if (tooltip-region-active-p)
 397           (when (and (<= (region-beginning) point) (<= point (region-end)))
 398             (buffer-substring (region-beginning) (region-end)))
 399         (tooltip-identifier-from-point point)))))
 400
 401
 402 (defun tooltip-process-prompt-regexp (process)
 403   "Return regexp matching the prompt of PROCESS at the end of a string.
 404 The prompt is taken from the value of COMINT-PROMPT-REGEXP in the buffer
 405 of PROCESS."
 406   (let ((prompt-regexp (save-excursion
 407                          (set-buffer (process-buffer process))
 408                          comint-prompt-regexp)))
 409     ;; Most start with `^' but the one for `sdb' cannot be easily
 410     ;; stripped.  Code the prompt for `sdb' fixed here.
 411     (if (= (aref prompt-regexp 0) ?^)
 412         (setq prompt-regexp (substring prompt-regexp 1))
 413       (setq prompt-regexp "\\*"))
 414     (concat "\n*" prompt-regexp "$")))
 415
 416
 417 (defun tooltip-strip-prompt (process output)
 418   "Return OUTPUT with any prompt of PROCESS stripped from its end."
 419   (let ((prompt-regexp (tooltip-process-prompt-regexp process)))
 420     (save-match-data
 421       (when (string-match prompt-regexp output)
 422         (setq output (substring output 0 (match-beginning 0)))))
 423     output))
 424
 425
 426 \f
 427 ;;; Tips for `gud'
 428
 429 (defvar tooltip-gud-original-filter nil
 430   "Process filter to restore after GUD output has been received.")
 431
 432
 433 (defvar tooltip-gud-dereference nil
 434   "Non-nil means print expressions with a `*' in front of them.
 435 For C this would dereference a pointer expression.")
 436
 437
 438 (defvar tooltip-gud-event nil
 439   "The mouse movement event that led to a tooltip display.
 440 This event can be examined by forms in TOOLTIP-GUD-DISPLAY.")
 441
 442
 443 (defvar tooltip-gud-debugger nil
 444   "A symbol describing the debugger running under GUD.")
 445
 446
 447 (defun tooltip-gud-toggle-dereference ()
 448   "Toggle whether tooltips should show `* expr' or `expr'."
 449   (interactive)
 450   (setq tooltip-gud-dereference (not tooltip-gud-dereference))
 451   (when (interactive-p)
 452     (message "Dereferencing is now %s."
 453              (if tooltip-gud-dereference "on" "off"))))
 454
 455
 456 (defun tooltip-gud-process-output (process output)
 457   "Process debugger output and show it in a tooltip window."
 458   (set-process-filter process tooltip-gud-original-filter)
 459   (tooltip-show (tooltip-strip-prompt process output)))
 460
 461
 462 (defun tooltip-gud-print-command (expr)
 463   "Return a suitable command to print the expression EXPR.
 464 If TOOLTIP-GUD-DEREFERENCE is t, also prepend a `*' to EXPR."
 465   (when tooltip-gud-dereference
 466     (setq expr (concat "*" expr)))
 467   (case tooltip-gud-debugger
 468     ((gdb dbx) (concat "print " expr))
 469     (xdb (concat "p " expr))
 470     (sdb (concat expr "/"))
 471     (perldb expr)))
 472
 473
 474 (defun tooltip-gud-tips (event)
 475   "Show tip for identifier or selection under the mouse.
 476 The mouse must either point at an identifier or inside a selected
 477 region for the tip window to be shown.  If tooltip-gud-dereference is t,
 478 add a `*' in front of the printed expression.
 479
 480 This function must return nil if it doesn't handle EVENT."
 481   (let (gud-buffer process)
 482     (when (and (eventp event)
 483                tooltip-gud-tips-p
 484                (boundp 'gud-comint-buffer)
 485                (setq gud-buffer gud-comint-buffer)
 486                (setq process (get-buffer-process gud-buffer))
 487                (posn-point (event-end event))
 488                (progn (setq tooltip-gud-event event)
 489                       (eval (cons 'and tooltip-gud-display))))
 490       (let ((expr (tooltip-expr-to-print event)))
 491         (when expr
 492           (let ((cmd (tooltip-gud-print-command expr)))
 493             (unless (null cmd)         ; CMD can be nil if unknown debugger
 494               (setq tooltip-gud-original-filter (process-filter process))
 495               (set-process-filter process 'tooltip-gud-process-output)
 496               (gud-basic-call cmd)
 497               expr)))))))
 498
 499 \f
 500 ;;; Tooltip help.
 501
 502 (defvar tooltip-help-message nil
 503   "The last help message received via `tooltip-show-help-function'.")
 504
 505
 506 (defun tooltip-show-help-function (msg)
 507   "Function installed as `show-help-function'.
 508 MSG is either a help string to display, or nil to cancel the display."
 509   (let ((previous-help tooltip-help-message))
 510     (setq tooltip-help-message msg)
 511     (cond ((null msg)
 512            ;; Cancel display.  This also cancels a delayed tip, if
 513            ;; there is one.
 514            (tooltip-hide))
 515           ((equal previous-help msg)
 516            ;; Same help as before (but possibly the mouse has moved).
 517            ;; Keep what we have.
 518            )
 519           (t
 520            ;; A different help.  Remove a previous tooltip, and
 521            ;; display a new one, with some delay.
 522            (tooltip-hide)
 523            (tooltip-start-delayed-tip)))))
 524
 525
 526 (defun tooltip-help-tips (event)
 527   "Hook function to display a help tooltip.
 528 This is installed on the hook `tooltip-hook', which is run when
 529 the the timer with ID `tooltip-timeout-id' fires.
 530 Value is non-nil if this function handled the tip."
 531   (when (stringp tooltip-help-message)
 532     (tooltip-show tooltip-help-message)
 533     t))
 534
 535
 536 \f
 537 ;;; Do this after all functions have been defined that are called from
 538 ;;; `tooltip-mode'.  The actual default value of `tooltip-mode' is set
 539 ;;; in startup.el.
 540
 541 ;;;###autoload
 542 (defcustom tooltip-mode nil
 543   "Toggle tooltip-mode.
 544 Setting this variable directly does not take effect;
 545 use either \\[customize] or the function `tooltip-mode'."
 546   :set (lambda (symbol value)
 547          (tooltip-mode (or value 0)))
 548   :initialize 'custom-initialize-default
 549   :type 'boolean
 550   :require 'tooltip
 551   :group 'tooltip)
 552
 553
 554 ;;; tooltip.el ends here