lisp/tooltip.el

   1 ;;; tooltip.el --- show tooltip windows
   2
   3 ;; Copyright (C) 1997, 1999-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Gerd Moellmann <gerd@acm.org>
   6 ;; Keywords: help c mouse tools
   7 ;; Package: emacs
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'syntax)
  29
  30 (defvar comint-prompt-regexp)
  31
  32 (defgroup tooltip nil
  33   "Customization group for the `tooltip' package."
  34   :group 'help
  35   :group 'gud
  36   :group 'mouse
  37   :group 'tools
  38   :version "21.1"
  39   :tag "Tool Tips")
  40 \f
  41 ;;; Switching tooltips on/off
  42
  43 (define-minor-mode tooltip-mode
  44   "Toggle Tooltip mode.
  45
  46 When this global minor mode is enabled, Emacs displays help
  47 text (e.g. for buttons and menu items that you put the mouse on)
  48 in a pop-up window.
  49
  50 When Tooltip mode is disabled, Emacs displays help text in the
  51 echo area, instead of making a pop-up window."
  52   :global t
  53   ;; Even if we start on a text-only terminal, make this non-nil by
  54   ;; default because we can open a graphical frame later (multi-tty).
  55   :init-value t
  56   :initialize 'custom-initialize-delay
  57   :group 'tooltip
  58   (if (and tooltip-mode (fboundp 'x-show-tip))
  59       (progn
  60         (add-hook 'pre-command-hook 'tooltip-hide)
  61         (add-hook 'tooltip-functions 'tooltip-help-tips))
  62     (unless (and (boundp 'gud-tooltip-mode) gud-tooltip-mode)
  63       (remove-hook 'pre-command-hook 'tooltip-hide))
  64     (remove-hook 'tooltip-functions 'tooltip-help-tips))
  65   (setq show-help-function
  66         (if tooltip-mode 'tooltip-show-help 'tooltip-show-help-non-mode)))
  67
  68 \f
  69 ;;; Customizable settings
  70
  71 (defcustom tooltip-delay 0.7
  72   "Seconds to wait before displaying a tooltip the first time."
  73   :type 'number
  74   :group 'tooltip)
  75
  76 (defcustom tooltip-short-delay 0.1
  77   "Seconds to wait between subsequent tooltips on different items."
  78   :type 'number
  79   :group 'tooltip)
  80
  81 (defcustom tooltip-recent-seconds 1
  82   "Display tooltips if changing tip items within this many seconds.
  83 Do so after `tooltip-short-delay'."
  84   :type 'number
  85   :group 'tooltip)
  86
  87 (defcustom tooltip-hide-delay 10
  88   "Hide tooltips automatically after this many seconds."
  89   :type 'number
  90   :group 'tooltip)
  91
  92 (defcustom tooltip-x-offset 5
  93   "X offset, in pixels, for the display of tooltips.
  94 The offset is the distance between the X position of the mouse and
  95 the left border of the tooltip window.  It must be chosen so that the
  96 tooltip window doesn't contain the mouse when it pops up, or it may
  97 interfere with clicking where you wish.
  98
  99 If `tooltip-frame-parameters' includes the `left' parameter,
 100 the value of `tooltip-x-offset' is ignored."
 101   :type 'integer
 102   :group 'tooltip)
 103
 104 (defcustom tooltip-y-offset +20
 105   "Y offset, in pixels, for the display of tooltips.
 106 The offset is the distance between the Y position of the mouse and
 107 the top border of the tooltip window.  It must be chosen so that the
 108 tooltip window doesn't contain the mouse when it pops up, or it may
 109 interfere with clicking where you wish.
 110
 111 If `tooltip-frame-parameters' includes the `top' parameter,
 112 the value of `tooltip-y-offset' is ignored."
 113   :type 'integer
 114   :group 'tooltip)
 115
 116 (defcustom tooltip-frame-parameters
 117   '((name . "tooltip")
 118     (internal-border-width . 2)
 119     (border-width . 1)
 120     (no-special-glyphs . t))
 121   "Frame parameters used for tooltips.
 122
 123 If `left' or `top' parameters are included, they specify the absolute
 124 position to pop up the tooltip.
 125
 126 Note that font and color parameters are ignored, and the attributes
 127 of the `tooltip' face are used instead."
 128   :type '(repeat (cons :format "%v"
 129                        (symbol :tag "Parameter")
 130                        (sexp :tag "Value")))
 131   :group 'tooltip
 132   :version "26.1")
 133
 134 (defface tooltip
 135   '((((class color))
 136      :background "lightyellow"
 137      :foreground "black"
 138      :inherit variable-pitch)
 139     (t
 140      :inherit variable-pitch))
 141   "Face for tooltips."
 142   :group 'tooltip
 143   :group 'basic-faces)
 144
 145 (defcustom tooltip-use-echo-area nil
 146   "Use the echo area instead of tooltip frames for help and GUD tooltips.
 147 This variable is obsolete; instead of setting it to t, disable
 148 `tooltip-mode' (which has a similar effect)."
 149   :type 'boolean
 150   :group 'tooltip)
 151
 152 (make-obsolete-variable 'tooltip-use-echo-area
 153                         "disable Tooltip mode instead" "24.1" 'set)
 154
 155 (defcustom tooltip-resize-echo-area nil
 156   "If non-nil, using the echo area for tooltips will resize the echo area.
 157 By default, when the echo area is used for displaying tooltips,
 158 the tooltip text is truncated if it exceeds a single screen line.
 159 When this variable is non-nil, the text is not truncated; instead,
 160 the echo area is resized as needed to accommodate the full text
 161 of the tooltip.
 162 This variable has effect only on GUI frames."
 163   :type 'boolean
 164   :group 'tooltip
 165   :version "27.1")
 166
 167 \f
 168 ;;; Variables that are not customizable.
 169
 170 (define-obsolete-variable-alias 'tooltip-hook 'tooltip-functions "23.1")
 171
 172 (defvar tooltip-functions nil
 173   "Functions to call to display tooltips.
 174 Each function is called with one argument EVENT which is a copy
 175 of the last mouse movement event that occurred.  If one of these
 176 functions displays the tooltip, it should return non-nil and the
 177 rest are not called.")
 178
 179 (defvar tooltip-timeout-id nil
 180   "The id of the timeout started when Emacs becomes idle.")
 181
 182 (defvar tooltip-last-mouse-motion-event nil
 183   "A copy of the last mouse motion event seen.")
 184
 185 (defvar tooltip-hide-time nil
 186   "Time when the last tooltip was hidden.")
 187
 188 (defvar gud-tooltip-mode) ;; Prevent warning.
 189
 190 ;;; Event accessors
 191
 192 (defun tooltip-event-buffer (event)
 193   "Return the buffer over which event EVENT occurred.
 194 This might return nil if the event did not occur over a buffer."
 195   (let ((window (posn-window (event-end event))))
 196     (and window (window-buffer window))))
 197
 198 \f
 199 ;;; Timeout for tooltip display
 200
 201 (defun tooltip-delay ()
 202   "Return the delay in seconds for the next tooltip."
 203   (if (and tooltip-hide-time
 204            (< (- (float-time) tooltip-hide-time) tooltip-recent-seconds))
 205       tooltip-short-delay
 206     tooltip-delay))
 207
 208 (defun tooltip-cancel-delayed-tip ()
 209   "Disable the tooltip timeout."
 210   (when tooltip-timeout-id
 211     (disable-timeout tooltip-timeout-id)
 212     (setq tooltip-timeout-id nil)))
 213
 214 (defun tooltip-start-delayed-tip ()
 215   "Add a one-shot timeout to call function `tooltip-timeout'."
 216   (setq tooltip-timeout-id
 217         (add-timeout (tooltip-delay) 'tooltip-timeout nil)))
 218
 219 (defun tooltip-timeout (_object)
 220   "Function called when timer with id `tooltip-timeout-id' fires."
 221   (run-hook-with-args-until-success 'tooltip-functions
 222                                     tooltip-last-mouse-motion-event))
 223
 224 \f
 225 ;;; Displaying tips
 226
 227 (defun tooltip-set-param (alist key value)
 228   "Change the value of KEY in alist ALIST to VALUE.
 229 If there's no association for KEY in ALIST, add one, otherwise
 230 change the existing association.  Value is the resulting alist."
 231   (declare (obsolete "use (setf (alist-get ..) ..) instead" "25.1"))
 232   (setf (alist-get key alist) value)
 233   alist)
 234
 235 (declare-function x-show-tip "xfns.c"
 236                   (string &optional frame parms timeout dx dy))
 237
 238 (defun tooltip-show (text &optional use-echo-area)
 239   "Show a tooltip window displaying TEXT.
 240
 241 Text larger than `x-max-tooltip-size' is clipped.
 242
 243 If the alist in `tooltip-frame-parameters' includes `left' and `top'
 244 parameters, they determine the x and y position where the tooltip
 245 is displayed.  Otherwise, the tooltip pops at offsets specified by
 246 `tooltip-x-offset' and `tooltip-y-offset' from the current mouse
 247 position.
 248
 249 Optional second arg USE-ECHO-AREA non-nil means to show tooltip
 250 in echo area."
 251   (if use-echo-area
 252       (tooltip-show-help-non-mode text)
 253     (condition-case error
 254         (let ((params (copy-sequence tooltip-frame-parameters))
 255               (fg (face-attribute 'tooltip :foreground))
 256               (bg (face-attribute 'tooltip :background)))
 257           (when (stringp fg)
 258             (setf (alist-get 'foreground-color params) fg)
 259             (setf (alist-get 'border-color params) fg))
 260           (when (stringp bg)
 261             (setf (alist-get 'background-color params) bg))
 262           (x-show-tip (propertize text 'face 'tooltip)
 263                       (selected-frame)
 264                       params
 265                       tooltip-hide-delay
 266                       tooltip-x-offset
 267                       tooltip-y-offset))
 268       (error
 269        (message "Error while displaying tooltip: %s" error)
 270        (sit-for 1)
 271        (message "%s" text)))))
 272
 273 (declare-function x-hide-tip "xfns.c" ())
 274
 275 (defun tooltip-hide (&optional _ignored-arg)
 276   "Hide a tooltip, if one is displayed.
 277 Value is non-nil if tooltip was open."
 278   (tooltip-cancel-delayed-tip)
 279   (when (x-hide-tip)
 280     (setq tooltip-hide-time (float-time))))
 281
 282 \f
 283 ;;; Debugger-related functions
 284
 285 (defun tooltip-identifier-from-point (point)
 286   "Extract the identifier at POINT, if any.
 287 Value is nil if no identifier exists at point.  Identifier extraction
 288 is based on the current syntax table."
 289   (save-excursion
 290     (goto-char point)
 291     (let* ((start (progn (skip-syntax-backward "w_") (point)))
 292            (pstate (syntax-ppss)))
 293       (unless (or (looking-at "[0-9]")
 294                   (nth 3 pstate)
 295                   (nth 4 pstate))
 296         (skip-syntax-forward "w_")
 297         (when (> (point) start)
 298           (buffer-substring start (point)))))))
 299
 300 (defun tooltip-expr-to-print (event)
 301   "Return an expression that should be printed for EVENT.
 302 If a region is active and the mouse is inside the region, print
 303 the region.  Otherwise, figure out the identifier around the point
 304 where the mouse is."
 305   (with-current-buffer (tooltip-event-buffer event)
 306     (let ((point (posn-point (event-end event))))
 307       (if (use-region-p)
 308           (when (and (<= (region-beginning) point) (<= point (region-end)))
 309             (buffer-substring (region-beginning) (region-end)))
 310         (tooltip-identifier-from-point point)))))
 311
 312 (defun tooltip-process-prompt-regexp (process)
 313   "Return regexp matching the prompt of PROCESS at the end of a string.
 314 The prompt is taken from the value of `comint-prompt-regexp' in
 315 the buffer of PROCESS."
 316   (let ((prompt-regexp (with-current-buffer (process-buffer process)
 317                          comint-prompt-regexp)))
 318     (concat "\n*"
 319             ;; Most start with `^' but the one for `sdb' cannot be easily
 320             ;; stripped.  Code the prompt for `sdb' fixed here.
 321             (if (= (aref prompt-regexp 0) ?^)
 322                 (substring prompt-regexp 1)
 323               "\\*")
 324             "$")))
 325
 326 (defun tooltip-strip-prompt (process output)
 327   "Return OUTPUT with any prompt of PROCESS stripped from its end."
 328   (save-match-data
 329     (if (string-match (tooltip-process-prompt-regexp process) output)
 330         (substring output 0 (match-beginning 0))
 331       output)))
 332
 333 \f
 334 ;;; Tooltip help.
 335
 336 (defvar tooltip-help-message nil
 337   "The last help message received via `show-help-function'.
 338 This is used by `tooltip-show-help' and
 339 `tooltip-show-help-non-mode'.")
 340
 341 (defvar tooltip-previous-message nil
 342   "The previous content of the echo area.")
 343
 344 (defun tooltip-show-help-non-mode (help)
 345   "Function installed as `show-help-function' when Tooltip mode is off.
 346 It is also called if Tooltip mode is on, for text-only displays."
 347   (when (and (not (window-minibuffer-p)) ;Don't overwrite minibuffer contents.
 348              (not cursor-in-echo-area))  ;Don't overwrite a prompt.
 349     (cond
 350      ((stringp help)
 351       (setq help (replace-regexp-in-string "\n" ", " help))
 352       (unless (or tooltip-previous-message
 353                   (equal-including-properties help (current-message))
 354                   (and (stringp tooltip-help-message)
 355                        (equal-including-properties tooltip-help-message
 356                                                    (current-message))))
 357         (setq tooltip-previous-message (current-message)))
 358       (setq tooltip-help-message help)
 359       (let ((message-truncate-lines
 360              (or (not (display-graphic-p)) (not tooltip-resize-echo-area)))
 361             (message-log-max nil))
 362         (message "%s" help)))
 363      ((stringp tooltip-previous-message)
 364       (let ((message-log-max nil))
 365         (message "%s" tooltip-previous-message)
 366         (setq tooltip-previous-message nil)))
 367      (t
 368       (message nil)))))
 369
 370 (defun tooltip-show-help (msg)
 371   "Function installed as `show-help-function'.
 372 MSG is either a help string to display, or nil to cancel the display."
 373   (if (display-graphic-p)
 374       (let ((previous-help tooltip-help-message))
 375         (setq tooltip-help-message msg)
 376         (cond ((null msg)
 377                ;; Cancel display.  This also cancels a delayed tip, if
 378                ;; there is one.
 379                (tooltip-hide))
 380               ((equal-including-properties previous-help msg)
 381                ;; Same help as before (but possibly the mouse has moved).
 382                ;; Keep what we have.
 383                )
 384               (t
 385                ;; A different help.  Remove a previous tooltip, and
 386                ;; display a new one, with some delay.
 387                (tooltip-hide)
 388                (tooltip-start-delayed-tip))))
 389     ;; On text-only displays, try `tooltip-show-help-non-mode'.
 390     (tooltip-show-help-non-mode msg)))
 391
 392 (defun tooltip-help-tips (_event)
 393   "Hook function to display a help tooltip.
 394 This is installed on the hook `tooltip-functions', which
 395 is run when the timer with id `tooltip-timeout-id' fires.
 396 Value is non-nil if this function handled the tip."
 397   (when (stringp tooltip-help-message)
 398     (tooltip-show tooltip-help-message tooltip-use-echo-area)
 399     t))
 400
 401 (provide 'tooltip)
 402
 403 ;;; tooltip.el ends here