1 ;;; new-key-seq-widget.el --- New key-sequence widget for Emacs
3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
4 ;; Created: Tue Dec 25 23:00:43 2007
11 ;; Features that might be required by this library:
15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 ;; New version of Kim's Emacs key-sequence widget. For inclusion in
22 ;; Fix-me: check what was included.
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;; I do not know how much I have changed, but I keep it together here
31 ;; Note: I have named made `widget-key-sequence-map' a constant for
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;; This program is free software; you can redistribute it and/or
37 ;; modify it under the terms of the GNU General Public License as
38 ;; published by the Free Software Foundation; either version 2, or
39 ;; (at your option) any later version.
41 ;; This program is distributed in the hope that it will be useful,
42 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
43 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
44 ;; General Public License for more details.
46 ;; You should have received a copy of the GNU General Public License
47 ;; along with this program; see the file COPYING. If not, write to
48 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
49 ;; Floor, Boston, MA 02110-1301, USA.
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 ;;; I'm not sure about what this is good for? KFS.
60 ;;; This should probably be for customize-set-value etc, but it is not
61 ;;; used. Or for the widget editing, but it is not used there
63 (defvar widget-key-sequence-prompt-value-history nil
64 "History of input to `widget-key-sequence-prompt-value'.")
66 (defvar widget-key-sequence-default-value [ignore]
67 "Default value for an empty key sequence.")
69 (defconst widget-key-sequence-map
70 (let ((map (make-sparse-keymap)))
71 (set-keymap-parent map widget-field-keymap)
72 (define-key map [(control ?q)] 'widget-key-sequence-read-event)
73 (define-key map [(control ?t)] 'widget-key-sequence-toggle-input-format)
76 (defvar widget-key-sequence-input-formats '(key-description vector))
78 (defcustom widget-key-sequence-default-input-format 'key-description
79 "Format used to edit key sequences.
80 This is the format shown and edited in a key-sequence widget."
81 :type '(choice (const :tag "Key description" 'key-description)
82 (const :tag "Vector" 'vector))
85 (define-widget 'key-sequence 'restricted-sexp
87 :prompt-value 'widget-field-prompt-value
88 :prompt-internal 'widget-symbol-prompt-internal
89 ; :prompt-match 'fboundp ;; What was this good for? KFS
90 :prompt-history 'widget-key-sequence-prompt-value-history
91 :action 'widget-field-action
92 :match-alternatives '(stringp vectorp)
94 :validate 'widget-key-sequence-validate
95 :value-to-internal 'widget-key-sequence-value-to-internal
96 :value-to-external 'widget-key-sequence-value-to-external
97 :value widget-key-sequence-default-value
98 :keymap widget-key-sequence-map
99 :help-echo "C-q: insert KEY, EVENT, or CODE; C-t: toggle format"
103 ;;; Leave these here for testing:
104 ;; (edmacro-parse-keys "C-x h" t) => [24 104]
105 ;; (key-description-to-vector "C-x h" ) => [(control 120) 104]
106 ;; (key-description (key-description-to-vector "C-x h")) => "C-x h"
107 ;; (key-description (edmacro-parse-keys "C-x h")) => "C-x h"
108 ;; (key-description [M-mouse-1]) => <M-mouse-1>
109 ;; (edmacro-parse-keys "<M-mouse-1>") => [M-mouse-1]
111 ;; (event-modifiers 'mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
112 ;; (event-modifiers 'M-mouse-1) =>
113 ;; (event-modifiers '(mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
114 ;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
115 ;; (event-modifiers '(S-down-mouse-1)) => (shift down)
116 ;; (event-modifiers 'S-down-mouse-1) => (shift down)
117 ;; (event-modifiers 'down-mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
118 ;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
119 ;; (let ((m (make-sparse-keymap))) (define-key m [(down mouse-1)] 'hej))
120 (defun key-description-to-vector (kd)
121 "Convert human readable key description KD to vector format.
122 KD should be in the format returned by `key-description'."
126 ;; Fix-me: temporarily clean the event here:
128 (let ((esem (get k 'event-symbol-element-mask))) (when esem (lwarn t :warning "kd=%s, k=%s, esem=%s" kd k esem)))
129 (put k 'event-symbol-element-mask nil))
130 (let ((m (event-modifiers k))
131 (b (event-basic-type k)))
132 (setq m (delq 'click m))
136 ;; fix-me: does not always work for menu and tool
137 ;; bar event because they may contains spaces.
138 (edmacro-parse-keys kd t))))
139 (m (make-sparse-keymap))
141 ;; Test before returning it:
142 (define-key m v 'test)
145 (defun widget-key-sequence-current-input-format ()
146 (let ((fmt (or (widget-get (widget-at (point)) :key-sequence-format)
147 widget-key-sequence-default-input-format)))
150 (defun widget-key-sequence-toggle-input-format ()
151 "Toggle key sequence input format."
153 (let* ((widget (widget-at (point)))
154 (value (widget-apply widget :value-get))
155 (first (string-to-char value))
157 (let ((fmt (or (widget-get widget :key-sequence-format)
158 widget-key-sequence-default-input-format)))
161 (let ((m (cdr (memq old-fmt widget-key-sequence-input-formats))))
162 (if m (car m) (car widget-key-sequence-input-formats))))
165 ((eq new-fmt 'key-description)
166 (setq value (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" value))
167 (if (string= value "")
169 (key-description (read value))))
170 ((eq new-fmt 'vector)
171 (format "%S" (key-description-to-vector value)))
173 (error "Bad key seq format spec: %s" new-fmt))))
174 (state (widget-get (widget-get widget :parent) :custom-state))
176 (widget-put widget :key-sequence-format new-fmt)
177 (setq new-value (propertize new-value 'face 'highlight))
178 (widget-apply widget :value-set new-value)
180 (widget-put (widget-get widget :parent) :custom-state state)
182 ((eq new-fmt 'key-description)
183 (message "Switched to human readable format"))
184 ((eq new-fmt 'vector)
185 (message "Switched to vector format"))
187 (error "Uh? format=%s" new-fmt)))))
190 (defun widget-key-sequence-read-event (ev)
191 "Read event or char code and put description in widget.
192 The events may come from keyboard, mouse, menu or tool bar.
194 If the event is a mouse event then multiple entries will be
195 entered. It is not possible to know which one is wanted. Please
196 remove those not wanted!
198 If 0-7 is pressed then code for an event is prompted for."
200 (let ((inhibit-quit t) quit-flag)
201 (unless (eq 'key-description
202 (widget-key-sequence-current-input-format))
203 (error "Wrong input format, please do C-t first"))
204 (read-event "Insert KEY, EVENT, or CODE: "))))
205 (lwarn t :warning "=====> ev=%s" ev)
206 (let ((tr (and (keymapp function-key-map)
207 (lookup-key function-key-map (vector ev)))))
208 (insert (if (= (char-before) ?\s) "" " "))
209 ;; Fix-me: change to check for ? instead of 0-7 to allow char
210 ;; literal input format
211 (when (and (integerp ev)
212 (or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix))))
213 (and (<= ?a (downcase ev))
214 (< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix))))))
215 (setq unread-command-events (cons ev unread-command-events)
216 ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix))
218 (if (and (integerp ev) (not (characterp ev)))
219 (insert (char-to-string ev)))) ;; throw invalid char error
220 (setq ev (key-description (list ev)))
222 (setq tr (key-description (list (aref tr 0))))
223 (when (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr))
228 (when (or (string-match "mouse-" ev)
229 (string-match "menu-bar" ev)
230 (string-match "tool-bar" ev))
231 (let ((ev2 (read-event nil nil (* 0.001 double-click-time))))
233 (lwarn t :warning "(stringp ev2)=%s, (sequencp ev2)=%s, (symbolp ev2)=%s, ev2=%S" (stringp ev2) (sequencep ev2) (symbolp ev2) ev2)
234 (if nil ;(memq 32 (append (symbol-name ev2) nil)) ;; Fix-me: contains space
235 (insert ?\" (symbol-name ev2) ?\")
236 (insert (key-description (list ev2))))
238 (setq ev2 (read-event nil nil (* 0.001 double-click-time))))))))
240 (defun widget-key-sequence-validate (widget)
241 "Validate the internal value of the widget.
242 Actually there is nothing to validate here. The internal value
243 is always valid, but it is however maybe not what the user
244 expects. Because of this the internal format is rewritten when
245 the user gives the value in a way that is not the normal
246 representation of it. A warning is also shown then."
248 (let* ((int-val (widget-apply widget :value-get))
249 (def-desc (key-description (edmacro-parse-keys int-val)))
250 (fmt (or (widget-get widget :key-sequence-format)
251 widget-key-sequence-default-input-format)))
252 ;; Normalize and compare with default description
254 (replace-regexp-in-string " *" " " int-val t))
256 (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" int-val t))
259 (string= int-val def-desc))
260 ;; Replace with the default description if it is different
261 ;; so the user sees what the value actually means:
262 (widget-apply widget :value-set def-desc)
264 (concat "Key description %s means the same as %s\n"
265 "\tTip: You can type C-q to insert a key or event")
268 ;; Return nil if there a no problem validating
270 (error (widget-put widget :error (error-message-string err))
271 (lwarn t :warning "invalid %S: %s" widget (error-message-string err))
272 ;; Return widget if there was an error
275 (defun widget-key-sequence-value-to-internal (widget value)
276 (if (widget-apply widget :match value)
277 (if (equal value widget-key-sequence-default-value)
279 (let ((fmt (or (widget-get widget :key-sequence-format)
280 widget-key-sequence-default-input-format)))
283 (key-description value))))
286 (defun widget-key-sequence-value-to-external (widget value)
288 (if (string-match "\\`[[:space:]]*\\'" value)
289 widget-key-sequence-default-value
290 ;; Give a better error message and a trace back on debug:
292 (let* ((fmt (or (widget-get widget :key-sequence-format)
293 widget-key-sequence-default-input-format))
294 (first (string-to-char value)))
300 (key-description-to-vector value))))
301 (error (error "Bad value: %s" (error-message-string err)))))
304 ;; (customize-option 'new-key-seq-widget-test)
305 (defcustom new-key-seq-widget-test []
310 (provide 'new-key-seq-widget)
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
312 ;;; new-key-seq-widget.el ends here