Re: Customizing key bindings (was: Re: [CVS] f7, f8 bound..)

[Per Abrahamsen]

Richard Stallman <address@hidden> writes:

> Another alternative method is that display of the key sequence field
> could show its current global binding in parentheses.

I have implemented that in the code below.  Evaluate the code, and
type

        M-x customize-option <ret> global-key-bindings <ret>

to test it.

;;; cus-key.el -- Customize support for changing key bindings.

(require 'wid-edit)

(defvar custom-global-keymap (let ((map (make-sparse-keymap)))
                               (set-keymap-parent map global-map)
                               map)
  "Global keymap for use by Customize.

This is automatically generated from `global-key-bindings', you should 
never change this manually.  Instead, change either `global-map' from Lisp 
or `global-key-bindings' from Customize.")

(defun quoted-key-insert (key)
  "Insert a string representation of the next key typed.
The string representation is a representation understood
by `read-kbd-macro'."
  (interactive "KPress a key: ")
  (insert (edmacro-format-keys key)))

(defvar key-sequence-widget-map 
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map widget-field-keymap)
    (define-key map (kbd "C-q") 'quoted-key-insert)
    map)
    "Keymap for the `key-sequence' widget.")
    
(define-widget 'key-sequence-field 'string
  "Field for entering key bindings."
  :tag "Key sequence"
  :error "Not a well-formed key sequence"
  :validate 'key-sequence-field-validate
  :keymap key-sequence-widget-map)

(defun key-sequence-widget-validate (widget value)
  (let ((value (widget-apply widget :value-get)))
    (condition-case nil
        (progn 
          (read-kbd-macro value)
          nil)
      (error widget))))

(define-widget 'key-sequence-button 'push-button
  "Button for entering key bindings."
  :tag "Key sequence"
  :action 'key-sequence-button-action)

(defun key-sequence-button-action (widget &optional event)
  (let ((key (read-key-sequence "Press key sequence: ")))
    (widget-value-set (widget-get widget :parent)
                      (edmacro-format-keys key))
    (widget-setup)))

(define-widget 'key-sequence 'default
  "Widget for entering key bindings."
  :tag "Read key sequence"
  :match 'key-sequence-match
  :format "%v"
  :value ""
  :value-create 'key-sequence-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-choice-value-get
  :notify 'key-sequence-notify)

(defun key-sequence-match (widget value)
  (stringp value))

(defun widget-ancestor-get (widget property)
  "Starting from WIDGET, return the value of PROPERTY.
If PROPERTY is not specified or nil in WIDGET and the :parent property is 
non-nil, call `widget-ancestor-get' recusively with the value of the :parent
property.  Otherwise, return nil."
  (cond ((widget-get widget property))
        ((widget-get widget :parent)
         (widget-ancestor-get (widget-get widget :parent) property))
        (nil)))

(defun key-sequence-describe (widget command)
  "Create a child to WIDGET that describes COMMAND.
The child widget is returned."
  (cond ((functionp command)
         (widget-create-child-value 
          widget '(function-item) command))
        ((null command)
         (widget-create-child-value
          widget '(item) "Undefined"))
        ((numberp command)
         (widget-create-child-value
          widget '(item) "Binding too long"))
        ((keymapp command)
         (widget-create-child-value
          widget '(item) "Prefix key"))
        (t
         (widget-create-child-value
          widget '(item) "Dude, this is too weird"))))

(defun key-sequence-value-create (widget)
  (let ((value (widget-default-get widget))
        (map (or (widget-ancestor-get widget :keymap)
                 (current-global-map)))
        (button (widget-create-child-and-convert
                 widget '(key-sequence-button)))
        (field (widget-create-child-value
                widget '(key-sequence-field :format " %vOld binding: ")
                (widget-get widget :value))))
    (let* ((command (condition-case nil
                        (lookup-key map (read-kbd-macro value))
                      (error nil)))
           (binding (key-sequence-describe widget command)))
      (widget-put widget :children (list field))
      (widget-put widget :buttons (list binding button)))))

(defun key-sequence-notify (widget child &optional event)
  "Update the old binding, and notify parent."
  (let* ((buttons (widget-get widget :buttons))
         (binding (car buttons))
         (children (widget-get widget :buttons))
         (field (car children))
         (value (widget-value child))
         (map (or (widget-ancestor-get widget :keymap)
                  (current-global-map)))
         (command (condition-case nil
                      (lookup-key map (read-kbd-macro value))
                    (error nil))))
    (save-excursion
      (goto-char (widget-get binding :from))
      (widget-delete binding)
      (setcar buttons (key-sequence-describe widget command))))
  (widget-default-notify widget child event))

(define-widget 'command 'function
  "An interactive Lisp function."
  :complete-function (lambda ()
                       (interactive)
                       (lisp-complete-symbol 'commandp))
  :prompt-match 'commandp
  :match-alternatives '(commandp)
  :validate (lambda (widget)
              (unless (commandp (widget-value widget))
                (widget-put widget :error (format "Invalid function: %S"
                                                  (widget-value widget)))
                widget))
  :value 'ignore
  :tag "Command")

(define-widget 'key-binding 'group
  "Bind a key sequence to a command."
  :value '("" ignore)
  :indent 0
  :args '(key-sequence (command :tag "New binding")))

(defcustom global-key-bindings nil
  "Global keybindings defined through customize.

While entering the name of a key, you can either type keys yourself
just as they appear in the manual, as in C-c a.  You must use angle
brackets for function keys, as in <f7>.  You can also hit C-q and type
the key.  C-q will insert the correct string representation for you.
For longer sequences, you can also invoke the [Key sequence] button, 
and type the entire key sequence directly.

While entering the name of a command, you can use M-TAB to comlete
the function name."
  ;; Note that we cannot use \\[quoted-key-insert] because the keymap
  ;; is not the same.
  :type '(repeat key-binding)
  :set (lambda (sym val)
         (set-default sym val)
         (setq custom-global-keymap (make-sparse-keymap))
         (set-keymap-parent custom-global-keymap global-map)
         (mapc (lambda (bind)
                 (define-key custom-global-keymap (read-kbd-macro (car bind))
                   (cadr bind)))
               val)
         (use-global-map custom-global-keymap)
         val))

(provide 'cus-key)

;;; cus-key.el ends here