From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Per Abrahamsen Newsgroups: gmane.emacs.devel Subject: Keymap customization Date: Mon, 23 Sep 2002 12:23:37 +0200 Organization: The Church of Emacs Sender: emacs-devel-admin@gnu.org Message-ID: NNTP-Posting-Host: localhost.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: main.gmane.org 1032776746 20767 127.0.0.1 (23 Sep 2002 10:25:46 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Mon, 23 Sep 2002 10:25:46 +0000 (UTC) Return-path: Original-Received: from quimby.gnus.org ([80.91.224.244]) by main.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 17tQPQ-0005Oj-00 for ; Mon, 23 Sep 2002 12:25:44 +0200 Original-Received: from monty-python.gnu.org ([199.232.76.173]) by quimby.gnus.org with esmtp (Exim 3.12 #1 (Debian)) id 17tR5d-0004AF-00 for ; Mon, 23 Sep 2002 13:09:22 +0200 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.10) id 17tQPB-0007bt-00; Mon, 23 Sep 2002 06:25:29 -0400 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.10) id 17tQNU-0007Kk-00 for emacs-devel@gnu.org; Mon, 23 Sep 2002 06:23:44 -0400 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.10) id 17tQNS-0007KE-00 for emacs-devel@gnu.org; Mon, 23 Sep 2002 06:23:43 -0400 Original-Received: from sheridan.dina.kvl.dk ([130.225.40.227]) by monty-python.gnu.org with esmtp (Exim 4.10) id 17tQNR-0007Jw-00 for emacs-devel@gnu.org; Mon, 23 Sep 2002 06:23:41 -0400 Original-Received: from zuse.dina.kvl.dk (zuse.dina.kvl.dk [130.225.40.245]) by sheridan.dina.kvl.dk (8.9.3/8.9.3/Debian 8.9.3-21) with ESMTP id MAA03955 for ; Mon, 23 Sep 2002 12:23:39 +0200 Original-Received: (from abraham@localhost) by zuse.dina.kvl.dk (8.9.3+Sun/8.9.3) id MAA14362; Mon, 23 Sep 2002 12:23:38 +0200 (MEST) X-Authentication-Warning: zuse.dina.kvl.dk: abraham set sender to abraham@dina.kvl.dk using -f Original-To: emacs-devel@gnu.org X-Face: +kRV2]2q}lixHkE{U)mY#+6]{AH=yN~S9@IFiOa@X6?GM|8MBp/ Original-Lines: 28 User-Agent: Gnus/5.090007 (Oort Gnus v0.07) Emacs/21.1 (sparc-sun-solaris2.8) Errors-To: emacs-devel-admin@gnu.org X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.0.11 Precedence: bulk List-Help: List-Post: List-Subscribe: , List-Id: Emacs development discussions. List-Unsubscribe: , List-Archive: Xref: main.gmane.org gmane.emacs.devel:8116 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:8116 --=-=-= Hi RMS and gang, What is needed for the keymap customization support to be included in Emacs? Here are the open issues: 1. The defkeymap should generate a defvar. 2. The generation of new prefix keys is not supported. 3. We really should use a two-keymap solution in define-key. Fixing #3 would also fix #2. I am willing to solve #1 if that mean I can commit the code to the Emacs CVS. I'll also think about #2 then. I believe #3 is the right thing, I'm not willing to do that work, but I'll help anyone who volunteers. But I don't think the current suboptimal solution should be rejected if nobody volunteer to do #3. The latest version is attached. -- Per --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=cus-key.el Content-Description: Emacs Keymap customization support ;;; cus-key.el -- Customize support for changing key bindings. ;; $Id: abraham $ (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)) (map1 (or (widget-ancestor-get widget :key-sequence-keymap) (current-global-map))) (map (if (symbolp map1) (symbol-value map1) map1)) (key (condition-case nil (read-kbd-macro value) nil)) (command (and key (lookup-key map key))))) (cond ((null key) ;; Unparsable. widget) ((string-equal key "") ;; Empty prefix. We can't rebind the entire keymap. widget) ((functionp command) ;; Normal binding, OK. nil) ((null command) ;; Unbound, OK. nil) ((numberp command) ;; We can't allow the creation of new prefix keys, as we have ;; no way to undo such a prefix widget) ((keymapp command) ;; This will turn a prefix key into an ordinary binding. A ;; bit drastic (as many bindings can be lost), but the user ;; asked for it. nil) (t ;; This is an impossible value according to the lookup-key doc ;; string. What to do? Let the user deside. nil))) (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) "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 :key-sequence-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)))) (when (symbolp map) (setq map (symbol-value map))) (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)) (map1 (or (widget-ancestor-get widget :key-sequence-keymap) (current-global-map))) (map (if (symbolp map1) (symbol-value map1) map1)) (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-value 'choice "A valid key binding value for use by `define-key'. This could be a command or nil." :args '((const :tag "Remove definition" nil) ) :value 'ignore :tag "New binding") (define-widget 'key-binding 'group "Bind a key sequence to a command." :value '("" ignore) :indent 0 :args '(key-sequence key-binding-value)) (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 . 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-sequence-keymap ,symbol 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. In this case, OLD-BINDINGS is ;; what the user customized the last time, BINDINGS is what the ;; user wants this time. (if (equal bindings standard-bindings) (set-default sym standard-bindings) (mapc (lambda (bind) (unless (assoc (car bind) bindings) (custom-remove-key sym (read-kbd-macro (car bind))))) old-bindings) (mapc (lambda (bind) (custom-add-key sym (read-kbd-macro (car bind)) (cadr bind))) bindings) (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 (assoc key shadows))) (when (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: ;; (eval-buffer) ;; (setq test emacs-lisp-mode-map) ;; (defkeymap emacs-lisp-mode-map test "Elisp mode map for testing.") ;; (customize-option 'emacs-lisp-mode-map) ;; (apropos "emacs-lisp-mode-map") (provide 'cus-key) ;;; cus-key.el ends here --=-=-=--