Re: Customizing key bindings

[Alex Schroeder]

Per Abrahamsen <address@hidden> writes:

> I think you should use the key-binding widget

Done.  I also removed some global-map cruft I still had in the file.

Alex.


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

(require 'wid-edit)

(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-field-validate (widget)
  (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
  :validate 'widget-children-validate
  :notify 'key-sequence-notify)

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

(defun widget-ancestor-get (widget property &optional predicate)
  "Starting from WIDGET, return the value of PROPERTY.
The value of PROPERTY will only be returned if it satisfies PREDICATE.
PREDICATE is a function accepting one parameter, 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 ((and predicate
              (widget-get widget property)
              (funcall predicate (widget-get widget property)))
         (widget-get widget property))
        ((and (not predicate)
              (widget-get widget property)))
        ((widget-get widget :parent)
         (widget-ancestor-get (widget-get widget :parent) property predicate))
        (nil)))

(defun key-sequence-find-map (widget)
  "Find the map that WIDGET is supposed to customize."
  (let ((sym (widget-ancestor-get
              widget :value
              (lambda (sym)
                (and (symbolp sym)
                     (boundp sym)
                     (keymapp (symbol-value sym)))))))
    (if sym
        (symbol-value sym)
      (current-global-map))))

(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 (key-sequence-find-map widget))
        (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 (key-sequence-find-map widget))
         (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")))

(defmacro defkeymap (symbol map doc &rest args)
  "Define SYMBOL to be a keymap with value MAP.
DOC is the keymap documentation."
  ;; It is better not to use backquote in this file,
  ;; because that makes a bootstrapping problem
  ;; if you need to recompile all the Lisp files using interpreted code.
  (nconc (list 'custom-declare-keymap
               (list 'quote symbol)
               (list 'quote map)
               doc)
         args))

(defun custom-declare-keymap (symbol map doc &rest args)
  "Like `defkeymap', but SYMBOL and MAP are evaluated as normal arguments.
MAP should be an expression to evaluate to compute the default value,
not the default value itself.  The DOC string will be expanded with
some standard instructions for customization."
  ;; Keymaps are variables.  The only difference is that we know lots
  ;; of defcustom properties already.
  (setq doc (concat doc
                    "\n
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 the command, you can use M-TAB to complete
it."))
  (apply 'custom-declare-variable symbol map doc 
         :type '(repeat key-binding)
         :set 'custom-set-keymap
         :get 'custom-get-keymap
         args))

(defun custom-set-keymap (sym bindings)
  "Update keymap SYM with BINDINGS.
This also does the necessary book-keeping to save away shadowed bindings
and restoring them if necessary."
  (let ((standard-bindings (eval (car (get sym 'standard-value))))
        (old-bindings (car (get sym 'custom-bindings))))
    ;; When defkeymap is called for the first time, BINDINGS is the
    ;; standard-value.  When customized, BINDINGS is no longer a
    ;; keymap but an alist of bindings.
    (if (equal bindings standard-bindings)
        (set-default sym standard-bindings)
      ;; remove all keys no longer in bindings
      (mapc (lambda (bind)
              (unless (assoc (car bind) bindings)
                (custom-remove-key sym (read-kbd-macro (car bind)))))
            old-bindings)
      ;; define all keys in bindings
      (mapc (lambda (bind)
              (custom-add-key sym (read-kbd-macro (car bind)) (cadr bind)))
            bindings)
      ;; store the current bindings away
      (put sym 'custom-bindings (list bindings)))))

(defun custom-get-keymap (sym)
  "Return the additions to the standard-value of keymap SYM.
These additions are stored in the custom-bindings property by
`custom-set-keymap'."
  (car (get sym 'custom-bindings)))

(defun custom-add-key (sym key def)
  "Add KEY to the keymap stored in SYM with definition DEF.
The shadowed binding is stored, if none has been stored before.  The
shadowed bindings are stored in the custom-bindings-shadow property."
  (let* ((map (symbol-value sym))
         (old-binding (lookup-key map key))
         (shadows (get sym 'custom-bindings-shadow))
         (shadow-binding (cdr (assoc key shadows))))
    (when (and old-binding (not shadow-binding))
      (put sym 'custom-bindings-shadow (cons (cons key old-binding) shadows)))
    (define-key map key def)))

(defun custom-remove-key (sym key)
  "Remove KEY from the keymap stored in SYM.
The shadowed binding is restored, if there is one."
  (let ((def (cdr (assoc key (get sym 'custom-bindings-shadow))))
        (map (symbol-value sym)))
    ;; when DEF is nil, this is a valid binding
    (define-key map key def)))

;; Example:

(defkeymap my-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map (read-kbd-macro "<f11>") 'bbdb)
    map)
  "Keymap to demonstrate `defkeymap'.")

;; my-keymap
;; (keymapp my-keymap)
;; (apropos "my-keymap")
;; (custom-get-keymap 'my-keymap)
;; (put 'my-keymap 'custom-bindings nil)
;; (get 'my-keymap 'standard-value)
;; (customize-option 'my-keymap)
;; (unintern 'my-keymap)

(provide 'cus-key)

;;; cus-key.el ends here