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

[Per Abrahamsen <abraham@dina.kvl.dk>]

Richard Stallman <rms@gnu.org> 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