Fix an argument process problem with bind-key

Fixes https://github.com/jwiegley/use-package/issues/334
This commit is contained in:
John Wiegley 2017-12-04 15:21:41 -08:00
parent a2ddc18065
commit 6470eaf3d5
2 changed files with 110 additions and 22 deletions

View file

@ -197,7 +197,7 @@ See `bind-key' for more details."
"Similar to `bind-key', but overrides any mode-specific bindings." "Similar to `bind-key', but overrides any mode-specific bindings."
`(bind-key ,key-name ,command override-global-map ,predicate)) `(bind-key ,key-name ,command override-global-map ,predicate))
(defun bind-keys-form (args) (defun bind-keys-form (args keymap)
"Bind multiple keys at once. "Bind multiple keys at once.
Accepts keyword arguments: Accepts keyword arguments:
@ -217,25 +217,37 @@ function symbol (unquoted)."
(if (and (eq (car args) :package) (if (and (eq (car args) :package)
(not (eq (car (cdr (cdr args))) :map))) (not (eq (car (cdr (cdr args))) :map)))
(setq args (cons :map (cons 'global-map args)))) (setq args (cons :map (cons 'global-map args))))
(let* ((map (plist-get args :map)) (let ((map keymap)
(doc (plist-get args :prefix-docstring)) doc
(prefix-map (plist-get args :prefix-map)) prefix-map
(prefix (plist-get args :prefix)) prefix
(filter (plist-get args :filter)) filter
(menu-name (plist-get args :menu-name)) menu-name
(pkg (plist-get args :package)) pkg)
(key-bindings (progn
(while (keywordp (car args)) ;; Process any initial keyword arguments
(pop args) (let ((cont t))
(pop args)) (while (and cont args)
args))) (if (pcase (car args)
(`:map (setq map (cadr args)))
(`:prefix-docstring (setq doc (cadr args)))
(`:prefix-map (setq prefix-map (cadr args)))
(`:prefix (setq prefix (cadr args)))
(`:filter (setq filter (cadr args)) t)
(`:menu-name (setq menu-name (cadr args)))
(`:package (setq pkg (cadr args))))
(setq args (cddr args))
(setq cont nil))))
(when (or (and prefix-map (not prefix)) (when (or (and prefix-map (not prefix))
(and prefix (not prefix-map))) (and prefix (not prefix-map)))
(error "Both :prefix-map and :prefix must be supplied")) (error "Both :prefix-map and :prefix must be supplied"))
(when (and menu-name (not prefix)) (when (and menu-name (not prefix))
(error "If :menu-name is supplied, :prefix must be too")) (error "If :menu-name is supplied, :prefix must be too"))
(let ((args key-bindings)
saw-map first next) ;; Process key binding arguments
(let (first next)
(while args (while args
(if (keywordp (car args)) (if (keywordp (car args))
(progn (progn
@ -245,6 +257,7 @@ function symbol (unquoted)."
(nconc first (list (car args))) (nconc first (list (car args)))
(setq first (list (car args)))) (setq first (list (car args))))
(setq args (cdr args)))) (setq args (cdr args))))
(cl-flet (cl-flet
((wrap (map bindings) ((wrap (map bindings)
(if (and map pkg (not (eq map 'global-map))) (if (and map pkg (not (eq map 'global-map)))
@ -254,6 +267,7 @@ function symbol (unquoted)."
,(if (symbolp pkg) `',pkg pkg) ,(if (symbolp pkg) `',pkg pkg)
'(progn ,@bindings)))) '(progn ,@bindings))))
bindings))) bindings)))
(append (append
(when prefix-map (when prefix-map
`((defvar ,prefix-map) `((defvar ,prefix-map)
@ -275,10 +289,9 @@ function symbol (unquoted)."
`((bind-key ,(car form) ,fun nil ,filter)))))) `((bind-key ,(car form) ,fun nil ,filter))))))
first)) first))
(when next (when next
(bind-keys-form (bind-keys-form (if pkg
(if pkg
(cons :package (cons pkg next)) (cons :package (cons pkg next))
next)))))))) next) map)))))))
;;;###autoload ;;;###autoload
(defmacro bind-keys (&rest args) (defmacro bind-keys (&rest args)
@ -296,12 +309,12 @@ Accepts keyword arguments:
The rest of the arguments are conses of keybinding string and a The rest of the arguments are conses of keybinding string and a
function symbol (unquoted)." function symbol (unquoted)."
(macroexp-progn (bind-keys-form args))) (macroexp-progn (bind-keys-form args nil)))
;;;###autoload ;;;###autoload
(defmacro bind-keys* (&rest args) (defmacro bind-keys* (&rest args)
(macroexp-progn (macroexp-progn
(bind-keys-form `(:map override-global-map ,@args)))) (bind-keys-form args 'override-global-map)))
(defun get-binding-description (elem) (defun get-binding-description (elem)
(cond (cond

View file

@ -77,7 +77,7 @@
(unless (looking-at "(match-expansion") (unless (looking-at "(match-expansion")
(backward-up-list)) (backward-up-list))
(when (looking-at "(match-expansion") (when (looking-at "(match-expansion")
(search-forward "(use-package") (re-search-forward "(\\(use-package\\|bind-key\\)")
(goto-char (match-beginning 0)) (goto-char (match-beginning 0))
(let ((decl (read (current-buffer)))) (let ((decl (read (current-buffer))))
(kill-sexp) (kill-sexp)
@ -1356,6 +1356,81 @@
(if (fboundp 'delight) (if (fboundp 'delight)
(delight '((foo "bar" foo))))))) (delight '((foo "bar" foo)))))))
(ert-deftest use-package-test/334-1 ()
(let (foo1-map foo2-map
bar1-func1
bar1-func2
bar2-func1
bar2-func2
bar3-func1
bar3-func2
bar4-func1
bar4-func2)
(match-expansion
(bind-keys :map foo1-map
("Y" . foo1)
:prefix "y"
:prefix-map bar1-prefix-map
("y" . bar1-func1)
("f" . bar1-func2)
:prefix "y"
:prefix-map bar2-prefix-map
("y" . bar2-func1)
("f" . bar2-func2)
:map foo2-map
("Y" . foo2)
:prefix "y"
:prefix-map bar3-prefix-map
("y" . bar3-func1)
("f" . bar3-func2)
:prefix "y"
:prefix-map bar4-prefix-map
("y" . bar4-func1)
("f" . bar4-func2))
`(progn
(bind-key "Y" #'foo1 foo1-map nil)
(defvar bar1-prefix-map)
(define-prefix-command 'bar1-prefix-map)
(bind-key "y" 'bar1-prefix-map foo1-map nil)
(bind-key "y" #'bar1-func1 bar1-prefix-map nil)
(bind-key "f" #'bar1-func2 bar1-prefix-map nil)
(defvar bar2-prefix-map)
(define-prefix-command 'bar2-prefix-map)
(bind-key "y" 'bar2-prefix-map foo1-map nil)
(bind-key "y" #'bar2-func1 bar2-prefix-map nil)
(bind-key "f" #'bar2-func2 bar2-prefix-map nil)
(bind-key "Y" #'foo2 foo2-map nil)
(defvar bar3-prefix-map)
(define-prefix-command 'bar3-prefix-map)
(bind-key "y" 'bar3-prefix-map foo2-map nil)
(bind-key "y" #'bar3-func1 bar3-prefix-map nil)
(bind-key "f" #'bar3-func2 bar3-prefix-map nil)
(defvar bar4-prefix-map)
(define-prefix-command 'bar4-prefix-map)
(bind-key "y" 'bar4-prefix-map foo2-map nil)
(bind-key "y" #'bar4-func1 bar4-prefix-map nil)
(bind-key "f" #'bar4-func2 bar4-prefix-map nil)))))
(ert-deftest use-package-test/334-2 ()
(let (w3m-lnum-mode-map
w3m-print-current-url
w3m-lnum-print-this-url
w3m-print-this-url)
(match-expansion
(bind-keys :map w3m-lnum-mode-map
:prefix "y"
:prefix-map w3m-y-prefix-map
("y" . w3m-print-current-url)
("f" . w3m-lnum-print-this-url)
("t" . w3m-print-this-url))
`(progn
(defvar w3m-y-prefix-map)
(define-prefix-command 'w3m-y-prefix-map)
(bind-key "y" 'w3m-y-prefix-map w3m-lnum-mode-map nil)
(bind-key "y" #'w3m-print-current-url w3m-y-prefix-map nil)
(bind-key "f" #'w3m-lnum-print-this-url w3m-y-prefix-map nil)
(bind-key "t" #'w3m-print-this-url w3m-y-prefix-map nil)))))
(ert-deftest use-package-test/506 () (ert-deftest use-package-test/506 ()
(match-expansion (match-expansion
(use-package ess-site (use-package ess-site