313 lines
13 KiB
EmacsLisp
313 lines
13 KiB
EmacsLisp
|
;;; new-key-seq-widget.el --- New key-sequence widget for Emacs
|
||
|
|
;;
|
||
|
|
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
|
||
|
|
;; Created: Tue Dec 25 23:00:43 2007
|
||
|
|
;; Version:
|
||
|
|
;; Last-Updated:
|
||
|
|
;; URL:
|
||
|
|
;; Keywords:
|
||
|
|
;; Compatibility:
|
||
|
|
;;
|
||
|
|
;; Features that might be required by this library:
|
||
|
|
;;
|
||
|
|
;; None
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Commentary:
|
||
|
|
;;
|
||
|
|
;; New version of Kim's Emacs key-sequence widget. For inclusion in
|
||
|
|
;; Emacs I hope.
|
||
|
|
;;
|
||
|
|
;; Fix-me: check what was included.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Change log:
|
||
|
|
;;
|
||
|
|
;; I do not know how much I have changed, but I keep it together here
|
||
|
|
;; for simplicity.
|
||
|
|
;;
|
||
|
|
;; Note: I have named made `widget-key-sequence-map' a constant for
|
||
|
|
;; the moment.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;; This program is free software; you can redistribute it and/or
|
||
|
|
;; modify it under the terms of the GNU General Public License as
|
||
|
|
;; published by the Free Software Foundation; either version 2, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program is distributed in the hope that it will be useful,
|
||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
|
|
;; General Public License for more details.
|
||
|
|
;;
|
||
|
|
;; You should have received a copy of the GNU General Public License
|
||
|
|
;; along with this program; see the file COPYING. If not, write to
|
||
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
|
||
|
|
;; Floor, Boston, MA 02110-1301, USA.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(require 'wid-edit)
|
||
|
|
(require 'edmacro)
|
||
|
|
|
||
|
|
;;; I'm not sure about what this is good for? KFS.
|
||
|
|
;;
|
||
|
|
;;; This should probably be for customize-set-value etc, but it is not
|
||
|
|
;;; used. Or for the widget editing, but it is not used there
|
||
|
|
;;; either. /Lennart
|
||
|
|
(defvar widget-key-sequence-prompt-value-history nil
|
||
|
|
"History of input to `widget-key-sequence-prompt-value'.")
|
||
|
|
|
||
|
|
(defvar widget-key-sequence-default-value [ignore]
|
||
|
|
"Default value for an empty key sequence.")
|
||
|
|
|
||
|
|
(defconst widget-key-sequence-map
|
||
|
|
(let ((map (make-sparse-keymap)))
|
||
|
|
(set-keymap-parent map widget-field-keymap)
|
||
|
|
(define-key map [(control ?q)] 'widget-key-sequence-read-event)
|
||
|
|
(define-key map [(control ?t)] 'widget-key-sequence-toggle-input-format)
|
||
|
|
map))
|
||
|
|
|
||
|
|
(defvar widget-key-sequence-input-formats '(key-description vector))
|
||
|
|
|
||
|
|
(defcustom widget-key-sequence-default-input-format 'key-description
|
||
|
|
"Format used to edit key sequences.
|
||
|
|
This is the format shown and edited in a key-sequence widget."
|
||
|
|
:type '(choice (const :tag "Key description" 'key-description)
|
||
|
|
(const :tag "Vector" 'vector))
|
||
|
|
:group 'widgets)
|
||
|
|
|
||
|
|
(define-widget 'key-sequence 'restricted-sexp
|
||
|
|
"A key sequence."
|
||
|
|
:prompt-value 'widget-field-prompt-value
|
||
|
|
:prompt-internal 'widget-symbol-prompt-internal
|
||
|
|
; :prompt-match 'fboundp ;; What was this good for? KFS
|
||
|
|
:prompt-history 'widget-key-sequence-prompt-value-history
|
||
|
|
:action 'widget-field-action
|
||
|
|
:match-alternatives '(stringp vectorp)
|
||
|
|
:format "%{%t%}: %v"
|
||
|
|
:validate 'widget-key-sequence-validate
|
||
|
|
:value-to-internal 'widget-key-sequence-value-to-internal
|
||
|
|
:value-to-external 'widget-key-sequence-value-to-external
|
||
|
|
:value widget-key-sequence-default-value
|
||
|
|
:keymap widget-key-sequence-map
|
||
|
|
:help-echo "C-q: insert KEY, EVENT, or CODE; C-t: toggle format"
|
||
|
|
:tag "Key sequence")
|
||
|
|
|
||
|
|
|
||
|
|
;;; Leave these here for testing:
|
||
|
|
;; (edmacro-parse-keys "C-x h" t) => [24 104]
|
||
|
|
;; (key-description-to-vector "C-x h" ) => [(control 120) 104]
|
||
|
|
;; (key-description (key-description-to-vector "C-x h")) => "C-x h"
|
||
|
|
;; (key-description (edmacro-parse-keys "C-x h")) => "C-x h"
|
||
|
|
;; (key-description [M-mouse-1]) => <M-mouse-1>
|
||
|
|
;; (edmacro-parse-keys "<M-mouse-1>") => [M-mouse-1]
|
||
|
|
|
||
|
|
;; (event-modifiers 'mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
|
||
|
|
;; (event-modifiers 'M-mouse-1) =>
|
||
|
|
;; (event-modifiers '(mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
|
||
|
|
;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
|
||
|
|
;; (event-modifiers '(S-down-mouse-1)) => (shift down)
|
||
|
|
;; (event-modifiers 'S-down-mouse-1) => (shift down)
|
||
|
|
;; (event-modifiers 'down-mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
|
||
|
|
;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1)
|
||
|
|
;; (let ((m (make-sparse-keymap))) (define-key m [(down mouse-1)] 'hej))
|
||
|
|
(defun key-description-to-vector (kd)
|
||
|
|
"Convert human readable key description KD to vector format.
|
||
|
|
KD should be in the format returned by `key-description'."
|
||
|
|
(let ((v
|
||
|
|
(vconcat
|
||
|
|
(mapcar (lambda (k)
|
||
|
|
;; Fix-me: temporarily clean the event here:
|
||
|
|
(when (symbolp k)
|
||
|
|
(let ((esem (get k 'event-symbol-element-mask))) (when esem (lwarn t :warning "kd=%s, k=%s, esem=%s" kd k esem)))
|
||
|
|
(put k 'event-symbol-element-mask nil))
|
||
|
|
(let ((m (event-modifiers k))
|
||
|
|
(b (event-basic-type k)))
|
||
|
|
(setq m (delq 'click m))
|
||
|
|
(if m
|
||
|
|
(nconc m (list b))
|
||
|
|
b)))
|
||
|
|
;; fix-me: does not always work for menu and tool
|
||
|
|
;; bar event because they may contains spaces.
|
||
|
|
(edmacro-parse-keys kd t))))
|
||
|
|
(m (make-sparse-keymap))
|
||
|
|
)
|
||
|
|
;; Test before returning it:
|
||
|
|
(define-key m v 'test)
|
||
|
|
v))
|
||
|
|
|
||
|
|
(defun widget-key-sequence-current-input-format ()
|
||
|
|
(let ((fmt (or (widget-get (widget-at (point)) :key-sequence-format)
|
||
|
|
widget-key-sequence-default-input-format)))
|
||
|
|
fmt))
|
||
|
|
|
||
|
|
(defun widget-key-sequence-toggle-input-format ()
|
||
|
|
"Toggle key sequence input format."
|
||
|
|
(interactive)
|
||
|
|
(let* ((widget (widget-at (point)))
|
||
|
|
(value (widget-apply widget :value-get))
|
||
|
|
(first (string-to-char value))
|
||
|
|
(old-fmt
|
||
|
|
(let ((fmt (or (widget-get widget :key-sequence-format)
|
||
|
|
widget-key-sequence-default-input-format)))
|
||
|
|
fmt))
|
||
|
|
(new-fmt
|
||
|
|
(let ((m (cdr (memq old-fmt widget-key-sequence-input-formats))))
|
||
|
|
(if m (car m) (car widget-key-sequence-input-formats))))
|
||
|
|
(new-value
|
||
|
|
(cond
|
||
|
|
((eq new-fmt 'key-description)
|
||
|
|
(setq value (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" value))
|
||
|
|
(if (string= value "")
|
||
|
|
""
|
||
|
|
(key-description (read value))))
|
||
|
|
((eq new-fmt 'vector)
|
||
|
|
(format "%S" (key-description-to-vector value)))
|
||
|
|
(t
|
||
|
|
(error "Bad key seq format spec: %s" new-fmt))))
|
||
|
|
(state (widget-get (widget-get widget :parent) :custom-state))
|
||
|
|
)
|
||
|
|
(widget-put widget :key-sequence-format new-fmt)
|
||
|
|
(setq new-value (propertize new-value 'face 'highlight))
|
||
|
|
(widget-apply widget :value-set new-value)
|
||
|
|
(widget-setup)
|
||
|
|
(widget-put (widget-get widget :parent) :custom-state state)
|
||
|
|
(cond
|
||
|
|
((eq new-fmt 'key-description)
|
||
|
|
(message "Switched to human readable format"))
|
||
|
|
((eq new-fmt 'vector)
|
||
|
|
(message "Switched to vector format"))
|
||
|
|
(t
|
||
|
|
(error "Uh? format=%s" new-fmt)))))
|
||
|
|
|
||
|
|
|
||
|
|
(defun widget-key-sequence-read-event (ev)
|
||
|
|
"Read event or char code and put description in widget.
|
||
|
|
The events may come from keyboard, mouse, menu or tool bar.
|
||
|
|
|
||
|
|
If the event is a mouse event then multiple entries will be
|
||
|
|
entered. It is not possible to know which one is wanted. Please
|
||
|
|
remove those not wanted!
|
||
|
|
|
||
|
|
If 0-7 is pressed then code for an event is prompted for."
|
||
|
|
(interactive (list
|
||
|
|
(let ((inhibit-quit t) quit-flag)
|
||
|
|
(unless (eq 'key-description
|
||
|
|
(widget-key-sequence-current-input-format))
|
||
|
|
(error "Wrong input format, please do C-t first"))
|
||
|
|
(read-event "Insert KEY, EVENT, or CODE: "))))
|
||
|
|
(lwarn t :warning "=====> ev=%s" ev)
|
||
|
|
(let ((tr (and (keymapp function-key-map)
|
||
|
|
(lookup-key function-key-map (vector ev)))))
|
||
|
|
(insert (if (= (char-before) ?\s) "" " "))
|
||
|
|
;; Fix-me: change to check for ? instead of 0-7 to allow char
|
||
|
|
;; literal input format
|
||
|
|
(when (and (integerp ev)
|
||
|
|
(or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix))))
|
||
|
|
(and (<= ?a (downcase ev))
|
||
|
|
(< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix))))))
|
||
|
|
(setq unread-command-events (cons ev unread-command-events)
|
||
|
|
ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix))
|
||
|
|
tr nil)
|
||
|
|
(if (and (integerp ev) (not (characterp ev)))
|
||
|
|
(insert (char-to-string ev)))) ;; throw invalid char error
|
||
|
|
(setq ev (key-description (list ev)))
|
||
|
|
(when (arrayp tr)
|
||
|
|
(setq tr (key-description (list (aref tr 0))))
|
||
|
|
(when (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr))
|
||
|
|
(setq ev tr)
|
||
|
|
;;(setq ev2 nil)
|
||
|
|
))
|
||
|
|
(insert ev " ")
|
||
|
|
(when (or (string-match "mouse-" ev)
|
||
|
|
(string-match "menu-bar" ev)
|
||
|
|
(string-match "tool-bar" ev))
|
||
|
|
(let ((ev2 (read-event nil nil (* 0.001 double-click-time))))
|
||
|
|
(while ev2
|
||
|
|
(lwarn t :warning "(stringp ev2)=%s, (sequencp ev2)=%s, (symbolp ev2)=%s, ev2=%S" (stringp ev2) (sequencep ev2) (symbolp ev2) ev2)
|
||
|
|
(if nil ;(memq 32 (append (symbol-name ev2) nil)) ;; Fix-me: contains space
|
||
|
|
(insert ?\" (symbol-name ev2) ?\")
|
||
|
|
(insert (key-description (list ev2))))
|
||
|
|
(insert " ")
|
||
|
|
(setq ev2 (read-event nil nil (* 0.001 double-click-time))))))))
|
||
|
|
|
||
|
|
(defun widget-key-sequence-validate (widget)
|
||
|
|
"Validate the internal value of the widget.
|
||
|
|
Actually there is nothing to validate here. The internal value
|
||
|
|
is always valid, but it is however maybe not what the user
|
||
|
|
expects. Because of this the internal format is rewritten when
|
||
|
|
the user gives the value in a way that is not the normal
|
||
|
|
representation of it. A warning is also shown then."
|
||
|
|
(condition-case err
|
||
|
|
(let* ((int-val (widget-apply widget :value-get))
|
||
|
|
(def-desc (key-description (edmacro-parse-keys int-val)))
|
||
|
|
(fmt (or (widget-get widget :key-sequence-format)
|
||
|
|
widget-key-sequence-default-input-format)))
|
||
|
|
;; Normalize and compare with default description
|
||
|
|
(setq int-val
|
||
|
|
(replace-regexp-in-string " *" " " int-val t))
|
||
|
|
(setq int-val
|
||
|
|
(replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" int-val t))
|
||
|
|
(unless (or
|
||
|
|
(eq fmt 'vector)
|
||
|
|
(string= int-val def-desc))
|
||
|
|
;; Replace with the default description if it is different
|
||
|
|
;; so the user sees what the value actually means:
|
||
|
|
(widget-apply widget :value-set def-desc)
|
||
|
|
(lwarn t :warning
|
||
|
|
(concat "Key description %s means the same as %s\n"
|
||
|
|
"\tTip: You can type C-q to insert a key or event")
|
||
|
|
int-val def-desc)
|
||
|
|
)
|
||
|
|
;; Return nil if there a no problem validating
|
||
|
|
nil)
|
||
|
|
(error (widget-put widget :error (error-message-string err))
|
||
|
|
(lwarn t :warning "invalid %S: %s" widget (error-message-string err))
|
||
|
|
;; Return widget if there was an error
|
||
|
|
widget)))
|
||
|
|
|
||
|
|
(defun widget-key-sequence-value-to-internal (widget value)
|
||
|
|
(if (widget-apply widget :match value)
|
||
|
|
(if (equal value widget-key-sequence-default-value)
|
||
|
|
""
|
||
|
|
(let ((fmt (or (widget-get widget :key-sequence-format)
|
||
|
|
widget-key-sequence-default-input-format)))
|
||
|
|
(if (eq fmt 'vector)
|
||
|
|
(format "%S" value)
|
||
|
|
(key-description value))))
|
||
|
|
value))
|
||
|
|
|
||
|
|
(defun widget-key-sequence-value-to-external (widget value)
|
||
|
|
(if (stringp value)
|
||
|
|
(if (string-match "\\`[[:space:]]*\\'" value)
|
||
|
|
widget-key-sequence-default-value
|
||
|
|
;; Give a better error message and a trace back on debug:
|
||
|
|
(condition-case err
|
||
|
|
(let* ((fmt (or (widget-get widget :key-sequence-format)
|
||
|
|
widget-key-sequence-default-input-format))
|
||
|
|
(first (string-to-char value)))
|
||
|
|
(cond
|
||
|
|
((eq fmt 'vector)
|
||
|
|
(read value)
|
||
|
|
)
|
||
|
|
(t
|
||
|
|
(key-description-to-vector value))))
|
||
|
|
(error (error "Bad value: %s" (error-message-string err)))))
|
||
|
|
value))
|
||
|
|
|
||
|
|
;; (customize-option 'new-key-seq-widget-test)
|
||
|
|
(defcustom new-key-seq-widget-test []
|
||
|
|
"Testing only!"
|
||
|
|
:type 'key-sequence
|
||
|
|
:group 'widgets)
|
||
|
|
|
||
|
|
(provide 'new-key-seq-widget)
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; new-key-seq-widget.el ends here
|