1
;; tooltips.jl -- display frame-part keymap descriptions
2
;; $Id: tooltips.jl,v 1.29 2001/04/05 22:02:01 jsh Exp $
4
;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>
6
;; This file is part of sawmill.
8
;; sawmill is free software; you can redistribute it and/or modify it
9
;; under the terms of the GNU General Public License as published by
10
;; the Free Software Foundation; either version 2, or (at your option)
13
;; sawmill is distributed in the hope that it will be useful, but
14
;; WITHOUT ANY WARRANTY; without even the implied warranty of
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
;; GNU General Public License for more details.
18
;; You should have received a copy of the GNU General Public License
19
;; along with sawmill; see the file COPYING. If not, write to
20
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(define-structure sawfish.wm.ext.tooltips
24
(export display-tooltip
25
display-tooltip-after-delay
38
sawfish.wm.util.keymap)
40
(define-structure-alias tooltips sawfish.wm.ext.tooltips)
42
(define tooltips-timer nil)
44
;;###autoload (defgroup tooltips "Tooltips" :group misc :require sawfish.wm.ext.tooltips)
46
(defgroup tooltips "Tooltips"
48
:require sawfish.wm.ext.tooltips)
50
(defcustom tooltips-enabled nil
51
"Display tooltips for window frames."
53
:group (misc tooltips)
55
:require sawfish.wm.ext.tooltips)
57
(defcustom tooltips-timeout-enabled nil
58
"Remove tooltips after a period of time."
60
:depends tooltips-enabled
61
:group (misc tooltips))
63
(defcustom tooltips-show-doc-strings t
64
"Show full documentation in tooltips."
66
:depends tooltips-enabled
67
:group (misc tooltips))
69
(defcustom tooltips-delay 500
70
"Number of milliseconds before displaying tooltips."
73
:depends tooltips-enabled
74
:group (misc tooltips))
76
(defcustom tooltips-timeout-delay 5000
77
"Number of milliseconds before removing tooltips."
81
:depends tooltips-enabled
82
:group (misc tooltips))
84
(defcustom tooltips-font "-*-lucidatypewriter-medium-*-*-*-10-*-*-*-*-*-*-*"
85
"Font used to display tooltips."
88
:depends tooltips-enabled
89
:group (misc tooltips))
91
(defcustom tooltips-background-color "grey85"
92
"Color used for the tooltips background"
93
:group (misc tooltips)
95
:depends tooltips-enabled
98
(defcustom tooltips-foreground-color "black"
99
"Color used for the tooltips foreground"
100
:group (misc tooltips)
102
:depends tooltips-enabled
105
;;; displaying tooltips
107
;; the window it's displayed for (or t)
108
(define tooltips-displayed nil)
110
(define (display-tooltip text #!optional win)
111
(let ((pos (query-pointer))
112
(pos-fn (lambda (in size inc)
113
(if (< in (/ size 2))
115
(- (+ (- size in) inc))))))
116
(rplaca pos (pos-fn (car pos) (screen-width) 0))
117
(rplacd pos (pos-fn (cdr pos) (screen-height) 16))
118
(display-message (if (functionp text) (text) text)
120
(background . ,tooltips-background-color)
121
(foreground . ,tooltips-foreground-color)
124
(font . ,tooltips-font)))
125
(setq tooltips-displayed (or win t))
126
(when tooltips-timeout-enabled
128
(make-timer remove-tooltip
129
(quotient tooltips-timeout-delay 1000)
130
(mod tooltips-timeout-delay 1000))))
131
(unless (in-hook-p 'pre-command-hook remove-tooltip)
132
(add-hook 'pre-command-hook remove-tooltip))))
134
(define (remove-tooltip)
135
(when (in-hook-p 'pre-command-hook remove-tooltip)
136
(remove-hook 'pre-command-hook remove-tooltip))
137
(when tooltips-displayed
138
(display-message nil)
139
(setq tooltips-displayed nil))
141
(delete-timer tooltips-timer)
142
(setq tooltips-timer nil)))
144
(define (tooltips-unmapped win)
145
(when (eq win tooltips-displayed)
148
(add-hook 'unmap-notify-hook tooltips-unmapped)
150
(define (call-after-delay thunk)
152
(when tooltips-enabled
153
(setq tooltips-timer (make-timer (lambda ()
154
(setq tooltips-timer nil)
156
(quotient tooltips-delay 1000)
157
(mod tooltips-delay 1000)))
158
(unless (in-hook-p 'pre-command-hook remove-tooltip)
159
(add-hook 'pre-command-hook remove-tooltip))))
161
(define (display-tooltip-after-delay . args)
162
(call-after-delay (lambda ()
163
(apply display-tooltip args))))
165
;;; frame-part tooltips
167
;; each item is (EVENT-DESC . DOC)
168
(define (tooltips-format items)
169
(let ((max-event-width 0)
172
(while (string-match "\n" s point)
173
(setq parts (cons (substring
174
s (or point 0) (match-start)) parts))
175
(setq point (match-end)))
176
(setq parts (cons (substring s (or point 0)) parts))
180
(setq max-event-width (max max-event-width (length (car cell)))))
182
(setq max-event-width (1+ max-event-width))
184
(setq out (cons (car cell) out))
185
(setq out (cons (make-string (- max-event-width
186
(length (car cell))) ? ) out))
187
(let ((parts (split (cdr cell))))
189
(setq out (cons (car parts) out))
190
(setq out (cons ?\n out)))
191
(mapc (lambda (string)
192
(setq out (cons (make-string max-event-width ? ) out))
193
(setq out (cons string out))
194
(setq out (cons ?\n out))) (cdr parts)))) items)
195
(apply concat (nreverse out))))
197
(define (command-info command)
199
(if (and tooltips-show-doc-strings command
201
(setq doc (command-documentation command)))
203
(format nil "%S" command))))
205
(define (display-fp-tooltip fp)
206
(let ((keymap (frame-part-get fp 'keymap))
208
(when (symbolp keymap)
209
(setq keymap (symbol-value keymap)))
210
(map-keymap (lambda (cell)
211
(setq items (cons (cons (event-name (cdr cell))
212
(command-info (car cell))) items)))
214
(display-tooltip (tooltips-format (nreverse items)))))
216
(define (tooltips-fp-enter win fp)
217
(declare (unused win))
218
(when tooltips-enabled
219
(call-after-delay (lambda ()
220
(unless (clicked-frame-part)
221
(display-fp-tooltip fp))))))
223
(add-hook 'enter-frame-part-hook tooltips-fp-enter)
224
(add-hook 'leave-frame-part-hook remove-tooltip))
added
removed
lisp/sawfish/wm/ext/tooltips.jl
