branch: externals/keymap-popup
commit 3062d11a9cc9caed50ca4aa15b8cf1673ab15a08
Author: Thanos Apollo <[email protected]>
Commit: Thanos Apollo <[email protected]>
popup: Tighten session lifecycle
---
docs/keymap-popup.org | 14 +++--
keymap-popup.el | 147 +++++++++++++++++++++++++++++---------------
tests/keymap-popup-tests.el | 133 ++++++++++++++++++++++++++++++++++++++-
3 files changed, 237 insertions(+), 57 deletions(-)
diff --git a/docs/keymap-popup.org b/docs/keymap-popup.org
index e585988ceb5..03eb00ce8af 100644
--- a/docs/keymap-popup.org
+++ b/docs/keymap-popup.org
@@ -113,6 +113,7 @@ KEY (DESC :keymap MAP [PROP VALUE...]) ; sub-menu
- =COMMAND= -- command symbol or a =(lambda () (interactive) ...)=.
- =PROP= -- one of =:if=, =:inapt-if=, =:stay-open=, =:c-u= (see
[[#special-bindings][Special bindings]]).
+ =:stay-open= is a boolean flag and may omit its =t= value.
** Groups and rows
@@ -283,8 +284,8 @@ the popup open -- no need to add =:stay-open t=.
#+begin_src emacs-lisp
(keymap-popup-define my-mark-map
:group "Mark"
- "m" ("Mark" dired-mark :stay-open t)
- "u" ("Unmark" dired-unmark :stay-open t)
+ "m" ("Mark" dired-mark :stay-open)
+ "u" ("Unmark" dired-unmark :stay-open)
"U" ("Unmark all" dired-unmark-all-marks))
#+end_src
@@ -433,9 +434,11 @@ Signature:
BINDINGS is an evaluated list in the same shape as
=keymap-popup-annotate='s body; commands and predicates are actual
objects rather than forms. OPTS accepts =:exit-key=,
-=:description=, and =:persistent=. Unlike the macros, no keys are
-bound and no commands are defined -- keyed entries should already
-be bound in KEYMAP. Returns KEYMAP.
+=:description=, and =:persistent=. Reattaching replaces prior
+descriptions and options, so omitted options return to their
+defaults. Unlike the macros, no keys are bound and no commands are
+defined -- keyed entries should already be bound in KEYMAP. Returns
+KEYMAP.
* Customization
:PROPERTIES:
@@ -498,4 +501,3 @@ emacs --batch -l ert -l keymap-popup.el \
-l tests/keymap-popup-tests.el \
-f ert-run-tests-batch-and-exit
#+end_src
-
diff --git a/keymap-popup.el b/keymap-popup.el
index 5bb615deb58..303381d9fea 100644
--- a/keymap-popup.el
+++ b/keymap-popup.el
@@ -179,27 +179,33 @@ no explicit :exit-key, for both `keymap-popup-define' and
(defun keymap-popup--attach-meta (keymap rows &rest opts)
"Attach popup descriptions ROWS and metadata OPTS to KEYMAP.
OPTS is a plist accepting :exit-key, :description, and
-:persistent; other keys are ignored. Only non-nil values are
-stored. :persistent is stored as the symbol `yes' because
-metadata lives in `define-key' bindings, where t means \"default
-binding\". Returns KEYMAP."
- (setf (keymap-popup--meta keymap 'descriptions) rows)
- (when-let* ((exit-key (plist-get opts :exit-key)))
- (setf (keymap-popup--meta keymap 'exit-key) exit-key))
- (when-let* ((description (plist-get opts :description)))
- (setf (keymap-popup--meta keymap 'description) description))
- (when (plist-get opts :persistent)
- (setf (keymap-popup--meta keymap 'persistent) 'yes))
+:persistent; other keys are ignored. Reattaching replaces all
+previous metadata, so omitted options return to their defaults.
+:persistent is stored as the symbol `yes' because metadata lives
+in `define-key' bindings, where t means \"default binding\".
+Returns KEYMAP."
+ (setf (keymap-popup--meta keymap 'descriptions) rows
+ (keymap-popup--meta keymap 'exit-key) (plist-get opts :exit-key)
+ (keymap-popup--meta keymap 'description) (plist-get opts :description)
+ (keymap-popup--meta keymap 'persistent)
+ (and (plist-get opts :persistent) 'yes))
keymap)
;;; Parsers
(defun keymap-popup--extract-props (plist)
"Extract known properties from PLIST.
-Recognized keys: :if, :inapt-if, :stay-open, :c-u."
- (cl-loop for (k v) on plist by #'cddr
- when (memq k '(:if :inapt-if :stay-open :c-u))
- append (list k v)))
+Recognized keys are :if, :inapt-if, :stay-open, and :c-u.
+:stay-open may be written as a bare boolean flag."
+ (named-let extract ((rest plist))
+ (cond
+ ((null rest) nil)
+ ((and (eq (car rest) :stay-open)
+ (or (null (cdr rest)) (keywordp (cadr rest))))
+ (cons :stay-open (cons t (extract (cdr rest)))))
+ ((memq (car rest) '(:if :inapt-if :stay-open :c-u))
+ (cons (car rest) (cons (cadr rest) (extract (cddr rest)))))
+ (t (extract (cddr rest))))))
(defun keymap-popup--parse-entry (key spec)
"Parse binding SPEC for KEY into a plist.
@@ -602,8 +608,9 @@ KEYMAP.
Unlike the macros, this attaches descriptions computed from data,
so it suits anonymous keymaps and menus built from runtime lists.
-It does not bind keys or define commands; keyed entries should
-already be bound in KEYMAP."
+Reattaching replaces prior descriptions and options; omitted
+options return to their defaults. It does not bind keys or define
+commands; keyed entries should already be bound in KEYMAP."
(apply #'keymap-popup--attach-meta keymap
(keymap-popup--parse-bindings bindings)
opts))
@@ -787,8 +794,9 @@ Returns a list of ((col-lines ...) ...) per row, filtering
empty groups."
(defun keymap-popup--global-col-widths (rendered-rows)
"Compute max column width per position across all RENDERED-ROWS."
- (let ((max-cols (cl-loop for cols in rendered-rows
- maximize (length cols))))
+ (let ((max-cols (or (cl-loop for cols in rendered-rows
+ maximize (length cols))
+ 0)))
(cl-loop for i from 0 below max-cols
collect (cl-loop for cols in rendered-rows
when (nth i cols)
@@ -835,9 +843,33 @@ Switch variables are buffer-local there, so rendering must
read
"Non-nil when this popup instance is in persistent mode.")
(defvar-local keymap-popup--wrapper-map nil
"The active wrapper keymap on `overriding-terminal-local-map'.")
+(defvar-local keymap-popup--exit-function nil
+ "Function that deactivates the active transient map.")
+(defvar-local keymap-popup--persistent-hook nil
+ "Self-removing post-command hook owned by this popup session.")
(defvar-local keymap-popup--display-backend nil
"The active display backend plist (:show :fit :hide).")
+(defun keymap-popup--snapshot-state ()
+ "Return the current popup navigation state as a plist."
+ (list :keymap keymap-popup--active-keymap
+ :descriptions keymap-popup--active-descriptions
+ :docstring keymap-popup--active-docstring
+ :exit-key keymap-popup--active-exit-key
+ :wrapper-map keymap-popup--wrapper-map
+ :exit-function keymap-popup--exit-function))
+
+(defun keymap-popup--restore-state (state)
+ "Restore popup navigation STATE in the current buffer."
+ (setq-local keymap-popup--active-keymap (plist-get state :keymap)
+ keymap-popup--active-descriptions (plist-get state :descriptions)
+ keymap-popup--active-docstring (plist-get state :docstring)
+ keymap-popup--active-exit-key (plist-get state :exit-key)
+ keymap-popup--wrapper-map (plist-get state :wrapper-map)
+ keymap-popup--exit-function (plist-get state :exit-function)
+ keymap-popup--reentering t
+ keymap-popup--prefix-mode nil))
+
;;; Popup display
(defun keymap-popup--dedupe-descriptions (descriptions)
@@ -959,14 +991,16 @@ the global map."
(defun keymap-popup--resolve-descriptions (rows keymap)
"Resolve entry keys in ROWS against KEYMAP's current bindings.
-Drops annotated entries whose command has no binding."
- (keymap-popup--map-groups
- rows
- (lambda (group)
- (plist-put (copy-sequence group) :entries
- (cl-loop for entry in (plist-get group :entries)
- when (keymap-popup--resolve-key entry keymap)
- collect it)))))
+Drops annotated entries whose command has no binding, then removes
+duplicates introduced when annotated entries resolve to the same key."
+ (keymap-popup--dedupe-descriptions
+ (keymap-popup--map-groups
+ rows
+ (lambda (group)
+ (plist-put (copy-sequence group) :entries
+ (cl-loop for entry in (plist-get group :entries)
+ when (keymap-popup--resolve-key entry keymap)
+ collect it))))))
;;; Display backends
@@ -1062,6 +1096,8 @@ Frame parameters are taken from
`keymap-popup-child-frame-parameters'."
(when (buffer-live-p buf)
(remove-hook 'minibuffer-setup-hook #'keymap-popup--suspend)
(remove-hook 'minibuffer-exit-hook #'keymap-popup--resume)
+ (when-let* ((hook (buffer-local-value 'keymap-popup--persistent-hook buf)))
+ (remove-hook 'post-command-hook hook))
(when-let* ((hide (plist-get (buffer-local-value
'keymap-popup--display-backend buf)
:hide)))
(funcall hide buf))
@@ -1104,15 +1140,8 @@ otherwise tears down completely."
(if (and keymap-popup--stack
(or (equal key-str keymap-popup--active-exit-key)
(equal key-str "C-g")))
- (pcase-let ((`(:keymap ,km :descriptions ,descs :docstring ,doc
- :exit-key ,ek)
- (pop keymap-popup--stack)))
- (setq-local keymap-popup--active-keymap km
- keymap-popup--active-descriptions descs
- keymap-popup--active-docstring doc
- keymap-popup--active-exit-key ek
- keymap-popup--reentering t
- keymap-popup--prefix-mode nil)
+ (progn
+ (keymap-popup--restore-state (pop keymap-popup--stack))
(keymap-popup--refresh buf))
(keymap-popup--teardown buf)))))))
@@ -1163,11 +1192,7 @@ the predicate itself is evaluated at keypress time."
(defun keymap-popup--push-submenu (buf child-keymap)
"Push current popup state in BUF and activate CHILD-KEYMAP's transient map."
(with-current-buffer buf
- (push (list :keymap keymap-popup--active-keymap
- :descriptions keymap-popup--active-descriptions
- :docstring keymap-popup--active-docstring
- :exit-key keymap-popup--active-exit-key)
- keymap-popup--stack)
+ (push (keymap-popup--snapshot-state) keymap-popup--stack)
(let* ((descs (keymap-popup--resolve-descriptions
(keymap-popup--collect-descriptions child-keymap)
child-keymap))
@@ -1309,12 +1334,24 @@ by the overrides reading the popup's active
descriptions."
(defun keymap-popup-dismiss ()
"Dismiss the active popup, if any.
-Deactivates the transient map and removes the popup display."
+Deactivates every transient map in a nested popup session and
+removes the popup display."
(interactive)
- (when-let* ((buf (get-buffer keymap-popup--buffer-name))
- (map (buffer-local-value 'keymap-popup--wrapper-map buf)))
- (internal-pop-keymap map 'overriding-terminal-local-map)
- (keymap-popup--teardown buf)))
+ (when-let* ((buf (get-buffer keymap-popup--buffer-name)))
+ (let ((exit-functions
+ (with-current-buffer buf
+ (prog1
+ (seq-filter
+ #'functionp
+ (cons keymap-popup--exit-function
+ (mapcar (lambda (state)
+ (plist-get state :exit-function))
+ keymap-popup--stack)))
+ (setq-local keymap-popup--exit-function nil
+ keymap-popup--stack nil)))))
+ (mapc #'funcall exit-functions)
+ (when (buffer-live-p buf)
+ (keymap-popup--teardown buf)))))
(defun keymap-popup--session-inputs (keymap)
"Derive a plist of session inputs from KEYMAP and the current buffer.
@@ -1343,6 +1380,8 @@ Returns (:source BUF :keymap MAP :descriptions D
:docstring S
keymap-popup--persistent (plist-get session :persistent)
keymap-popup--display-backend (plist-get session :backend)
keymap-popup--stack nil
+ keymap-popup--exit-function nil
+ keymap-popup--persistent-hook nil
keymap-popup--prefix-mode nil
keymap-popup--reentering nil)))
@@ -1352,18 +1391,24 @@ EXIT-KEY is bound in the wrapper to dismiss the popup."
(let ((wrapper (keymap-popup--build-wrapper-map keymap descriptions buf
exit-key)))
(with-current-buffer buf
(setq-local keymap-popup--wrapper-map wrapper))
- (set-transient-map wrapper
- (keymap-popup--make-keep-pred buf)
- (keymap-popup--make-on-exit buf))))
+ (let ((exit-function
+ (set-transient-map wrapper
+ (keymap-popup--make-keep-pred buf)
+ (keymap-popup--make-on-exit buf))))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (setq-local keymap-popup--exit-function exit-function))))))
(defun keymap-popup--install-persistent-hook (buf)
- "Add a self-removing post-command-hook that refreshes BUF until it dies."
+ "Install BUF's self-removing persistent refresh hook."
(let ((hook-fn (make-symbol "keymap-popup--persistent-refresh")))
(fset hook-fn
(lambda ()
(if (buffer-live-p buf)
(keymap-popup--refresh buf)
(remove-hook 'post-command-hook hook-fn))))
+ (with-current-buffer buf
+ (setq-local keymap-popup--persistent-hook hook-fn))
(add-hook 'post-command-hook hook-fn)))
;;;###autoload
@@ -1376,6 +1421,8 @@ dispatch. Sub-menu keys push a navigation stack.
\\[universal-argument] toggles prefix mode."
(or (keymap-popup--meta keymap 'descriptions)
(user-error "No descriptions in keymap"))
+ (when (get-buffer keymap-popup--buffer-name)
+ (keymap-popup-dismiss))
(let ((session (keymap-popup--session-inputs keymap))
(buf (keymap-popup--prepare-buffer)))
(keymap-popup--init-buffer-state buf session)
diff --git a/tests/keymap-popup-tests.el b/tests/keymap-popup-tests.el
index 1d08b3f6959..ba2863eeba7 100644
--- a/tests/keymap-popup-tests.el
+++ b/tests/keymap-popup-tests.el
@@ -446,6 +446,10 @@
(should-not (and (string-match-p "Row1" (car lines))
(string-match-p "Row2" (car lines)))))))
+(ert-deftest keymap-popup-test-render-empty-descriptions ()
+ "An empty resolved menu renders as a blank popup."
+ (should (equal (keymap-popup--render nil) "\n")))
+
(ert-deftest keymap-popup-test-columns-aligned-across-rows ()
(let* ((rows (list
(list (list :name "A"
@@ -638,6 +642,16 @@
(entry (keymap-popup--find-entry-by-key descs "g")))
(should (plist-get entry :stay-open))))
+(ert-deftest keymap-popup-test-bare-stay-open-in-descriptions ()
+ "A bare :stay-open property is a true boolean flag."
+ (eval '(keymap-popup-define keymap-popup--test-bare-stay
+ "g" ("Refresh" ignore :stay-open))
+ t)
+ (let* ((descs (keymap-popup--meta keymap-popup--test-bare-stay
+ 'descriptions))
+ (entry (keymap-popup--find-entry-by-key descs "g")))
+ (should (eq (plist-get entry :stay-open) t))))
+
(ert-deftest keymap-popup-test-dynamic-group-name ()
(eval '(keymap-popup-define keymap-popup--test-dyngrp
:group (lambda () "Dynamic Group")
@@ -1198,6 +1212,7 @@ come from the wrapper."
t)
(let ((buf (get-buffer-create keymap-popup--buffer-name))
(parent-map (make-sparse-keymap))
+ (parent-wrapper (make-sparse-keymap))
(received nil))
(unwind-protect
(progn
@@ -1207,6 +1222,8 @@ come from the wrapper."
keymap-popup--active-descriptions '(((:name nil
:entries nil)))
keymap-popup--active-docstring nil
keymap-popup--active-exit-key "q"
+ keymap-popup--wrapper-map parent-wrapper
+ keymap-popup--exit-function #'ignore
keymap-popup--stack nil))
(cl-letf (((symbol-function 'set-transient-map)
(lambda (map &rest _) (setq received map))))
@@ -1214,6 +1231,10 @@ come from the wrapper."
(with-current-buffer buf
(should (= (length keymap-popup--stack) 1))
(should (eq (plist-get (car keymap-popup--stack) :keymap)
parent-map))
+ (should (eq (plist-get (car keymap-popup--stack) :wrapper-map)
+ parent-wrapper))
+ (should (eq (plist-get (car keymap-popup--stack) :exit-function)
+ #'ignore))
(should (eq keymap-popup--active-keymap
keymap-popup--test-push-child))
(should keymap-popup--wrapper-map)
(should (eq received keymap-popup--wrapper-map))))
@@ -1443,6 +1464,22 @@ entry independently)."
(should (= (length entries) 1))
(should (equal (plist-get (car entries) :key) "a"))))
+(ert-deftest keymap-popup-test-resolve-descriptions-deduplicates-keys ()
+ "Annotated entries resolving to the same key keep the first description."
+ (let* ((map (make-sparse-keymap))
+ (rows '(((:name "Child" :entries
+ ((:key nil :description "Child" :type suffix
+ :command next-line)))
+ (:name "Parent" :entries
+ ((:key "n" :description "Parent" :type suffix
+ :command next-line)))))))
+ (keymap-set map "n" #'next-line)
+ (let* ((resolved (keymap-popup--resolve-descriptions rows map))
+ (entries (keymap-popup--collect-entries
+ resolved (lambda (entry _group) entry))))
+ (should (= (length entries) 1))
+ (should (equal (plist-get (car entries) :description) "Child")))))
+
(ert-deftest keymap-popup-test-annotate-macro ()
(eval '(keymap-popup-annotate keymap-popup--test-annotate-map
:group "Move"
@@ -1536,6 +1573,19 @@ entry independently)."
(should-not (keymap-popup--meta map 'description))
(should-not (keymap-popup--meta map 'persistent))))
+(ert-deftest keymap-popup-test-attach-meta-clears-stale-opts ()
+ "Reattaching without options removes values from the previous attachment."
+ (let ((map (make-sparse-keymap)))
+ (keymap-popup--attach-meta map '(old)
+ :exit-key "x"
+ :description "Old"
+ :persistent t)
+ (keymap-popup--attach-meta map '(new))
+ (should (equal (keymap-popup--meta map 'descriptions) '(new)))
+ (should-not (keymap-popup--meta map 'exit-key))
+ (should-not (keymap-popup--meta map 'description))
+ (should-not (keymap-popup--meta map 'persistent))))
+
(ert-deftest keymap-popup-test-attach-meta-ignores-unknown-opts ()
(let ((map (make-sparse-keymap)))
(keymap-popup--attach-meta map '(rows) :popup-key "?")
@@ -1595,6 +1645,81 @@ entry independently)."
(ert-deftest keymap-popup-test-dismiss-is-command ()
(should (commandp #'keymap-popup-dismiss)))
+(ert-deftest keymap-popup-test-dismiss-cleans-real-transient-maps ()
+ "Dismiss removes nested transient maps and their pre-command hooks."
+ (let ((overriding-terminal-local-map nil)
+ (pre-command-hook nil)
+ (parent (make-sparse-keymap))
+ (child (make-sparse-keymap))
+ (descriptions '(((:name nil :entries nil))))
+ (buf (get-buffer-create keymap-popup--buffer-name)))
+ (unwind-protect
+ (progn
+ (keymap-popup--attach-meta parent descriptions)
+ (keymap-popup--attach-meta child descriptions)
+ (with-current-buffer buf
+ (setq-local keymap-popup--source-buffer buf
+ keymap-popup--active-keymap parent
+ keymap-popup--active-descriptions descriptions
+ keymap-popup--active-exit-key "q"
+ keymap-popup--display-backend
+ (list :show #'ignore :fit #'ignore :hide #'ignore)))
+ (keymap-popup--activate-transient-map
+ buf parent descriptions "q")
+ (keymap-popup--push-submenu buf child)
+ (should overriding-terminal-local-map)
+ (should (= (length pre-command-hook) 2))
+ (keymap-popup-dismiss)
+ (should-not overriding-terminal-local-map)
+ (should-not pre-command-hook)
+ (should-not (buffer-live-p buf)))
+ (when (buffer-live-p buf)
+ (kill-buffer buf)))))
+
+(ert-deftest keymap-popup-test-teardown-removes-persistent-hook ()
+ "Teardown removes the popup's persistent post-command hook immediately."
+ (let ((post-command-hook nil)
+ (buf (get-buffer-create "*keymap-popup-test-persistent*")))
+ (unwind-protect
+ (progn
+ (with-current-buffer buf
+ (setq-local keymap-popup--display-backend
+ (list :show #'ignore :fit #'ignore :hide #'ignore)))
+ (keymap-popup--install-persistent-hook buf)
+ (should (= (length post-command-hook) 1))
+ (keymap-popup--teardown buf)
+ (should-not post-command-hook)
+ (should-not (buffer-live-p buf)))
+ (when (buffer-live-p buf)
+ (kill-buffer buf)))))
+
+(ert-deftest keymap-popup-test-new-session-replaces-active-session ()
+ "Opening another popup first removes the prior session's maps and hooks."
+ (let ((overriding-terminal-local-map nil)
+ (pre-command-hook nil)
+ (post-command-hook nil)
+ (keymap-popup-persistent t)
+ (keymap-popup-backend
+ (lambda () (list :show #'ignore :fit #'ignore :hide #'ignore)))
+ (map (make-sparse-keymap)))
+ (unwind-protect
+ (progn
+ (keymap-set map "x" #'ignore)
+ (keymap-popup-attach map '("x" ("Ignore" ignore)))
+ (with-temp-buffer
+ (keymap-popup map)
+ (should (= (length pre-command-hook) 1))
+ (should (= (length post-command-hook) 1))
+ (keymap-popup map)
+ (should (= (length pre-command-hook) 1))
+ (should (= (length post-command-hook) 1))
+ (keymap-popup-dismiss)
+ (should-not overriding-terminal-local-map)
+ (should-not pre-command-hook)
+ (should-not post-command-hook)))
+ (when (get-buffer keymap-popup--buffer-name)
+ (keymap-popup-dismiss)))))
+
(ert-deftest keymap-popup-test-on-exit-tears-down-for-suffix ()
"On-exit tears down when a suffix (non-exit-key) caused the exit."
(let ((buf (get-buffer-create "*keymap-popup-test-exit*")))
@@ -1618,12 +1743,14 @@ entry independently)."
"On-exit pops to parent when exit-key caused the exit."
(let ((buf (get-buffer-create "*keymap-popup-test-pop*"))
(parent-map (make-sparse-keymap))
+ (parent-wrapper (make-sparse-keymap))
(descs '(((:name nil :entries nil)))))
(unwind-protect
(progn
(with-current-buffer buf
(setq-local keymap-popup--active-exit-key "q")
(setq-local keymap-popup--active-keymap (make-sparse-keymap))
+ (setq-local keymap-popup--wrapper-map (make-sparse-keymap))
(setq-local keymap-popup--active-descriptions descs)
(setq-local keymap-popup--active-docstring nil)
(setq-local keymap-popup--source-buffer buf)
@@ -1631,7 +1758,9 @@ entry independently)."
(list (list :keymap parent-map
:descriptions descs
:docstring nil
- :exit-key "x")))
+ :exit-key "x"
+ :wrapper-map parent-wrapper
+ :exit-function #'ignore)))
(setq-local keymap-popup--display-backend
(list :show #'ignore :fit #'ignore :hide #'ignore)))
(let ((on-exit (keymap-popup--make-on-exit buf)))
@@ -1642,6 +1771,8 @@ entry independently)."
(with-current-buffer buf
(should (eq keymap-popup--active-keymap parent-map))
(should (equal keymap-popup--active-exit-key "x"))
+ (should (eq keymap-popup--wrapper-map parent-wrapper))
+ (should (eq keymap-popup--exit-function #'ignore))
(should-not keymap-popup--stack))))
(when (buffer-live-p buf)
(kill-buffer buf)))))
