RE: customizing key definitions with Customize

["Drew Adams" <drew.adams@oracle.com>]

[-- Attachment #1: Type: text/plain, Size: 4222 bytes --]

> New keymap-option.el attached - please try it out.
> 
> 1. In the implementation I sent previously, the :set function
> only did `define-key' for the key definitions (after the user
> was done editing them and chose `Set for Session'). That meant
> that no previously existing key bindings were removed or changed,
> even if the user changed a `Key' value or clicked DEL
> to delete the key definition from the option. Only new 
> bindings were made.
> 
> 2. To remedy that, the :set function needs to first remove 
> all existing key bindings, so the only bindings will be those
> the user has kept. I've done that now, in the attached version.
> The :set code now calls `makunbound' and then sets
> the keymap variable to (make-sparse-keymap) before it defines 
> the keys per the user's customizations.

That doesn't really do the trick, unfortunately.

The keymap itself, not just the keymap variable, needs to be reinitialized and
then filled with the new bindings, because the keymap might already have been
used as part of other keymaps.

In the :set function I had, I've thus replaced (makunbound ',map) and (setq ,map
(make-sparse-keymap)) with (when (keymapp ,map) (setcdr ,map nil)). That seems
to fix that problem, but there are other problems, listed below. The updated
code is attached.

1. Non-sparse keymaps, such as `global-map', can end up with some of their keys
undefined after customization.

I cobbled together some code that processes key ranges such as "SPC .. ~", in
particular to handle the multiple bindings of things like `self-insert-command'
in non-sparse keymaps. The attached code raises an error for a non-sparse
keymap, but you can comment out the two lines that raise the error (marked "<===
1"), to try it.

2. However, some maps, such as `global-map', can still end up with some of their
keys undefined. You won't want to try `global-map' with error handling #1 turned
off. If you want to experiment with `global-map', comment out the line marked
"<=== 2".

I'm not sure why some key definitions are not reinstated as they should be.
Perhaps it has to do with the order of processing the key definitions (e.g. wrt
prefix keys).

3. The approach I've used of relying on the output of `substitute-command-keys'
does not work completely for menu maps, because it loses the other information
besides the real binding (e.g. command). For instance, if this is a menu item:

(search-documentation
  menu-item "Search Documentation"
  (keymap
    (emacs-terminology
      menu-item "Emacs Terminology" search-emacs-glossary (nil)
      :help "Display the Glossary section of the Emacs manual")
     ...))
 
Then the :set function changes that to just this:

(search-documentation 
  keymap (emacs-terminology . search-emacs-glossary))

So this is another reason why we should work directly from the keymap, using,
say, `map-keymap', and not try to use the output of `substitute-command-keys'.

To deal with menus generally, we would need to extend the definion of
`key-definition' to accommodate not only the binding (command) but also the
other stuff that menu bindings include. A less satisfying alternative would be
to just forego being able to customize menu keymaps. The attached code just
raises an error if you try to create an option for a menu keymap.

4. There still is an `edmacro-parse-keys' bug that prevents some keys from being
handled correctly. With the attached code, the only such key in the global map
is, I think, "M-<" - see the separate bug report. Someone more knowledgeable
will need to fix `edmacro-parse-keys' the right way.

I won't be going any further with this, but I hope someone will. I spent more
time on it than I wished, but I hope that some of what I explored might help
someone else do things right. I've added some comments in the code, in case it
helps.

There hasn't been much interest expressed, but I think this would be a good
feature if done right. Users can customize the rest of Emacs, besides key
bindings, and bindings can be fairly complex to work with. Besides letting users
customize bindings generally, such a feature can be used by a library to control
(e.g. encourage/discourage) which bindings users customize (with Customize).

HTH.


[-- Attachment #2: keymap-option.el --]
[-- Type: application/octet-stream, Size: 12601 bytes --]

(define-widget 'key-definition 'lazy
  "Key definition.
A list of two components: KEY, BINDING.
KEY is either a key sequence (string or vector) or a command.
If KEY is a command, then the binding represented is its remapping
to BINDING, which must also be a command."
  :tag "Key Definition" :indent 1 :offset 0
  :type
  '(list
    (choice
     (key-sequence :tag "Key" :value [ignore])
     (restricted-sexp :tag "Command to remap"
      :match-alternatives (commandp) :value ignore))
    (sexp :tag "Command")))

(defun custom-create-keymap-option (map)
  "Define a user option for keymap MAP."
  (interactive
   (list (intern (completing-read
                  "Keymap (symbol): " obarray
                  (lambda (s) (and (boundp s) (keymapp (symbol-value s))))
                  nil nil 'variable-name-history))))
  (when (boundp map)
    (when (keymap-prompt (symbol-value map))
      (error "Cannot create option for a menu keymap"))
    (unless (listp (cadr (symbol-value map))) ; <====================== 1
      (error "Cannot create option for a non-sparse keymap"))) ; <===== 1
  (let ((opt-name (intern (concat (symbol-name map) "-defs")))
        (defs ()))
    (if (not (and (symbolp map) (boundp map) (keymapp (symbol-value map))))
        (set map (make-sparse-keymap))  ; New map.

      ;; Print key bindings in a temp buffer, wrap each with `kbd', then read & eval.
      (with-temp-buffer
        (princ (substitute-command-keys
                (concat "\\{" (symbol-name map) "}")) (current-buffer))
        (goto-char (point-min))
        (with-syntax-table emacs-lisp-mode-syntax-table
          (while (re-search-forward
                  "^key +binding\n\\(-+ +\\)-+\n\n" nil t)
            (let ((col (- (match-end 1) (match-beginning 1))))
              (while (and (not (eobp)) (not (looking-at "\n\\s-*\n")))
                (if (or (eolp)          ; Delete these kinds of lines.
                        (looking-at "^\\S-+.+\\s-+Prefix Command$")
                        (looking-at ".+(binding currently shadowed)$")
                        (looking-at "^\\s-+(that binding is currently \
shadowed by another mode)$")
                        (looking-at "^.+\\s-+[?][?]")) ; This is from a `lambda'.
                    (delete-region (line-beginning-position) (1+ (line-end-position)))

                  (end-of-line)
                  (skip-chars-backward "^ \t\n")
                  (looking-at "\\(\\sw\\|\\s_\\)+$") ; Cmd name or last part of key.
                  (if (>= (current-column) col)
                      (let ((sym (intern-soft (match-string 0)))
                            (cmd-beg (match-beginning 0))
                            eokey-pos)
                        (cond ((or (fboundp sym) ; Command or pseudo-command.
                                   (memq sym '(mouse-face ignore-event prev-buffer)))
                               (end-of-line)
                               (insert ")")
                               (goto-char cmd-beg)
                               (skip-chars-backward " \t")
                               (setq eokey-pos (point))
                               (insert "\")") ; +2
                               (forward-line 0)
                               (cond ((looking-at
                                       (concat "^\\(\\S-.*\\) \\.\\. \\(.+\\)\")\\s-+"
                                               (symbol-name sym)))
                                      (let ((key1 (match-string 1))
                                            (key2 (match-string 2)))
                                        (do-key-range sym (key-to-char key1)
                                                      (key-to-char key2))))
                                     (t
                                      (insert "(,(kbd \"") ; +8
                                      (while (< (point) (+ 8 eokey-pos))
                                        (when (looking-at "\\(\"\\|\\\\\\)")
                                          (insert "\\"))
                                        (forward-char))
                                      (goto-char (+ 10 cmd-beg))
                                      (forward-line))))
                              (t        ; Not a command. Last part of key name.
                               ;; E.g., this might be "Portuguese>" in key description
                               ;; <describe> <describe-language-environment>
                               ;; <European> <Brazilian Portuguese>
                               (forward-line)
                               (if (looking-at "^\\s-+\\S-+$")
                                   (custom-create-keymap-option-1 col)
                                 (beginning-of-line)
                                 (delete-region (line-beginning-position)
                                                (1+ (line-end-position)))))))
                    (forward-line)
                    (if (looking-at "^\\s-+\\S-+$")
                        (custom-create-keymap-option-1 col)
                      (forward-line -1)
                      (delete-region (line-beginning-position)
                                     (1+ (line-end-position 2))))))))))
        (goto-char (point-min))
        (while (re-search-forward "^key +binding\n\\(-+ +\\)-+\n\n" nil t)
          (forward-line -3)
          (delete-region (line-beginning-position) (1+ (line-end-position 3))))
        (insert "`(\n") (goto-char (point-max)) (insert ")") ; Wrap all bindings.
        (goto-char (point-min))
        (setq defs (eval (read (current-buffer)))))) ; Create list of key-definitions.

    (eval
     `(defcustom ,opt-name
        ',defs
        ,(format "Customizable keymap for `%s'." map)
        :type '(repeat key-definition)
        :set #'(lambda (sym defns)
                 (custom-set-default sym defns)
                 ;; Wipe out the keymap, so user deletions and replacements will
                 ;; take effect.
                 ;; If you try using `global-map', comment out this line first.
                 (when (keymapp ,map) (setcdr ,map nil)) ; <========= 2
                 (let (key command)
                   (dolist (key-def defns)
                     (setq key      (car key-def)
                           command  (cadr key-def))
                     (if (symbolp key)
                         (define-key ,map (vector 'remap key) command)
                       (define-key ,map key command)))))
        :initialize #'custom-initialize-set))))

(defun custom-create-keymap-option-1 (col)
  (end-of-line)
  (skip-chars-backward "^ \t\n")
  (when (looking-at "\\(\\sw\\|\\s_\\)+$")
    (if (>= (current-column) col)
        (let ((sym (intern-soft (match-string 0))))
          (cond ((or (fboundp sym)
                     (memq sym '(mouse-face ignore-event)))
                 (end-of-line)
                 (insert ")")
                 (forward-line -1)
                 (end-of-line)
                 (insert "\")")         ; +2
                 (forward-line 0)
                 (insert "(,(kbd \"")   ; +8
                 (forward-line 2))
                (t
                 (forward-line 0)
                 (delete-region (line-beginning-position)
                                (1+ (line-end-position 2)))))))))

;; These three functions are used to convert a range of keys such as "SPC .. ~"
;; to a sequence of kbd entries that can be read to create bindings.

(defun do-key-range (symb ch1 ch2)
  "Create kbd entries for the keys (characters) CH1 through CH2."
  (delete-region (line-beginning-position) (1+ (line-end-position)))
  (while (<= ch1 ch2)
    (insert "(,(kbd \"" (char-to-key-string ch1) "\") " (symbol-name symb) ")\n")
    (setq ch1 (1+ ch1))))

(defun char-to-key-string (char)
  "Return string representation of character CHAR."
  (let ((strg (char-to-string char)))
    (cond ((eq char ?\ ) (setq strg "SPC"))
          ((eq char ?\") (setq strg "\\\""))
          ((eq char ?\\) (setq strg "\\\\")))
    strg))

(defun key-to-char (key)
  "Convert key representation to character."
  (let ((ekey (edmacro-parse-keys key)))
    (if (vectorp ekey) (aref ekey 0) (string-to-char ekey))))

;; Tried to fix this so that it would correctly handle key descriptions such as this:
;; "<describe> <describe-language-environment> <European> <Brazilian Portuguese>"
;; But the substituted regexp breaks the correct handling of "M-x <".  Needs work.
(defun edmacro-parse-keys (string &optional need-vector)
  (let ((case-fold-search nil)
	(pos 0)
	(res []))
    (while (and (< pos (length string))
                ;; This is the only change I made. Each of these doesn't work for
                ;; some cases, however - Emacs bug filed.
                ;; ORIGINAL: (string-match "[^ \t\n\f]+" string pos)
		;; DK suggestion: (string-match "[^ \t\n\f<]+\\|<[^>]+>" string pos))
		(string-match "[^ \t\n\f<]+\\|<[^>]+>\\|<+" string pos))
      (let ((word (substring string (match-beginning 0) (match-end 0)))
	    (key nil)
	    (times 1))
	(setq pos (match-end 0))
	(when (string-match "\\([0-9]+\\)\\*." word)
	  (setq times (string-to-number (substring word 0 (match-end 1))))
	  (setq word (substring word (1+ (match-end 1)))))
	(cond ((string-match "^<<.+>>$" word)
	       (setq key (vconcat (if (eq (key-binding [?\M-x])
					  'execute-extended-command)
				      [?\M-x]
				    (or (car (where-is-internal
					      'execute-extended-command))
					[?\M-x]))
				  (substring word 2 -2) "\r")))
	      ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
		    (progn
		      (setq word (concat (substring word (match-beginning 1)
						    (match-end 1))
					 (substring word (match-beginning 3)
						    (match-end 3))))
		      (not (string-match
			    "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
			    word))))
	       (setq key (list (intern word))))
	      ((or (equal word "REM") (string-match "^;;" word))
	       (setq pos (string-match "$" string pos)))
	      (t
	       (let ((orig-word word) (prefix 0) (bits 0))
		 (while (string-match "^[ACHMsS]-." word)
		   (incf bits (cdr (assq (aref word 0)
					 '((?A . ?\A-\^@) (?C . ?\C-\^@)
					   (?H . ?\H-\^@) (?M . ?\M-\^@)
					   (?s . ?\s-\^@) (?S . ?\S-\^@)))))
		   (incf prefix 2)
		   (callf substring word 2))
		 (when (string-match "^\\^.$" word)
		   (incf bits ?\C-\^@)
		   (incf prefix)
		   (callf substring word 1))
		 (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
					    ("LFD" . "\n") ("TAB" . "\t")
					    ("ESC" . "\e") ("SPC" . " ")
					    ("DEL" . "\177")))))
		   (when found (setq word (cdr found))))
		 (when (string-match "^\\\\[0-7]+$" word)
		   (loop for ch across word
                      for n = 0 then (+ (* n 8) ch -48)
                      finally do (setq word (vector n))))
		 (cond ((= bits 0)
			(setq key word))
		       ((and (= bits ?\M-\^@) (stringp word)
			     (string-match "^-?[0-9]+$" word))
			(setq key (loop for x across word collect (+ x bits))))
		       ((/= (length word) 1)
			(error "%s must prefix a single character, not %s"
			       (substring orig-word 0 prefix) word))
		       ((and (/= (logand bits ?\C-\^@) 0) (stringp word)
			     ;; We used to accept . and ? here,
			     ;; but . is simply wrong,
			     ;; and C-? is not used (we use DEL instead).
			     (string-match "[@-_a-z]" word))
			(setq key (list (+ bits (- ?\C-\^@)
					   (logand (aref word 0) 31)))))
		       (t
			(setq key (list (+ bits (aref word 0)))))))))
	(when key
	  (loop repeat times do (callf vconcat res key)))))
    (when (and (>= (length res) 4)
	       (eq (aref res 0) ?\C-x)
	       (eq (aref res 1) ?\()
	       (eq (aref res (- (length res) 2)) ?\C-x)
	       (eq (aref res (- (length res) 1)) ?\)))
      (setq res (edmacro-subseq res 2 -2)))
    (if (and (not need-vector)
	     (loop for ch across res
                always (and (if (fboundp 'characterp)
                                (characterp ch)  ; Emacs 23+
                              (char-valid-p ch)) ; Emacs < 23
                            (let ((ch2 (logand ch (lognot ?\M-\^@))))
                              (and (>= ch2 0) (<= ch2 127))))))
	(concat (loop for ch across res
                   collect (if (= (logand ch ?\M-\^@) 0)
                               ch (+ ch 128))))
      res)))