aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorPhilip Kaludercic2024-06-15 14:44:06 +0200
committerPhilip Kaludercic2024-06-15 14:44:06 +0200
commitf1c06968eeac0b8caa39d385f436985dc448f40c (patch)
treeeee6134219dcd7ce2f0e8bfbdf16c6e05ca8aace
parentd3bdf11d808d32de8bee54a14c73f72c834a31bb (diff)
parent1e89fa000e9ba9549f15ef57abccd118d5f2fe1a (diff)
downloademacs-f1c06968eeac0b8caa39d385f436985dc448f40c.tar.gz
emacs-f1c06968eeac0b8caa39d385f436985dc448f40c.zip
Merge remote-tracking branch 'github-which-key/master'
-rw-r--r--lisp/which-key.el2810
-rw-r--r--test/lisp/which-key-tests.el267
2 files changed, 3077 insertions, 0 deletions
diff --git a/lisp/which-key.el b/lisp/which-key.el
new file mode 100644
index 00000000000..f53226ee969
--- /dev/null
+++ b/lisp/which-key.el
@@ -0,0 +1,2810 @@
1;;; which-key.el --- Display available keybindings in popup -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
4
5;; Author: Justin Burkett <justin@burkett.cc>
6;; Maintainer: Justin Burkett <justin@burkett.cc>
7;; Version: 3.6.0
8;; Keywords:
9;; Package-Requires: ((emacs "24.4"))
10
11;; This program is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; This program is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; which-key provides the minor mode which-key-mode for Emacs. The mode displays
27;; the key bindings following your currently entered incomplete command (a
28;; prefix) in a popup. For example, after enabling the minor mode if you enter
29;; C-x and wait for the default of 1 second the minibuffer will expand with all
30;; of the available key bindings that follow C-x (or as many as space allows
31;; given your settings). This includes prefixes like C-x 8 which are shown in a
32;; different face. Screenshots of what the popup will look like along with
33;; information about additional features can be found at
34;; https://github.com/justbur/emacs-which-key.
35;;
36
37;;; Code:
38
39(require 'cl-lib)
40(require 'button)
41(require 'regexp-opt)
42
43;; For compiler
44(defvar evil-operator-shortcut-map)
45(defvar evil-operator-state-map)
46(defvar evil-motion-state-map)
47(defvar golden-ratio-mode)
48(declare-function evil-get-command-property "ext:evil-common.el")
49
50;;; Options
51
52(defgroup which-key nil
53 "Customization options for which-key-mode."
54 :group 'help
55 :prefix "which-key-")
56
57(defcustom which-key-idle-delay 1.0
58 "Delay (in seconds) for which-key buffer to popup.
59This variable should be set before activating `which-key-mode'.
60
61A value of zero might lead to issues, so a non-zero value is
62recommended
63(see https://github.com/justbur/emacs-which-key/issues/134)."
64 :type 'float
65 :version "1.0")
66
67(defcustom which-key-idle-secondary-delay nil
68 "Seconds to wait for which-key to pop up after initial display.
69This makes it possible to shorten the delay for subsequent popups
70in the same key sequence. The default is for this value to be
71nil, which disables this behavior."
72 :type '(choice float (const :tag "Disabled" nil))
73 :version "1.0")
74
75(defcustom which-key-echo-keystrokes (if (and echo-keystrokes
76 (> (+ echo-keystrokes 0.01)
77 which-key-idle-delay))
78 (/ (float which-key-idle-delay) 4)
79 echo-keystrokes)
80 "Value to use for `echo-keystrokes'.
81This only applies if `which-key-popup-type' is minibuffer or
82`which-key-show-prefix' is echo. It needs to be less than
83`which-key-idle-delay' or else the keystroke echo will erase the
84which-key popup."
85 :type 'float
86 :version "1.0")
87
88(defcustom which-key-max-description-length 27
89 "Truncate the description of keys to this length.
90Either nil (no truncation), an integer (truncate after that many
91characters), a float (use that fraction of the available width),
92or a function, which takes one argument, the available width in
93characters, and whose return value has one of the types mentioned
94before. Truncation is done using `which-key-ellipsis'."
95 :type '(choice (const :tag "Disable truncation" nil)
96 (integer :tag "Width in characters")
97 (float :tag "Use fraction of available width")
98 function)
99 :version "1.0")
100
101(defcustom which-key-min-column-description-width 0
102 "Every column should at least have this width."
103 :type 'natnum
104 :version "1.0")
105
106(defcustom which-key-add-column-padding 0
107 "Additional spaces to add to the left of each key column."
108 :type 'integer
109 :version "1.0")
110
111(defcustom which-key-unicode-correction 3
112 "Correction for wide unicode characters.
113Since we measure width in terms of the number of characters,
114Unicode characters that are wider than ASCII characters throw off
115the calculation for available width in the which-key buffer. This
116variable allows you to adjust for the wide unicode characters by
117artificially reducing the available width in the buffer.
118
119The default of 3 means allow for the total extra width
120contributed by any wide unicode characters to be up to one
121additional ASCII character in the which-key buffer. Increase this
122number if you are seeing characters get cutoff on the right side
123of the which-key popup."
124 :type 'integer
125 :version "1.0")
126
127(defcustom which-key-dont-use-unicode nil
128 "If non-nil, don't use any unicode characters in default setup.
129For affected settings, see `which-key-replacement-alist', `which-key-ellipsis'
130`which-key-separator'."
131 :type 'boolean
132 :version "1.0")
133
134(defcustom which-key-separator
135 (if which-key-dont-use-unicode " : " " → ")
136 "Separator to use between key and description.
137Default is \" → \", unless `which-key-dont-use-unicode' is non
138nil, in which case the default is \" : \"."
139 :type 'string
140 :version "1.0")
141
142(defcustom which-key-ellipsis
143 (if which-key-dont-use-unicode ".." "…")
144 "Ellipsis to use when truncating.
145Default is \"…\", unless `which-key-dont-use-unicode' is non nil,
146in which case the default is \"..\". This can also be the empty
147string to truncate without using any ellipsis."
148 :type 'string
149 :version "1.0")
150
151(defcustom which-key-prefix-prefix "+"
152 "Prefix string to indicate a key bound to a keymap.
153Default is \"+\"."
154 :type 'string
155 :version "1.0")
156
157(defcustom which-key-compute-remaps nil
158 "If non-nil, show remapped commands.
159This applies to commands that have been remapped given the
160currently active keymaps."
161 :type 'boolean
162 :version "1.0")
163
164(defcustom which-key-replacement-alist
165 `(((nil . "which-key-show-next-page-no-cycle") . (nil . "wk next pg"))
166 ,@(unless which-key-dont-use-unicode
167 '((("<left>") . ("←"))
168 (("<right>") . ("→"))))
169 (("<\\([[:alnum:]-]+\\)>") . ("\\1")))
170 "ALIST for manipulating display of binding descriptions.
171Each element of the list is a nested cons cell with the format
172
173\(MATCH CONS . REPLACEMENT\).
174
175The MATCH CONS determines when a replacement should occur and
176REPLACEMENT determines how the replacement should occur. Each may
177have the format \(KEY REGEXP . BINDING REGEXP\). For the
178replacement to apply the key binding must match both the KEY
179REGEXP and the BINDING REGEXP. A value of nil in either position
180can be used to match every possibility. The replacement is
181performed by using `replace-regexp-in-string' on the KEY REGEXP
182from the MATCH CONS and REPLACEMENT when it is a cons cell, and
183then similarly for the BINDING REGEXP. A nil value in the BINDING
184REGEXP position cancels the replacement. For example, the entry
185
186\(\(nil . \"Prefix Command\"\) . \(nil . \"prefix\"\)\)
187
188matches any binding with the descriptions \"Prefix Command\" and
189replaces the description with \"prefix\", ignoring the
190corresponding key.
191
192REPLACEMENT may also be a function taking a cons cell
193\(KEY . BINDING\) and producing a new corresponding cons cell.
194
195If REPLACEMENT is anything other than a cons cell \(and non nil\)
196the key binding is ignored by which-key.
197
198Finally, you can multiple replacements to occur for a given key
199binding by setting `which-key-allow-multiple-replacements' to a
200non-nil value."
201 :type '(alist :key-type (cons (choice regexp (const nil))
202 (choice regexp (const nil)))
203 :value-type (cons (choice string (const nil))
204 (choice string (const nil))))
205 :version "1.0")
206
207(defcustom which-key-allow-multiple-replacements nil
208 "Allow a key binding to be modified by multiple elements.
209When non-nil, this allows a single key binding to match multiple
210patterns in `which-key-replacement-alist'. When nil, only the
211first match is used to perform replacements from
212`which-key-replacement-alist'."
213 :type 'boolean
214 :version "1.0")
215
216(defcustom which-key-show-docstrings nil
217 "If non-nil, show each command's docstring in the which-key popup.
218This will only display the docstring up to the first line
219break. If you set this variable to the symbol docstring-only,
220then the command's name with be omitted. You probably also want
221to adjust `which-key-max-description-length' at the same time if
222you use this feature."
223 :type '(radio
224 (const :tag "Do not show docstrings" nil)
225 (const :tag "Add docstring to command names" t)
226 (const :tag "Replace command name with docstring" docstring-only))
227 :version "1.0")
228
229(defcustom which-key-highlighted-command-list '()
230 "Rules used to highlight certain commands.
231If the element is a string, assume it is a regexp pattern for
232matching command names and use
233`which-key-highlighted-command-face' for any matching names. If
234the element is a cons cell, it should take the form (regexp .
235face to apply)."
236 :type '(repeat (choice string (cons regexp face)))
237 :version "1.0")
238
239(defcustom which-key-special-keys '()
240 "These keys will automatically be truncated to one character.
241They also have `which-key-special-key-face' applied to them. This
242is disabled by default. An example configuration is
243
244\(setq which-key-special-keys \\='(\"SPC\" \"TAB\" \"RET\" \"ESC\" \"DEL\")\)"
245 :type '(repeat string)
246 :version "1.0")
247
248(defcustom which-key-buffer-name " *which-key*"
249 "Name of which-key buffer."
250 :type 'string
251 :version "1.0")
252
253(defcustom which-key-show-prefix 'echo
254 "Whether to and where to display the current prefix sequence.
255Possible choices are echo for echo area (the default), left, top
256and nil. Nil turns the feature off."
257 :type '(radio (const :tag "Left of the keys" left)
258 (const :tag "In the first line" top)
259 (const :tag "In the last line" bottom)
260 (const :tag "In the echo area" echo)
261 (const :tag "In the mode-line" mode-line)
262 (const :tag "Hide" nil))
263 :version "1.0")
264
265(defcustom which-key-popup-type 'side-window
266 "Supported types are minibuffer, side-window, frame, and custom."
267 :type '(radio (const :tag "Show in minibuffer" minibuffer)
268 (const :tag "Show in side window" side-window)
269 (const :tag "Show in popup frame" frame)
270 (const :tag "Use your custom display functions" custom))
271 :version "1.0")
272
273(defcustom which-key-min-display-lines 1
274 "Minimum number of horizontal lines to display in the which-key buffer."
275 :type 'integer
276 :version "1.0")
277
278(defcustom which-key-max-display-columns nil
279 "Maximum number of columns to display in the which-key buffer.
280A value of nil means don't impose a maximum."
281 :type '(choice integer (const :tag "Unbounded" nil))
282 :version "1.0")
283
284(defcustom which-key-side-window-location 'bottom
285 "Location of which-key popup when `which-key-popup-type' is side-window.
286Should be one of top, bottom, left or right. You can also specify
287a list of two locations, like (right bottom). In this case, the
288first location is tried. If there is not enough room, the second
289location is tried."
290 :type '(radio (const right)
291 (const bottom)
292 (const left)
293 (const top)
294 (const (right bottom))
295 (const (bottom right)))
296 :version "1.0")
297
298(defcustom which-key-side-window-slot 0
299 "The `slot' to use for `display-buffer-in-side-window'.
300This applies when `which-key-popup-type' is `side-window'.
301Quoting from the docstring of `display-buffer-in-side-window',
302
303`slot' if non-nil, specifies the window slot where to display
304BUFFER. A value of zero or nil means use the middle slot on the
305specified side. A negative value means use a slot
306preceding (that is, above or on the left of) the middle slot. A
307positive value means use a slot following (that is, below or on
308the right of) the middle slot. The default is zero."
309 :type 'integer
310 :version "1.0")
311
312(defcustom which-key-side-window-max-width 0.333
313 "Maximum width of which-key popup when type is side-window.
314This variable can also be a number between 0 and 1. In that case,
315it denotes a percentage out of the frame's width."
316 :type 'float
317 :version "1.0")
318
319(defcustom which-key-side-window-max-height 0.25
320 "Maximum height of which-key popup when type is side-window.
321This variable can also be a number between 0 and 1. In that case, it denotes
322a percentage out of the frame's height."
323 :type 'float
324 :version "1.0")
325
326(defcustom which-key-frame-max-width 60
327 "Maximum width of which-key popup when type is frame."
328 :type 'natnum
329 :version "1.0")
330
331(defcustom which-key-frame-max-height 20
332 "Maximum height of which-key popup when type is frame."
333 :type 'natnum
334 :version "1.0")
335
336(defcustom which-key-allow-imprecise-window-fit (not (display-graphic-p))
337 "Allow which-key to use a simpler method for resizing the popup.
338If you are noticing lag when the which-key popup displays turning
339this on may help.
340
341See https://github.com/justbur/emacs-which-key/issues/130
342and https://github.com/justbur/emacs-which-key/issues/225."
343 :type 'boolean
344 :version "1.0")
345
346(defcustom which-key-show-remaining-keys nil
347 "Show remaining keys in last slot, when keys are hidden."
348 :type '(radio (const :tag "Yes" t)
349 (const :tag "No" nil))
350 :version "1.0")
351
352(defcustom which-key-sort-order #'which-key-key-order
353 "Order in which the key bindings are sorted.
354If nil, do not resort the output from `describe-buffer-bindings'
355which groups by mode. Ordering options
356are
357
3581. `which-key-key-order': by key (default)
3592. `which-key-key-order-alpha': by key using alphabetical order
3603. `which-key-description-order': by description
3614. `which-key-prefix-then-key-order': prefix (no prefix first) then key
3625. `which-key-local-then-key-order': local binding then key
363
364See the README and the docstrings for those functions for more
365information."
366 :type '(choice (function-item which-key-key-order)
367 (function-item which-key-key-order-alpha)
368 (function-item which-key-description-order)
369 (function-item which-key-prefix-then-key-order)
370 (function-item which-key-local-then-key-order))
371 :version "1.0")
372
373(defcustom which-key-sort-uppercase-first t
374 "If non-nil, uppercase comes before lowercase in sorting.
375This applies to the function chosen in
376`which-key-sort-order'. Otherwise, the order is reversed."
377 :type 'boolean
378 :version "1.0")
379
380(defcustom which-key-paging-prefixes '()
381 "Enable paging for these prefixes."
382 :type '(repeat string)
383 :version "1.0")
384
385(defcustom which-key-paging-key "<f5>"
386 "Key to use for changing pages.
387Bound after each of the prefixes in `which-key-paging-prefixes'"
388 :type 'string
389 :version "1.0")
390
391;; (defcustom which-key-undo-key nil
392;; "Key (string) to use for undoing keypresses. Bound recursively
393;; in each of the maps in `which-key-undo-keymaps'."
394;; :group 'which-key
395;; :type 'string)
396
397;; (defcustom which-key-undo-keymaps '()
398;; "Keymaps in which to bind `which-key-undo-key'"
399;; :group 'which-key
400;; :type '(repeat symbol))
401
402(defcustom which-key-use-C-h-commands t
403 "Use C-h (`help-char') for paging if non-nil.
404Normally `help-char' after a prefix calls
405`describe-prefix-bindings'. This changes that command to a
406which-key paging command when which-key-mode is active."
407 :type 'boolean
408 :version "1.0")
409
410(defcustom which-key-show-early-on-C-h nil
411 "Allow C-h (`help-char') to trigger which-key popup before timer.
412Show the which-key buffer if `help-char' is pressed in the middle
413of a prefix before the which-key buffer would normally be
414triggered by the time. If combined with the following settings,
415which-key will effectively only show when triggered \"manually\"
416using C-h.
417
418\(setq `which-key-idle-delay' 10000)
419\(setq `which-key-idle-secondary-delay' 0.05)
420
421Note that `which-key-idle-delay' should be set before turning on
422`which-key-mode'."
423 :type 'boolean
424 :version "1.0")
425
426(defcustom which-key-is-verbose nil
427 "Whether to warn about potential mistakes in configuration."
428 :type 'boolean
429 :version "1.0")
430
431(defcustom which-key-preserve-window-configuration nil
432 "Save and restore window configuration around which-key popup display.
433If non-nil, save window configuration before which-key buffer is
434shown and restore it after which-key buffer is hidden. It
435prevents which-key from changing window position of visible
436buffers. Only takken into account when popup type is
437side-window."
438 :type 'boolean
439 :version "1.0")
440
441(defvar which-key-C-h-map-prompt
442 (concat " \\<which-key-C-h-map>"
443 " \\[which-key-show-next-page-cycle]"
444 which-key-separator "next-page,"
445 " \\[which-key-show-previous-page-cycle]"
446 which-key-separator "previous-page,"
447 " \\[which-key-undo-key]"
448 which-key-separator "undo-key,"
449 " \\[which-key-toggle-docstrings]"
450 which-key-separator "toggle-docstrings,"
451 " \\[which-key-show-standard-help]"
452 which-key-separator "help,"
453 " \\[which-key-abort]"
454 which-key-separator "abort"
455 " 1..9"
456 which-key-separator "digit-arg")
457 "Prompt to display when invoking `which-key-C-h-map'.
458This string is fed into `substitute-command-keys'")
459
460(defvar which-key-C-h-map
461 (let ((map (make-sparse-keymap)))
462 (dolist (bind `(("\C-a" . which-key-abort)
463 ("a" . which-key-abort)
464 ("\C-d" . which-key-toggle-docstrings)
465 ("d" . which-key-toggle-docstrings)
466 (,(vector help-char) . which-key-show-standard-help)
467 ("h" . which-key-show-standard-help)
468 ("\C-n" . which-key-show-next-page-cycle)
469 ("n" . which-key-show-next-page-cycle)
470 ("\C-p" . which-key-show-previous-page-cycle)
471 ("p" . which-key-show-previous-page-cycle)
472 ("\C-u" . which-key-undo-key)
473 ("u" . which-key-undo-key)
474 ("1" . which-key-digit-argument)
475 ("2" . which-key-digit-argument)
476 ("3" . which-key-digit-argument)
477 ("4" . which-key-digit-argument)
478 ("5" . which-key-digit-argument)
479 ("6" . which-key-digit-argument)
480 ("7" . which-key-digit-argument)
481 ("8" . which-key-digit-argument)
482 ("9" . which-key-digit-argument)))
483 (define-key map (car bind) (cdr bind)))
484 map)
485 "Keymap for C-h commands.")
486
487(defvar which-key--paging-functions
488 (list #'which-key-C-h-dispatch
489 #'which-key-turn-page
490 #'which-key-show-next-page-cycle
491 #'which-key-show-next-page-no-cycle
492 #'which-key-show-previous-page-cycle
493 #'which-key-show-previous-page-no-cycle
494 #'which-key-undo-key
495 #'which-key-undo))
496
497(defvar which-key-persistent-popup nil
498 "Whether or not to disable `which-key--hide-popup'.")
499
500(defcustom which-key-hide-alt-key-translations t
501 "Hide key translations using Alt key if non nil.
502These translations are not relevant most of the times since a lot
503of terminals issue META modifier for the Alt key.
504
505See Info node `(emacs)Modifier Keys'."
506 :type 'boolean
507 :version "1.0")
508
509(defcustom which-key-delay-functions nil
510 "List of functions that may delay the which-key popup.
511A list of functions that may decide whether to delay the
512which-key popup based on the current incomplete key
513sequence. Each function in the list is run with two arguments,
514the current key sequence as produced by `key-description' and the
515length of the key sequence. If the popup should be delayed based
516on that key sequence, the function should return the delay time
517in seconds. Returning nil means no delay. The first function in
518this list to return a value is the value that is used.
519
520The delay time is effectively added to the normal
521`which-key-idle-delay'."
522 :type '(repeat function)
523 :version "1.0")
524
525(defcustom which-key-allow-regexps nil
526 "A list of regexp strings to use to filter key sequences.
527When non-nil, for a key sequence to trigger the which-key popup
528it must match one of the regexps in this list. The format of the
529key sequences is what is produced by `key-description'."
530 :type '(repeat regexp)
531 :version "1.0")
532
533(defcustom which-key-inhibit-regexps nil
534 "A list of regexp strings to use to filter key sequences.
535When non-nil, for a key sequence to trigger the which-key popup
536it cannot match one of the regexps in this list. The format of
537the key sequences is what is produced by `key-description'."
538 :type '(repeat regexp)
539 :version "1.0")
540
541(defcustom which-key-show-transient-maps nil
542 "Show keymaps created by `set-transient-map' when applicable.
543
544More specifically, detect when `overriding-terminal-local-map' is
545set (this is the keymap used by `set-transient-map') and display
546it."
547 :type 'boolean
548 :version "1.0")
549
550(make-obsolete-variable
551 'which-key-enable-extended-define-key
552 "which-key-enable-extended-define-key is obsolete and has no effect."
553 "2021-06-21")
554
555;; Hooks
556(defcustom which-key-init-buffer-hook '()
557 "Hook run when which-key buffer is initialized."
558 :type 'hook
559 :version "1.0")
560
561;;;; Faces
562
563(defgroup which-key-faces nil
564 "Faces for which-key-mode"
565 :group 'which-key
566 :prefix "which-key-")
567
568(defface which-key-key-face
569 '((t . (:inherit font-lock-constant-face)))
570 "Face for which-key keys"
571 :group 'which-key-faces
572 :version "1.0")
573
574(defface which-key-separator-face
575 '((t . (:inherit font-lock-comment-face)))
576 "Face for the separator (default separator is an arrow)"
577 :group 'which-key-faces
578 :version "1.0")
579
580(defface which-key-note-face
581 '((t . (:inherit which-key-separator-face)))
582 "Face for notes or hints occasionally provided"
583 :group 'which-key-faces
584 :version "1.0")
585
586(defface which-key-command-description-face
587 '((t . (:inherit font-lock-function-name-face)))
588 "Face for the key description when it is a command"
589 :group 'which-key-faces
590 :version "1.0")
591
592(defface which-key-local-map-description-face
593 '((t . (:inherit which-key-command-description-face)))
594 "Face for the key description when it is found in `current-local-map'"
595 :group 'which-key-faces
596 :version "1.0")
597
598(defface which-key-highlighted-command-face
599 '((t . (:inherit which-key-command-description-face :underline t)))
600 "Default face for the command description when it is a command
601and it matches a string in `which-key-highlighted-command-list'."
602 :group 'which-key-faces
603 :version "1.0")
604
605(defface which-key-group-description-face
606 '((t . (:inherit font-lock-keyword-face)))
607 "Face for the key description when it is a group or prefix."
608 :group 'which-key-faces
609 :version "1.0")
610
611(defface which-key-special-key-face
612 '((t . (:inherit which-key-key-face :inverse-video t :weight bold)))
613 "Face for special keys (SPC, TAB, RET)"
614 :group 'which-key-faces
615 :version "1.0")
616
617(defface which-key-docstring-face
618 '((t . (:inherit which-key-note-face)))
619 "Face for docstrings."
620 :group 'which-key-faces
621 :version "1.0")
622
623;;;; Custom popup
624
625(defcustom which-key-custom-popup-max-dimensions-function nil
626 "Set a custom max-dimensions function.
627Will be passed the width of the active window and is expected to
628return the maximum height in lines and width in characters of the
629which-key popup in the form a cons cell (height . width)."
630 :group 'which-key
631 :type '(choice function (const nil))
632 :version "1.0")
633
634(defcustom which-key-custom-hide-popup-function nil
635 "Set a custom hide-popup function.
636It takes no arguments and the return value is ignored."
637 :group 'which-key
638 :type '(choice function (const nil))
639 :version "1.0")
640
641(defcustom which-key-custom-show-popup-function nil
642 "Set a custom show-popup function.
643Will be passed the required dimensions in the form (height .
644width) in lines and characters respectively. The return value is
645ignored."
646 :group 'which-key
647 :type '(choice function (const nil))
648 :version "1.0")
649
650(defcustom which-key-lighter " WK"
651 "Minor mode lighter to use in the mode-line."
652 :group 'which-key
653 :type 'string
654 :version "1.0")
655
656(defvar which-key-inhibit nil
657 "Prevent which-key from popping up momentarily.
658This can be used by setting this to a non-nil value for the
659execution of a command, as in
660
661\(let \(\(which-key-inhibit t\)\)
662...\)")
663
664(defcustom which-key-inhibit-display-hook nil
665 "Hook run before display of which-key popup.
666Each function in the hook is run before displaying the which-key
667popup. If any function returns a non-nil value, the popup will
668not display."
669 :group 'which-key
670 :type 'hook
671 :version "1.0")
672
673(defvar which-key-keymap-history nil
674 "History of keymap selections.
675Used in functions like `which-key-show-keymap'.")
676
677;;; Internal Vars
678
679(defvar which-key--buffer nil
680 "Holds reference to which-key buffer.")
681(defvar which-key--timer nil
682 "Holds reference to open window timer.")
683(defvar which-key--secondary-timer-active nil
684 "Non-nil if the secondary timer is active.")
685(defvar which-key--paging-timer nil
686 "Holds reference to timer for paging.")
687(defvar which-key--frame nil
688 "Holds reference to which-key frame.
689Used when `which-key-popup-type' is frame.")
690(defvar which-key--echo-keystrokes-backup nil
691 "Backup the initial value of `echo-keystrokes'.")
692(defvar which-key--prefix-help-cmd-backup nil
693 "Backup the value of `prefix-help-command'.")
694(defvar which-key--last-try-2-loc nil
695 "Last location of side-window when two locations used.")
696(defvar which-key--automatic-display nil
697 "Non-nil if popup was triggered with automatic update.")
698(defvar which-key--debug-buffer-name nil
699 "If non-nil, use this buffer for debug messages.")
700(defvar which-key--multiple-locations nil)
701(defvar which-key--inhibit-next-operator-popup nil)
702(defvar which-key--prior-show-keymap-args nil)
703(defvar which-key--previous-frame-size nil)
704(defvar which-key--prefix-title-alist nil)
705(defvar which-key--evil-keys-regexp (eval-when-compile
706 (regexp-opt '("-state"))))
707(defvar which-key--ignore-non-evil-keys-regexp
708 (regexp-opt '("mouse-" "wheel-" "remap" "drag-" "scroll-bar"
709 "select-window" "switch-frame" "which-key")))
710(defvar which-key--ignore-keys-regexp
711 (regexp-opt '("mouse-" "wheel-" "remap" "drag-" "scroll-bar"
712 "select-window" "switch-frame" "-state"
713 "which-key")))
714
715(defvar which-key--pages-obj nil)
716(cl-defstruct which-key--pages
717 pages
718 height
719 widths
720 keys/page
721 page-nums
722 num-pages
723 total-keys
724 prefix
725 prefix-title)
726
727(defvar which-key--saved-window-configuration nil)
728
729(defun which-key--rotate (list n)
730 (let* ((len (length list))
731 (n (- len (mod n len))))
732 (append (last list n) (butlast list n))))
733
734(defun which-key--pages-set-current-page (pages-obj n)
735 (setf (which-key--pages-pages pages-obj)
736 (which-key--rotate (which-key--pages-pages pages-obj) n))
737 (setf (which-key--pages-widths pages-obj)
738 (which-key--rotate (which-key--pages-widths pages-obj) n))
739 (setf (which-key--pages-keys/page pages-obj)
740 (which-key--rotate (which-key--pages-keys/page pages-obj) n))
741 (setf (which-key--pages-page-nums pages-obj)
742 (which-key--rotate (which-key--pages-page-nums pages-obj) n))
743 pages-obj)
744
745(defsubst which-key--on-first-page ()
746 (= (which-key--pages-page-nums which-key--pages-obj) 1))
747
748(defsubst which-key--on-last-page ()
749 (= (which-key--pages-page-nums which-key--pages-obj)
750 (which-key--pages-num-pages which-key--pages-obj)))
751
752(defsubst which-key--current-prefix ()
753 (and which-key--pages-obj
754 (which-key--pages-prefix which-key--pages-obj)))
755
756(defmacro which-key--debug-message (&rest msg)
757 `(when which-key--debug-buffer-name
758 (let ((buf (get-buffer-create which-key--debug-buffer-name))
759 (fmt-msg (format ,@msg)))
760 (with-current-buffer buf
761 (goto-char (point-max))
762 (insert "\n" fmt-msg "\n")))))
763
764(defsubst which-key--safe-lookup-key (keymap key)
765 "Version of `lookup-key' that allows KEYMAP to be nil.
766Also convert numeric results of `lookup-key' to nil. KEY is not
767checked."
768 (when (keymapp keymap)
769 (let ((result (lookup-key keymap key)))
770 (when (and result (not (numberp result)))
771 result))))
772
773(defsubst which-key--safe-lookup-key-description (keymap key)
774 "Version of `lookup-key' that allows KEYMAP to be nil.
775Also convert numeric results of `lookup-key' to nil. KEY
776should be formatted as an input for `kbd'."
777 (let ((key (ignore-errors (kbd key))))
778 (when (and key (keymapp keymap))
779 (let ((result (lookup-key keymap key)))
780 (when (and result (not (numberp result)))
781 result)))))
782
783;;; Third-party library support
784
785(defun which-key--this-command-keys ()
786 "Version of `this-single-command-keys' corrected for key-chords."
787 (let ((this-command-keys (this-single-command-keys)))
788 (when (and (vectorp this-command-keys)
789 (> (length this-command-keys) 0)
790 (eq (aref this-command-keys 0) 'key-chord)
791 (bound-and-true-p key-chord-mode))
792 (setq this-command-keys (this-single-command-raw-keys)))
793 this-command-keys))
794
795(defcustom which-key-this-command-keys-function #'which-key--this-command-keys
796 "Function used to retrieve current key sequence.
797The purpose of allowing this variable to be customized is to
798allow which-key to support packages that insert non-standard
799`keys' into the key sequence being read by emacs."
800 :group 'which-key
801 :type 'function
802 :version "1.0")
803
804
805;;;; Evil
806
807(defvar evil-state nil)
808
809(defcustom which-key-allow-evil-operators (boundp 'evil-this-operator)
810 "Allow popup to show for evil operators.
811The popup is normally inhibited in the middle of commands, but
812setting this to non-nil will override this behavior for evil
813operators."
814 :group 'which-key
815 :type 'boolean
816 :version "1.0")
817
818(defcustom which-key-show-operator-state-maps nil
819 "Show the keys following an evil command that reads a motion.
820These are commands typically mapped to keys such as \"y\", \"d\"
821and \"c\" from normal state. This is experimental, because there
822might be some valid keys missing and it might be showing some
823invalid keys."
824 :group 'which-key
825 :type 'boolean
826 :version "1.0")
827
828(defun which-key-evil-this-operator-p ()
829 (and which-key-allow-evil-operators
830 (bound-and-true-p evil-this-operator)))
831
832(add-hook 'which-key-inhibit-display-hook
833 #'which-key-evil-this-operator-p)
834
835;;;; God-mode
836
837(defvar which-key--god-mode-support-enabled nil
838 "Support god-mode if non-nil.")
839
840(defvar which-key--god-mode-key-string nil
841 "String to use for god-mode support.")
842
843(defun which-key--god-mode-lookup-command-advice (orig-fun arg1 &rest args)
844 (setq which-key--god-mode-key-string arg1)
845 (unwind-protect
846 (apply orig-fun arg1 args)
847 (when (bound-and-true-p which-key-mode)
848 (which-key--hide-popup))))
849
850(defun which-key--god-mode-this-command-keys ()
851 "Version of `this-single-command-keys' corrected for god-mode."
852 (let ((this-command-keys (this-single-command-keys)))
853 (when (and which-key--god-mode-support-enabled
854 (bound-and-true-p god-local-mode)
855 (eq this-command 'god-mode-self-insert))
856 (setq this-command-keys (when which-key--god-mode-key-string
857 (kbd which-key--god-mode-key-string))))
858 this-command-keys))
859
860(defun which-key-god-mode-self-insert-p ()
861 (and which-key--god-mode-support-enabled
862 (bound-and-true-p god-local-mode)
863 (eq this-command 'god-mode-self-insert)))
864
865(defun which-key-enable-god-mode-support (&optional disable)
866 "Enable support for god-mode if non-nil.
867This is experimental, so you need to explicitly opt-in for
868now. Please report any problems at github. If DISABLE is non-nil
869disable support."
870 (interactive "P")
871 (setq which-key--god-mode-support-enabled (null disable))
872 (if disable
873 (progn
874 (advice-remove 'god-mode-lookup-command
875 #'which-key--god-mode-lookup-command-advice)
876 (remove-function which-key-this-command-keys-function
877 #'which-key--god-mode-this-command-keys)
878 (remove-hook 'which-key-inhibit-display-hook
879 #'which-key-god-mode-self-insert-p))
880 (advice-add 'god-mode-lookup-command :around
881 #'which-key--god-mode-lookup-command-advice)
882 (add-function :override which-key-this-command-keys-function
883 #'which-key--god-mode-this-command-keys)
884 (add-hook 'which-key-inhibit-display-hook
885 #'which-key-god-mode-self-insert-p)))
886
887;;; Mode
888
889;;;###autoload
890(define-minor-mode which-key-mode
891 "Toggle which-key-mode."
892 :global t
893 :group 'which-key
894 :lighter which-key-lighter
895 :keymap (let ((map (make-sparse-keymap)))
896 (mapc
897 (lambda (prefix)
898 (define-key map
899 (kbd (concat prefix " " which-key-paging-key))
900 #'which-key-C-h-dispatch))
901 which-key-paging-prefixes)
902 map)
903 (if which-key-mode
904 (progn
905 (setq which-key--echo-keystrokes-backup echo-keystrokes)
906 (when (or (eq which-key-show-prefix 'echo)
907 (eq which-key-popup-type 'minibuffer))
908 (which-key--setup-echo-keystrokes))
909 (unless (member prefix-help-command which-key--paging-functions)
910 (setq which-key--prefix-help-cmd-backup prefix-help-command))
911 (when (or which-key-use-C-h-commands
912 which-key-show-early-on-C-h)
913 (setq prefix-help-command #'which-key-C-h-dispatch))
914 (when which-key-show-remaining-keys
915 (add-hook 'pre-command-hook #'which-key--lighter-restore))
916 (add-hook 'pre-command-hook #'which-key--hide-popup)
917 (add-hook 'window-size-change-functions
918 #'which-key--hide-popup-on-frame-size-change)
919 (which-key--start-timer))
920 (setq echo-keystrokes which-key--echo-keystrokes-backup)
921 (when which-key--prefix-help-cmd-backup
922 (setq prefix-help-command which-key--prefix-help-cmd-backup))
923 (when which-key-show-remaining-keys
924 (remove-hook 'pre-command-hook #'which-key--lighter-restore))
925 (remove-hook 'pre-command-hook #'which-key--hide-popup)
926 (remove-hook 'window-size-change-functions
927 #'which-key--hide-popup-on-frame-size-change)
928 (which-key--stop-timer)))
929
930(defun which-key--init-buffer ()
931 "Initialize which-key buffer"
932 (unless (buffer-live-p which-key--buffer)
933 (setq which-key--buffer (get-buffer-create which-key-buffer-name))
934 (with-current-buffer which-key--buffer
935 ;; suppress confusing minibuffer message
936 (let (message-log-max)
937 (toggle-truncate-lines 1)
938 (message ""))
939 (setq-local cursor-type nil)
940 (setq-local cursor-in-non-selected-windows nil)
941 (setq-local mode-line-format nil)
942 (setq-local header-line-format nil)
943 (setq-local word-wrap nil)
944 (setq-local show-trailing-whitespace nil)
945 (run-hooks 'which-key-init-buffer-hook))))
946
947(defun which-key--setup-echo-keystrokes ()
948 "Reduce `echo-keystrokes' if necessary.
949It will interfere if set too high."
950 (when (and echo-keystrokes
951 (> (abs (- echo-keystrokes which-key-echo-keystrokes)) 0.000001))
952 (if (> which-key-idle-delay which-key-echo-keystrokes)
953 (setq echo-keystrokes which-key-echo-keystrokes)
954 (setq which-key-echo-keystrokes (/ (float which-key-idle-delay) 4)
955 echo-keystrokes which-key-echo-keystrokes))))
956
957(defun which-key-remove-default-unicode-chars ()
958 "Remove default unicode chars from settings.
959Use of `which-key-dont-use-unicode' is preferred to this
960function, but it's included here in case someone cannot set that
961variable early enough in their configuration, if they are using a
962starter kit for example."
963 (when (string-equal which-key-separator " → ")
964 (setq which-key-separator " : ")))
965
966;;; Default configuration functions for use by users.
967
968;;;###autoload
969(defun which-key-setup-side-window-right ()
970 "Set up side-window on right."
971 (interactive)
972 (setq which-key-popup-type 'side-window
973 which-key-side-window-location 'right
974 which-key-show-prefix 'top))
975
976;;;###autoload
977(defun which-key-setup-side-window-right-bottom ()
978 "Set up side-window on right if space allows.
979Otherwise, use bottom."
980 (interactive)
981 (setq which-key-popup-type 'side-window
982 which-key-side-window-location '(right bottom)
983 which-key-show-prefix 'top))
984
985;;;###autoload
986(defun which-key-setup-side-window-bottom ()
987 "Set up side-window that opens on bottom."
988 (interactive)
989 (which-key--setup-echo-keystrokes)
990 (setq which-key-popup-type 'side-window
991 which-key-side-window-location 'bottom
992 which-key-show-prefix 'echo))
993
994;;;###autoload
995(defun which-key-setup-minibuffer ()
996 "Set up minibuffer display.
997Do not use this setup if you use the paging commands. Instead use
998`which-key-setup-side-window-bottom', which is nearly identical
999but more functional."
1000 (interactive)
1001 (which-key--setup-echo-keystrokes)
1002 (setq which-key-popup-type 'minibuffer
1003 which-key-show-prefix 'left))
1004
1005;;; Helper functions to modify replacement lists.
1006
1007;;;###autoload
1008(defun which-key-add-keymap-based-replacements (keymap key replacement &rest more)
1009 "Replace the description of KEY using REPLACEMENT in KEYMAP.
1010KEY should take a format suitable for use in `kbd'. REPLACEMENT
1011should be a cons cell of the form \(STRING . COMMAND\) for each
1012REPLACEMENT, where STRING is the replacement string and COMMAND
1013is a symbol corresponding to the intended command to be
1014replaced. COMMAND can be nil if the binding corresponds to a key
1015prefix. An example is
1016
1017\(which-key-add-keymap-based-replacements global-map
1018 \"C-x w\" \\='\(\"Save as\" . write-file\)\).
1019
1020For backwards compatibility, REPLACEMENT can also be a string,
1021but the above format is preferred, and the option to use a string
1022for REPLACEMENT will eventually be removed."
1023 (declare (indent defun))
1024 (while key
1025 (let ((def
1026 (cond
1027 ((consp replacement) replacement)
1028 ((stringp replacement)
1029 (cons replacement
1030 (or (which-key--safe-lookup-key-description keymap key)
1031 (make-sparse-keymap))))
1032 (t
1033 (user-error "Replacement is neither a cons cell or a string")))))
1034 (define-key keymap (kbd key) def))
1035 (setq key (pop more)
1036 replacement (pop more))))
1037
1038;;;###autoload
1039(defun which-key-add-key-based-replacements
1040 (key-sequence replacement &rest more)
1041 "Replace the description of KEY-SEQUENCE with REPLACEMENT.
1042KEY-SEQUENCE is a string suitable for use in `kbd'. REPLACEMENT
1043may either be a string, as in
1044
1045\(which-key-add-key-based-replacements \"C-x 1\" \"maximize\"\)
1046
1047a cons of two strings as in
1048
1049\(which-key-add-key-based-replacements \"C-x 8\"
1050 \\='(\"unicode\" . \"Unicode keys\")\)
1051
1052or a function that takes a \(KEY . BINDING\) cons and returns a
1053replacement.
1054
1055In the second case, the second string is used to provide a longer
1056name for the keys under a prefix.
1057
1058MORE allows you to specifcy additional KEY REPLACEMENT pairs. All
1059replacements are added to `which-key-replacement-alist'."
1060 ;; TODO: Make interactive
1061 (while key-sequence
1062 ;; normalize key sequences before adding
1063 (let ((key-seq (key-description (kbd key-sequence)))
1064 (replace (or (and (functionp replacement) replacement)
1065 (car-safe replacement)
1066 replacement)))
1067 (push (cons (cons (concat "\\`" (regexp-quote key-seq) "\\'") nil)
1068 (if (functionp replace) replace (cons nil replace)))
1069 which-key-replacement-alist)
1070 (when (and (not (functionp replacement)) (consp replacement))
1071 (push (cons key-seq (cdr-safe replacement))
1072 which-key--prefix-title-alist)))
1073 (setq key-sequence (pop more) replacement (pop more))))
1074(put 'which-key-add-key-based-replacements 'lisp-indent-function 'defun)
1075
1076;;;###autoload
1077(defun which-key-add-major-mode-key-based-replacements
1078 (mode key-sequence replacement &rest more)
1079 "Functions like `which-key-add-key-based-replacements'.
1080The difference is that MODE specifies the `major-mode' that must
1081be active for KEY-SEQUENCE and REPLACEMENT (MORE contains
1082addition KEY-SEQUENCE REPLACEMENT pairs) to apply."
1083 (declare (indent defun))
1084 ;; TODO: Make interactive
1085 (when (not (symbolp mode))
1086 (error "`%S' should be a symbol corresponding to a value of major-mode" mode))
1087 (let ((mode-alist
1088 (or (cdr-safe (assq mode which-key-replacement-alist)) (list)))
1089 (title-mode-alist
1090 (or (cdr-safe (assq mode which-key--prefix-title-alist)) (list))))
1091 (while key-sequence
1092 ;; normalize key sequences before adding
1093 (let ((key-seq (key-description (kbd key-sequence)))
1094 (replace (or (and (functionp replacement) replacement)
1095 (car-safe replacement)
1096 replacement)))
1097 (push (cons (cons (concat "\\`" (regexp-quote key-seq) "\\'") nil)
1098 (if (functionp replace) replace (cons nil replace)))
1099 mode-alist)
1100 (when (and (not (functionp replacement)) (consp replacement))
1101 (push (cons key-seq (cdr-safe replacement))
1102 title-mode-alist)))
1103 (setq key-sequence (pop more) replacement (pop more)))
1104 (if (assq mode which-key-replacement-alist)
1105 (setcdr (assq mode which-key-replacement-alist) mode-alist)
1106 (push (cons mode mode-alist) which-key-replacement-alist))
1107 (if (assq mode which-key--prefix-title-alist)
1108 (setcdr (assq mode which-key--prefix-title-alist) title-mode-alist)
1109 (push (cons mode title-mode-alist) which-key--prefix-title-alist))))
1110
1111(defun which-key-define-key-recursively (map key def &optional at-root)
1112 "Recursively bind KEY in MAP to DEF on every level of MAP except the first.
1113If AT-ROOT is non-nil the binding is also placed at the root of MAP."
1114 (when at-root (define-key map key def))
1115 (map-keymap
1116 (lambda (_ev df)
1117 (when (keymapp df)
1118 (which-key-define-key-recursively df key def t)))
1119 map))
1120
1121;;; Functions for computing window sizes
1122
1123(defun which-key--text-width-to-total (text-width)
1124 "Convert window TEXT-WIDTH to window total-width.
1125TEXT-WIDTH is the desired text width of the window. The function
1126calculates what total width is required for a window in the
1127selected to have a text-width of TEXT-WIDTH columns. The
1128calculation considers possible fringes and scroll bars. This
1129function assumes that the desired window has the same character
1130width as the frame."
1131 (let ((char-width (frame-char-width)))
1132 (+ text-width
1133 (/ (frame-fringe-width) char-width)
1134 (/ (frame-scroll-bar-width) char-width)
1135 (if (which-key--char-enlarged-p) 1 0)
1136 ;; add padding to account for possible wide (unicode) characters
1137 3)))
1138
1139(defun which-key--total-width-to-text (total-width)
1140 "Convert window TOTAL-WIDTH to window text-width.
1141TOTAL-WIDTH is the desired total width of the window. The function calculates
1142what text width fits such a window. The calculation considers possible fringes
1143and scroll bars. This function assumes that the desired window has the same
1144character width as the frame."
1145 (let ((char-width (frame-char-width)))
1146 (- total-width
1147 (/ (frame-fringe-width) char-width)
1148 (/ (frame-scroll-bar-width) char-width)
1149 (if (which-key--char-enlarged-p) 1 0)
1150 ;; add padding to account for possible wide (unicode) characters
1151 3)))
1152
1153(defun which-key--char-enlarged-p (&optional _frame)
1154 (> (frame-char-width)
1155 (/ (float (frame-pixel-width)) (window-total-width (frame-root-window)))))
1156
1157(defun which-key--char-reduced-p (&optional _frame)
1158 (< (frame-char-width)
1159 (/ (float (frame-pixel-width)) (window-total-width (frame-root-window)))))
1160
1161(defun which-key--char-exact-p (&optional _frame)
1162 (= (frame-char-width)
1163 (/ (float (frame-pixel-width)) (window-total-width (frame-root-window)))))
1164
1165(defun which-key--width-or-percentage-to-width (width-or-percentage)
1166 "Return window total width.
1167If WIDTH-OR-PERCENTAGE is a whole number, return it unchanged. Otherwise, it
1168should be a percentage (a number between 0 and 1) out of the frame's width.
1169More precisely, it should be a percentage out of the frame's root window's
1170total width."
1171 (if (natnump width-or-percentage)
1172 width-or-percentage
1173 (round (* width-or-percentage (window-total-width (frame-root-window))))))
1174
1175(defun which-key--height-or-percentage-to-height (height-or-percentage)
1176 "Return window total height.
1177If HEIGHT-OR-PERCENTAGE is a whole number, return it unchanged. Otherwise, it
1178should be a percentage (a number between 0 and 1) out of the frame's height.
1179More precisely, it should be a percentage out of the frame's root window's
1180total height."
1181 (if (natnump height-or-percentage)
1182 height-or-percentage
1183 (round (* height-or-percentage (window-total-height (frame-root-window))))))
1184
1185(defun which-key--frame-size-changed-p ()
1186 "Non-nil if a change in frame size is detected."
1187 (let ((new-size (cons (frame-width) (frame-height))))
1188 (cond ((null which-key--previous-frame-size)
1189 (setq which-key--previous-frame-size new-size)
1190 nil)
1191 ((not (equal which-key--previous-frame-size new-size))
1192 (setq which-key--previous-frame-size new-size)))))
1193
1194;;; Show/hide which-key buffer
1195
1196(defun which-key--hide-popup ()
1197 "This function is called to hide the which-key buffer."
1198 (unless (or which-key-persistent-popup
1199 (member real-this-command which-key--paging-functions))
1200 (setq which-key--last-try-2-loc nil)
1201 (setq which-key--pages-obj nil)
1202 (setq which-key--automatic-display nil)
1203 (setq which-key--prior-show-keymap-args nil)
1204 (when (and which-key-idle-secondary-delay which-key--secondary-timer-active)
1205 (which-key--start-timer))
1206 (which-key--lighter-restore)
1207 (which-key--hide-popup-ignore-command)))
1208
1209(defun which-key--hide-popup-ignore-command ()
1210 "`which-key--hide-popup' without the check of `real-this-command'."
1211 (cl-case which-key-popup-type
1212 ;; Not necessary to hide minibuffer
1213 ;; (minibuffer (which-key--hide-buffer-minibuffer))
1214 (side-window (which-key--hide-buffer-side-window))
1215 (frame (which-key--hide-buffer-frame))
1216 (custom (funcall which-key-custom-hide-popup-function))))
1217
1218(defun which-key--hide-popup-on-frame-size-change (&optional _)
1219 "Hide which-key popup if the frame is resized (to trigger a new popup)."
1220 (when (which-key--frame-size-changed-p)
1221 (which-key--hide-popup)))
1222
1223(defun which-key--hide-buffer-side-window ()
1224 "Hide which-key buffer when side-window popup is used."
1225 (when (buffer-live-p which-key--buffer)
1226 ;; in case which-key buffer was shown in an existing window, `quit-window'
1227 ;; will re-show the previous buffer, instead of closing the window
1228 (quit-windows-on which-key--buffer)
1229 (when (and which-key-preserve-window-configuration
1230 which-key--saved-window-configuration)
1231 (set-window-configuration which-key--saved-window-configuration)
1232 (setq which-key--saved-window-configuration nil))))
1233
1234(defun which-key--hide-buffer-frame ()
1235 "Hide which-key buffer when frame popup is used."
1236 (when (frame-live-p which-key--frame)
1237 (delete-frame which-key--frame)))
1238
1239(defun which-key--popup-showing-p ()
1240 (and (bufferp which-key--buffer)
1241 (or (window-live-p (get-buffer-window which-key--buffer))
1242 (let ((window (get-buffer-window which-key--buffer t)))
1243 (and (window-live-p window)
1244 (frame-visible-p (window-frame window)))))))
1245
1246(defun which-key--show-popup (act-popup-dim)
1247 "Show the which-key buffer.
1248ACT-POPUP-DIM includes the dimensions, (height . width) of the
1249buffer text to be displayed in the popup. Return nil if no window
1250is shown, or if there is no need to start the closing timer."
1251 (when (and (> (car act-popup-dim) 0)
1252 (> (cdr act-popup-dim) 0))
1253 (cl-case which-key-popup-type
1254 ;; Not called for minibuffer
1255 ;; (minibuffer (which-key--show-buffer-minibuffer act-popup-dim))
1256 (side-window (which-key--show-buffer-side-window act-popup-dim))
1257 (frame (which-key--show-buffer-frame act-popup-dim))
1258 (custom (funcall which-key-custom-show-popup-function act-popup-dim)))))
1259
1260(defun which-key--fit-buffer-to-window-horizontally
1261 (&optional window &rest params)
1262 "Slightly modified version of `fit-buffer-to-window'.
1263Use &rest params because `fit-buffer-to-window' has a different
1264call signature in different emacs versions"
1265 (let ((fit-window-to-buffer-horizontally t)
1266 (window-min-height 1))
1267 (apply #'fit-window-to-buffer window params)))
1268
1269(defun which-key--show-buffer-side-window (act-popup-dim)
1270 "Show which-key buffer when popup type is side-window."
1271 (when (and which-key-preserve-window-configuration
1272 (not which-key--saved-window-configuration))
1273 (setq which-key--saved-window-configuration (current-window-configuration)))
1274 (let* ((height (car act-popup-dim))
1275 (width (cdr act-popup-dim))
1276 (alist
1277 (if which-key-allow-imprecise-window-fit
1278 `((window-width . ,(which-key--text-width-to-total width))
1279 (window-height . ,height)
1280 (side . ,which-key-side-window-location)
1281 (slot . ,which-key-side-window-slot))
1282 `((window-width . which-key--fit-buffer-to-window-horizontally)
1283 (window-height . (lambda (w) (fit-window-to-buffer w nil 1)))
1284 (side . ,which-key-side-window-location)
1285 (slot . ,which-key-side-window-slot)))))
1286 (which-key--debug-message "Allow imprecise fit: %s
1287Display window alist: %s"
1288 which-key-allow-imprecise-window-fit
1289 alist)
1290 ;; Previously used `display-buffer-in-major-side-window' here, but
1291 ;; apparently that is meant to be an internal function. See emacs bug #24828
1292 ;; and advice given there.
1293 (cond
1294 ((eq which-key--multiple-locations t)
1295 ;; possibly want to switch sides in this case so we can't reuse the window
1296 (delete-windows-on which-key--buffer)
1297 (display-buffer-in-side-window which-key--buffer alist))
1298 ((get-buffer-window which-key--buffer)
1299 (display-buffer-reuse-window which-key--buffer alist))
1300 (t
1301 (display-buffer-in-side-window which-key--buffer alist)))))
1302
1303(defun which-key--show-buffer-frame (act-popup-dim)
1304 "Show which-key buffer when popup type is frame."
1305 (let* (;(orig-window (selected-window))
1306 (frame-height (+ (car act-popup-dim)
1307 (if (with-current-buffer which-key--buffer
1308 mode-line-format)
1309 1
1310 0)))
1311 ;; without adding 2, frame sometimes isn't wide enough for the buffer.
1312 ;; this is probably because of the fringes. however, setting fringes
1313 ;; sizes to 0 (instead of adding 2) didn't always make the frame wide
1314 ;; enough. don't know why it is so.
1315 (frame-width (+ (cdr act-popup-dim) 2))
1316 (new-window (if (and (frame-live-p which-key--frame)
1317 (eq which-key--buffer
1318 (window-buffer
1319 (frame-root-window which-key--frame))))
1320 (which-key--show-buffer-reuse-frame
1321 frame-height frame-width)
1322 (which-key--show-buffer-new-frame
1323 frame-height frame-width))))
1324 (when new-window
1325 ;; display successful
1326 (setq which-key--frame (window-frame new-window))
1327 new-window)))
1328
1329(defun which-key--show-buffer-new-frame (frame-height frame-width)
1330 "Helper for `which-key--show-buffer-frame'."
1331 (let* ((frame-params `((height . ,frame-height)
1332 (width . ,frame-width)
1333 ;; tell the window manager to respect the given sizes
1334 (user-size . t)
1335 ;; which-key frame doesn't need a minibuffer
1336 (minibuffer . nil)
1337 (name . "which-key")
1338 ;; no need for scroll bars in which-key frame
1339 (vertical-scroll-bars . nil)
1340 ;; (left-fringe . 0)
1341 ;; (right-fringe . 0)
1342 ;; (right-divider-width . 0)
1343 ;; make sure frame is visible
1344 (visibility . t)))
1345 (alist `((pop-up-frame-parameters . ,frame-params)))
1346 (orig-frame (selected-frame))
1347 (new-window (display-buffer-pop-up-frame which-key--buffer alist)))
1348 (when new-window
1349 ;; display successful
1350 (redirect-frame-focus (window-frame new-window) orig-frame)
1351 new-window)))
1352
1353(defun which-key--show-buffer-reuse-frame (frame-height frame-width)
1354 "Helper for `which-key--show-buffer-frame'."
1355 (let ((window
1356 (display-buffer-reuse-window
1357 which-key--buffer `((reusable-frames . ,which-key--frame)))))
1358 (when window
1359 ;; display successful
1360 (set-frame-size (window-frame window) frame-width frame-height)
1361 window)))
1362
1363;;; Max dimension of available window functions
1364
1365(defun which-key--popup-max-dimensions ()
1366 "Return maximum dimension available for popup.
1367Dimension functions should return the maximum possible (height
1368. width) of the intended popup. SELECTED-WINDOW-WIDTH is the
1369width of currently active window, not the which-key buffer
1370window."
1371 (cl-ecase which-key-popup-type
1372 (minibuffer (which-key--minibuffer-max-dimensions))
1373 (side-window (which-key--side-window-max-dimensions))
1374 (frame (which-key--frame-max-dimensions))
1375 (custom (funcall which-key-custom-popup-max-dimensions-function
1376 (window-width)))))
1377
1378(defun which-key--minibuffer-max-dimensions ()
1379 "Return max-dimensions of minibuffer (height . width).
1380Measured in lines and characters respectively."
1381 (cons
1382 ;; height
1383 (if (floatp max-mini-window-height)
1384 (floor (* (frame-text-lines)
1385 max-mini-window-height))
1386 max-mini-window-height)
1387 ;; width
1388 (max 0 (- (frame-text-cols) which-key-unicode-correction))))
1389
1390(defun which-key--side-window-max-dimensions ()
1391 "Return max-dimensions of the side-window popup.
1392The return value should be (height . width) in lines and
1393characters respectively."
1394 (cons
1395 ;; height
1396 (if (member which-key-side-window-location '(left right))
1397 ;; 1 is a kludge to make sure there is no overlap
1398 (- (frame-height) (window-text-height (minibuffer-window)) 1)
1399 ;; (window-mode-line-height which-key--window))
1400 ;; FIXME: change to something like
1401 ;; (min which-*-height (calculate-max-height))
1402 (which-key--height-or-percentage-to-height
1403 which-key-side-window-max-height))
1404 ;; width
1405 (max 0
1406 (- (if (memq which-key-side-window-location '(left right))
1407 (which-key--total-width-to-text
1408 (which-key--width-or-percentage-to-width
1409 which-key-side-window-max-width))
1410 (which-key--total-width-to-text
1411 (which-key--width-or-percentage-to-width
1412 1.0)))
1413 which-key-unicode-correction))))
1414
1415(defun which-key--frame-max-dimensions ()
1416 "Return max-dimensions of the frame popup.
1417The return value should be (height . width) in lines and
1418characters respectively."
1419 (cons which-key-frame-max-height which-key-frame-max-width))
1420
1421;;; Sorting functions
1422
1423(defun which-key--string< (a b &optional alpha)
1424 (let ((da (downcase a))
1425 (db (downcase b)))
1426 (cond
1427 ((and alpha (not which-key-sort-uppercase-first))
1428 (if (string-equal da db)
1429 (not (string-lessp a b))
1430 (string-lessp da db)))
1431 ((and alpha which-key-sort-uppercase-first)
1432 (if (string-equal da db)
1433 (string-lessp a b)
1434 (string-lessp da db)))
1435 ((not which-key-sort-uppercase-first)
1436 (let ((aup (not (string-equal da a)))
1437 (bup (not (string-equal db b))))
1438 (if (eq aup bup)
1439 (string-lessp a b)
1440 bup)))
1441 (t (string-lessp a b)))))
1442
1443(defun which-key--key-description< (a b &optional alpha)
1444 "Key sorting function.
1445Used for `which-key-key-order' and `which-key-key-order-alpha'."
1446 (save-match-data
1447 (let* ((a (which-key--extract-key a))
1448 (b (which-key--extract-key b))
1449 (rngrgxp "^\\([^ ]+\\) \\.\\. [^ ]+")
1450 (a (if (string-match rngrgxp a) (match-string 1 a) a))
1451 (b (if (string-match rngrgxp b) (match-string 1 b) b))
1452 (aem? (string-equal a ""))
1453 (bem? (string-equal b ""))
1454 (a1? (= 1 (length a)))
1455 (b1? (= 1 (length b)))
1456 (srgxp "^\\(RET\\|SPC\\|TAB\\|DEL\\|LFD\\|ESC\\|NUL\\)")
1457 (asp? (string-match-p srgxp a))
1458 (bsp? (string-match-p srgxp b))
1459 (prrgxp "^\\(M\\|C\\|S\\|A\\|H\\|s\\)-")
1460 (apr? (string-match-p prrgxp a))
1461 (bpr? (string-match-p prrgxp b))
1462 (afn? (string-match-p "<f[0-9]+>" a))
1463 (bfn? (string-match-p "<f[0-9]+>" b)))
1464 (cond ((or aem? bem?) (and aem? (not bem?)))
1465 ((and asp? bsp?)
1466 (if (string-equal (substring a 0 3) (substring b 0 3))
1467 (which-key--key-description<
1468 (substring a 3) (substring b 3) alpha)
1469 (which-key--string< a b alpha)))
1470 ((or asp? bsp?) asp?)
1471 ((and a1? b1?) (which-key--string< a b alpha))
1472 ((or a1? b1?) a1?)
1473 ((and afn? bfn?)
1474 (< (string-to-number
1475 (replace-regexp-in-string "<f\\([0-9]+\\)>" "\\1" a))
1476 (string-to-number
1477 (replace-regexp-in-string "<f\\([0-9]+\\)>" "\\1" b))))
1478 ((or afn? bfn?) afn?)
1479 ((and apr? bpr?)
1480 (if (string-equal (substring a 0 2) (substring b 0 2))
1481 (which-key--key-description<
1482 (substring a 2) (substring b 2) alpha)
1483 (which-key--string< a b alpha)))
1484 ((or apr? bpr?) apr?)
1485 (t (which-key--string< a b alpha))))))
1486
1487(defsubst which-key-key-order-alpha (acons bcons)
1488 "Order key descriptions A and B.
1489Order is lexicographic within a \"class\", where the classes and
1490the ordering of classes are listed below.
1491
1492special (SPC,TAB,...) < single char < mod (C-,M-,...) < other.
1493Sorts single characters alphabetically with lowercase coming
1494before upper."
1495 (which-key--key-description< (car acons) (car bcons) t))
1496
1497(defsubst which-key-key-order (acons bcons)
1498 "Order key descriptions A and B.
1499Order is lexicographic within a \"class\", where the classes and
1500the ordering of classes are listed below.
1501
1502special (SPC,TAB,...) < single char < mod (C-,M-,...) < other."
1503 (which-key--key-description< (car acons) (car bcons)))
1504
1505(defsubst which-key-description-order (acons bcons)
1506 "Order descriptions of A and B.
1507Uses `string-lessp' after applying lowercase."
1508 (string-lessp (downcase (cdr acons)) (downcase (cdr bcons))))
1509
1510(defsubst which-key--group-p (description)
1511 (or (string-equal description "prefix")
1512 (string-match-p "^group:" description)
1513 (keymapp (intern description))))
1514
1515(defun which-key-prefix-then-key-order (acons bcons)
1516 "Order prefixes before non-prefixes.
1517Within these categories order using `which-key-key-order'."
1518 (let ((apref? (which-key--group-p (cdr acons)))
1519 (bpref? (which-key--group-p (cdr bcons))))
1520 (if (not (eq apref? bpref?))
1521 (and (not apref?) bpref?)
1522 (which-key-key-order acons bcons))))
1523
1524(defun which-key-prefix-then-key-order-reverse (acons bcons)
1525 "Order prefixes before non-prefixes.
1526Within these categories order using `which-key-key-order'."
1527 (let ((apref? (which-key--group-p (cdr acons)))
1528 (bpref? (which-key--group-p (cdr bcons))))
1529 (if (not (eq apref? bpref?))
1530 (and apref? (not bpref?))
1531 (which-key-key-order acons bcons))))
1532
1533(defun which-key-local-then-key-order (acons bcons)
1534 "Order local bindings before non-local ones.
1535Within these categories order using `which-key-key-order'."
1536 (let ((aloc? (which-key--local-binding-p acons))
1537 (bloc? (which-key--local-binding-p bcons)))
1538 (if (not (eq aloc? bloc?))
1539 (and aloc? (not bloc?))
1540 (which-key-key-order acons bcons))))
1541
1542;;; Functions for retrieving and formatting keys
1543
1544(defsubst which-key--string-width (maybe-string)
1545 "If MAYBE-STRING is a string use `which-key--string-width' o/w return 0."
1546 (if (stringp maybe-string) (string-width maybe-string) 0))
1547
1548(defsubst which-key--butlast-string (str)
1549 (string-join (butlast (split-string str)) " "))
1550
1551(defun which-key--match-replacement (key-binding replacement)
1552 ;; these are mode specific ones to ignore. The mode specific case is
1553 ;; handled in the selection of alist
1554 (when (and (consp key-binding) (not (symbolp (car replacement))))
1555 (let ((key-regexp (caar replacement))
1556 (binding-regexp (cdar replacement))
1557 (case-fold-search nil))
1558 (and (or (null key-regexp)
1559 (string-match-p key-regexp
1560 (car key-binding)))
1561 (or (null binding-regexp)
1562 (string-match-p binding-regexp
1563 (cdr key-binding)))))))
1564
1565(defsubst which-key--replace-in-binding (key-binding repl)
1566 (cond ((or (not (consp repl)) (null (cdr repl)))
1567 key-binding)
1568 ((functionp (cdr repl))
1569 (funcall (cdr repl) key-binding))
1570 ((consp (cdr repl))
1571 (cons
1572 (cond ((and (caar repl) (cadr repl))
1573 (replace-regexp-in-string
1574 (caar repl) (cadr repl) (car key-binding) t))
1575 ((cadr repl) (cadr repl))
1576 (t (car key-binding)))
1577 (cond ((and (cdar repl) (cddr repl))
1578 (replace-regexp-in-string
1579 (cdar repl) (cddr repl) (cdr key-binding) t))
1580 ((cddr repl) (cddr repl))
1581 (t (cdr key-binding)))))))
1582
1583(defun which-key--replace-in-repl-list-once (key-binding repls)
1584 (cl-dolist (repl repls)
1585 (when (which-key--match-replacement key-binding repl)
1586 (cl-return `(replaced . ,(which-key--replace-in-binding key-binding repl))))))
1587
1588(defun which-key--replace-in-repl-list-many (key-binding repls)
1589 (let (found)
1590 (dolist (repl repls)
1591 (when (which-key--match-replacement key-binding repl)
1592 (setq found t)
1593 (setq key-binding (which-key--replace-in-binding key-binding repl))))
1594 (when found `(replaced . ,key-binding))))
1595
1596(defun which-key--maybe-replace (key-binding)
1597 "Use `which-key--replacement-alist' to maybe replace KEY-BINDING.
1598KEY-BINDING is a cons cell of the form \(KEY . BINDING\) each of
1599which are strings. KEY is of the form produced by `key-binding'."
1600 (let* ((replacer (if which-key-allow-multiple-replacements
1601 #'which-key--replace-in-repl-list-many
1602 #'which-key--replace-in-repl-list-once)))
1603 (pcase
1604 (apply replacer
1605 (list key-binding
1606 (cdr-safe (assq major-mode which-key-replacement-alist))))
1607 (`(replaced . ,repl)
1608 (if which-key-allow-multiple-replacements
1609 (pcase (apply replacer (list repl which-key-replacement-alist))
1610 (`(replaced . ,repl) repl)
1611 ('() repl))
1612 repl))
1613 ('()
1614 (pcase (apply replacer (list key-binding which-key-replacement-alist))
1615 (`(replaced . ,repl) repl)
1616 ('() key-binding))))))
1617
1618(defsubst which-key--current-key-list (&optional key-str)
1619 (append (listify-key-sequence (which-key--current-prefix))
1620 (when key-str
1621 (listify-key-sequence (kbd key-str)))))
1622
1623(defsubst which-key--current-key-string (&optional key-str)
1624 (key-description (which-key--current-key-list key-str)))
1625
1626(defun which-key--local-binding-p (keydesc)
1627 (eq (which-key--safe-lookup-key-description
1628 (current-local-map)
1629 (which-key--current-key-string (car keydesc)))
1630 (intern (cdr keydesc))))
1631
1632(defun which-key--map-binding-p (map keydesc)
1633 "Does MAP contain KEYDESC = (key . binding)?"
1634 (or
1635 (when (bound-and-true-p evil-state)
1636 (let ((lookup
1637 (which-key--safe-lookup-key-description
1638 map
1639 (which-key--current-key-string
1640 (format "<%s-state> %s" evil-state (car keydesc))))))
1641 (or (eq lookup (intern (cdr keydesc)))
1642 (and (keymapp lookup) (string= (cdr keydesc) "Prefix Command")))))
1643 (let ((lookup
1644 (which-key--safe-lookup-key-description
1645 map (which-key--current-key-string (car keydesc)))))
1646 (or (eq lookup (intern (cdr keydesc)))
1647 (and (keymapp lookup) (string= (cdr keydesc) "Prefix Command"))))))
1648
1649(defun which-key--maybe-get-prefix-title (keys)
1650 "KEYS is a string produced by `key-description'.
1651A title is possibly returned using
1652`which-key--prefix-title-alist'. An empty string is returned if
1653no title exists."
1654 (cond
1655 ((not (string-equal keys ""))
1656 (let* ((title-res
1657 (cdr-safe (assoc-string keys which-key--prefix-title-alist)))
1658 (repl-res
1659 (cdr-safe (which-key--maybe-replace (cons keys ""))))
1660 (binding (key-binding (kbd keys)))
1661 (alternate (when (and binding (symbolp binding))
1662 (symbol-name binding))))
1663 (cond (title-res title-res)
1664 ((not (string-empty-p repl-res)) repl-res)
1665 ((and (eq which-key-show-prefix 'echo) alternate)
1666 alternate)
1667 ((and (member which-key-show-prefix '(bottom top mode-line))
1668 (eq which-key-side-window-location 'bottom)
1669 echo-keystrokes)
1670 (if alternate alternate
1671 (concat "Following " keys)))
1672 (t ""))))
1673 (t "")))
1674
1675(defun which-key--propertize (string &rest properties)
1676 "Version of `propertize' that checks type of STRING."
1677 (when (stringp string)
1678 (apply #'propertize string properties)))
1679
1680(defun which-key--propertize-key (key)
1681 "Add a face to KEY.
1682If KEY contains any \"special keys\" defined in
1683`which-key-special-keys' then truncate and add the corresponding
1684`which-key-special-key-face'."
1685 (let ((key-w-face (which-key--propertize key 'face 'which-key-key-face))
1686 (regexp (concat "\\("
1687 (mapconcat #'identity which-key-special-keys
1688 "\\|")
1689 "\\)"))
1690 (case-fold-search nil))
1691 (save-match-data
1692 (if (and which-key-special-keys
1693 (string-match regexp key))
1694 (let ((beg (match-beginning 0)) (end (match-end 0)))
1695 (concat (substring key-w-face 0 beg)
1696 (which-key--propertize (substring key-w-face beg (1+ beg))
1697 'face 'which-key-special-key-face)
1698 (substring key-w-face end
1699 (which-key--string-width key-w-face))))
1700 key-w-face))))
1701
1702(defsubst which-key--truncate-description (desc avl-width)
1703 "Truncate DESC description to `which-key-max-description-length'."
1704 (let* ((max which-key-max-description-length)
1705 (max (cl-etypecase max
1706 (null nil)
1707 (integer max)
1708 (float (truncate (* max avl-width)))
1709 (function (let ((val (funcall max avl-width)))
1710 (if (floatp val) (truncate val) val))))))
1711 (if (and max (> (length desc) max))
1712 (let ((dots (and (not (equal which-key-ellipsis ""))
1713 (which-key--propertize
1714 which-key-ellipsis 'face
1715 (get-text-property (1- (length desc)) 'face desc)))))
1716 (if dots
1717 (concat (substring desc 0 (- max (length dots))) dots)
1718 (substring desc 0 max)))
1719 desc)))
1720
1721(defun which-key--highlight-face (description)
1722 "Return the highlight face for DESCRIPTION if it has one."
1723 (let (face)
1724 (dolist (el which-key-highlighted-command-list)
1725 (unless face
1726 (cond ((consp el)
1727 (when (string-match-p (car el) description)
1728 (setq face (cdr el))))
1729 ((stringp el)
1730 (when (string-match-p el description)
1731 (setq face 'which-key-highlighted-command-face)))
1732 (t
1733 (message "which-key: warning: element %s of \
1734which-key-highlighted-command-list is not a string or a cons
1735cell" el)))))
1736 face))
1737
1738(defun which-key--propertize-description
1739 (description group local hl-face &optional original-description)
1740 "Add face to DESCRIPTION.
1741The face chosen depends on whether the description represents a
1742group or a command. Also make some minor adjustments to the
1743description string, like removing a \"group:\" prefix.
1744
1745ORIGINAL-DESCRIPTION is the description given by
1746`describe-buffer-bindings'."
1747 (when description
1748 (let* ((desc description)
1749 (desc (if (string-match-p "^group:" desc)
1750 (substring desc 6) desc))
1751 (desc (if group (concat which-key-prefix-prefix desc) desc)))
1752 (make-text-button
1753 desc nil
1754 'face (cond (hl-face hl-face)
1755 (group 'which-key-group-description-face)
1756 (local 'which-key-local-map-description-face)
1757 (t 'which-key-command-description-face))
1758 'help-echo (cond
1759 ((and original-description
1760 (fboundp (intern original-description))
1761 (documentation (intern original-description))
1762 ;; tooltip-mode doesn't exist in emacs-nox
1763 (boundp 'tooltip-mode) tooltip-mode)
1764 (documentation (intern original-description)))
1765 ((and original-description
1766 (fboundp (intern original-description))
1767 (documentation (intern original-description))
1768 (let* ((doc (documentation
1769 (intern original-description)))
1770 (str (replace-regexp-in-string "\n" " " doc))
1771 (max (floor (* (frame-width) 0.8))))
1772 (if (> (length str) max)
1773 (concat (substring str 0 max) "...")
1774 str)))))))))
1775
1776(defun which-key--extract-key (key-str)
1777 "Pull the last key (or key range) out of KEY-STR."
1778 (save-match-data
1779 (let ((key-range-regexp "\\`.*\\([^ \t]+ \\.\\. [^ \t]+\\)\\'"))
1780 (if (string-match key-range-regexp key-str)
1781 (match-string 1 key-str)
1782 (car (last (split-string key-str " ")))))))
1783
1784(defun which-key--maybe-add-docstring (current original)
1785 "Maybe concat a docstring to CURRENT and return result.
1786Specifically, do this if ORIGINAL is a command with a docstring
1787and `which-key-show-docstrings' is non-nil. If
1788`which-key-show-docstrings' is the symbol docstring-only, just
1789return the docstring."
1790 (let* ((orig-sym (intern original))
1791 (doc (when (commandp orig-sym)
1792 (documentation orig-sym)))
1793 (doc (when doc
1794 (replace-regexp-in-string
1795 (concat "^\\(?::"
1796 (regexp-opt '("around" "override"
1797 "after" "after-until" "after-while"
1798 "before" "before-until" "before-while"
1799 "filter-args" "filter-return"))
1800 " advice: [^\n]+\n"
1801 "\\)+\n")
1802 "" doc)))
1803 (docstring (when doc
1804 (which-key--propertize (car (split-string doc "\n"))
1805 'face 'which-key-docstring-face))))
1806 (cond ((not (and which-key-show-docstrings docstring))
1807 current)
1808 ((eq which-key-show-docstrings 'docstring-only)
1809 docstring)
1810 (t
1811 (format "%s %s" current docstring)))))
1812
1813(defun which-key--format-and-replace (unformatted &optional preserve-full-key)
1814 "Make list of key bindings with separators and descriptions.
1815Take a list of (key . desc) cons cells in UNFORMATTED, add
1816faces and perform replacements according to the three replacement
1817alists. Returns a list (key separator description)."
1818 (let ((sep-w-face
1819 (which-key--propertize which-key-separator
1820 'face 'which-key-separator-face))
1821 (local-map (current-local-map))
1822 (avl-width (cdr (which-key--popup-max-dimensions)))
1823 new-list)
1824 (dolist (key-binding unformatted)
1825 (let* ((keys (car key-binding))
1826 (orig-desc (cdr key-binding))
1827 (group (which-key--group-p orig-desc))
1828 (local (eq (which-key--safe-lookup-key-description
1829 local-map keys)
1830 (intern orig-desc)))
1831 (hl-face (which-key--highlight-face orig-desc))
1832 (key-binding (which-key--maybe-replace key-binding))
1833 (final-desc (which-key--propertize-description
1834 (cdr key-binding) group local hl-face orig-desc)))
1835 (when final-desc
1836 (setq final-desc
1837 (which-key--truncate-description
1838 (which-key--maybe-add-docstring final-desc orig-desc)
1839 avl-width)))
1840 (when (consp key-binding)
1841 (push
1842 (list (which-key--propertize-key
1843 (if preserve-full-key
1844 (car key-binding)
1845 (which-key--extract-key (car key-binding))))
1846 sep-w-face
1847 final-desc)
1848 new-list))))
1849 (nreverse new-list)))
1850
1851(defun which-key--compute-binding (binding)
1852 "Replace BINDING with remapped binding if it exists.
1853Requires `which-key-compute-remaps' to be non-nil."
1854 (copy-sequence (symbol-name
1855 (or (and which-key-compute-remaps
1856 (command-remapping binding))
1857 binding))))
1858
1859(defun which-key--get-menu-item-binding (def)
1860 "Retrieve binding for menu-item"
1861 ;; see `keymap--menu-item-binding'
1862 (let* ((binding (nth 2 def))
1863 (plist (nthcdr 3 def))
1864 (filter (plist-get plist :filter)))
1865 (if filter (funcall filter binding) binding)))
1866
1867(defun which-key--get-keymap-bindings-1
1868 (keymap start &optional prefix filter all ignore-commands)
1869 "See `which-key--get-keymap-bindings'."
1870 (let ((bindings start)
1871 (prefix-map (if prefix (lookup-key keymap prefix) keymap)))
1872 (when (keymapp prefix-map)
1873 (map-keymap
1874 (lambda (ev def)
1875 (let* ((key (vconcat prefix (list ev)))
1876 (key-desc (key-description key)))
1877 (cond
1878 ((assoc key-desc bindings))
1879 ((and (listp ignore-commands) (symbolp def) (memq def ignore-commands)))
1880 ((or (string-match-p
1881 which-key--ignore-non-evil-keys-regexp key-desc)
1882 (eq ev 'menu-bar)))
1883 ((and (keymapp def)
1884 (string-match-p which-key--evil-keys-regexp key-desc)))
1885 ((and (keymapp def)
1886 (or all
1887 ;; event 27 is escape, so this will pick up meta
1888 ;; bindings and hopefully not too much more
1889 (eql ev 27)))
1890 (setq bindings
1891 (which-key--get-keymap-bindings-1
1892 keymap bindings key nil all ignore-commands)))
1893 (def
1894 (let* ((def (if (eq 'menu-item (car-safe def))
1895 (which-key--get-menu-item-binding def)
1896 def))
1897 (binding
1898 (cons key-desc
1899 (cond
1900 ((symbolp def) (which-key--compute-binding def))
1901 ((keymapp def) "prefix")
1902 ((functionp def)
1903 (cond
1904 ((eq 'lambda (car-safe def)) "lambda")
1905 ((eq 'closure (car-safe def)) "closure")
1906 (t "function")))
1907 ((stringp def) def)
1908 ((vectorp def) (key-description def))
1909 ((and (consp def)
1910 ;; looking for (STRING . DEFN)
1911 (stringp (car def)))
1912 (concat (when (keymapp (cdr-safe def))
1913 "group:")
1914 (car def)))
1915 (t "unknown")))))
1916 (when (or (null filter)
1917 (and (functionp filter)
1918 (funcall filter binding)))
1919 (push binding bindings)))))))
1920 prefix-map))
1921 bindings))
1922
1923(defun which-key--get-keymap-bindings
1924 (keymap &optional start prefix filter all evil)
1925 "Retrieve top-level bindings from KEYMAP.
1926PREFIX limits bindings to those starting with this key
1927sequence. START is a list of existing bindings to add to. If ALL
1928is non-nil, recursively retrieve all bindings below PREFIX. If
1929EVIL is non-nil, extract active evil bidings."
1930 (let ((bindings start)
1931 (ignore '(self-insert-command ignore ignore-event company-ignore))
1932 (evil-map
1933 (when (and evil (bound-and-true-p evil-local-mode))
1934 (lookup-key keymap (kbd (format "<%s-state>" evil-state))))))
1935 (when (keymapp evil-map)
1936 (setq bindings (which-key--get-keymap-bindings-1
1937 evil-map bindings prefix filter all ignore)))
1938 (which-key--get-keymap-bindings-1
1939 keymap bindings prefix filter all ignore)))
1940
1941(defun which-key--get-current-bindings (&optional prefix filter)
1942 "Generate a list of current active bindings."
1943 (let (bindings)
1944 (dolist (map (current-active-maps t) bindings)
1945 (when (cdr map)
1946 (setq bindings
1947 (which-key--get-keymap-bindings
1948 map bindings prefix filter))))))
1949
1950(defun which-key--get-bindings (&optional prefix keymap filter recursive)
1951 "Collect key bindings.
1952If KEYMAP is nil, collect from current buffer using the current
1953key sequence as a prefix. Otherwise, collect from KEYMAP. FILTER
1954is a function to use to filter the bindings. If RECURSIVE is
1955non-nil, then bindings are collected recursively for all prefixes."
1956 (let* ((unformatted
1957 (cond ((keymapp keymap)
1958 (which-key--get-keymap-bindings
1959 keymap nil prefix filter recursive))
1960 (keymap
1961 (error "%s is not a keymap" keymap))
1962 (t
1963 (which-key--get-current-bindings prefix filter)))))
1964 (when which-key-sort-order
1965 (setq unformatted
1966 (sort unformatted which-key-sort-order)))
1967 (which-key--format-and-replace unformatted recursive)))
1968
1969;;; Functions for laying out which-key buffer pages
1970
1971(defun which-key--normalize-columns (columns)
1972 "Pad COLUMNS to the same length using empty strings."
1973 (let ((max-len (cl-reduce (lambda (a x) (max a (length x))) columns
1974 :initial-value 0)))
1975 (mapcar
1976 (lambda (c)
1977 (if (< (length c) max-len)
1978 (append c (make-list (- max-len (length c)) ""))
1979 c))
1980 columns)))
1981
1982(defsubst which-key--join-columns (columns)
1983 "Transpose columns into rows, concat rows into lines and rows into page."
1984 (let* ((padded (which-key--normalize-columns (nreverse columns)))
1985 (rows (apply #'cl-mapcar #'list padded)))
1986 (mapconcat (lambda (row) (mapconcat #'identity row " ")) rows "\n")))
1987
1988(defsubst which-key--max-len (keys index &optional initial-value)
1989 "Find the max length of the INDEX element in each of KEYS."
1990 (cl-reduce
1991 (lambda (x y) (max x (which-key--string-width (nth index y))))
1992 keys :initial-value (if initial-value initial-value 0)))
1993
1994(defun which-key--pad-column (col-keys avl-width)
1995 "Pad cells of COL-KEYS to AVL-WIDTH.
1996Take a column of (key separator description) COL-KEYS,
1997calculate the max width in the column and pad all cells out to
1998that width."
1999 (let* ((col-key-width (+ which-key-add-column-padding
2000 (which-key--max-len col-keys 0)))
2001 (col-sep-width (which-key--max-len col-keys 1))
2002 (avl-width (- avl-width col-key-width col-sep-width))
2003 (col-desc-width (min avl-width
2004 (which-key--max-len
2005 col-keys 2
2006 which-key-min-column-description-width)))
2007 (col-width (+ col-key-width col-sep-width col-desc-width))
2008 (col-format (concat "%" (int-to-string col-key-width)
2009 "s%s%-" (int-to-string col-desc-width) "s")))
2010 (cons col-width
2011 (mapcar (lambda (k) (apply #'format col-format k))
2012 col-keys))))
2013
2014(defun which-key--partition-list (n list)
2015 "Partition LIST into N-sized sublists."
2016 (let (res)
2017 (while list
2018 (setq res (cons (cl-subseq list 0 (min n (length list))) res)
2019 list (nthcdr n list)))
2020 (nreverse res)))
2021
2022(defun which-key--list-to-pages (keys avl-lines avl-width)
2023 "Convert list of KEYS to columns based on dimensions AVL-LINES and AVL-WIDTH.
2024Returns a `which-key--pages' object that holds the page strings,
2025as well as metadata."
2026 (let ((cols-w-widths (mapcar (lambda (c) (which-key--pad-column c avl-width))
2027 (which-key--partition-list avl-lines keys)))
2028 (page-width 0) (n-pages 0) (n-keys 0) (n-columns 0)
2029 page-cols pages page-widths keys/page col)
2030 (if (> (apply #'max (mapcar #'car cols-w-widths)) avl-width)
2031 ;; give up if no columns fit
2032 nil
2033 (while cols-w-widths
2034 ;; start new page
2035 (cl-incf n-pages)
2036 (setq col (pop cols-w-widths))
2037 (setq page-cols (list (cdr col)))
2038 (setq page-width (car col))
2039 (setq n-keys (length (cdr col)))
2040 (setq n-columns 1)
2041 ;; add additional columns as long as they fit
2042 (while (and cols-w-widths
2043 (or (null which-key-max-display-columns)
2044 (< n-columns which-key-max-display-columns))
2045 (<= (+ page-width 1 (caar cols-w-widths)) avl-width))
2046 (setq col (pop cols-w-widths))
2047 (push (cdr col) page-cols)
2048 (cl-incf page-width (1+ (car col)))
2049 (cl-incf n-keys (length (cdr col)))
2050 (cl-incf n-columns))
2051 (push (which-key--join-columns page-cols) pages)
2052 (push n-keys keys/page)
2053 (push page-width page-widths))
2054 (make-which-key--pages
2055 :pages (nreverse pages)
2056 :height (if (> n-pages 1) avl-lines (min avl-lines n-keys))
2057 :widths (nreverse page-widths)
2058 :keys/page (reverse keys/page)
2059 :page-nums (number-sequence 1 n-pages)
2060 :num-pages n-pages
2061 :total-keys (apply #'+ keys/page)))))
2062
2063(defun which-key--create-pages-1
2064 (keys available-lines available-width &optional min-lines vertical)
2065 "Create page strings using `which-key--list-to-pages'.
2066Will try to find the best number of rows and columns using the
2067given dimensions and the length and widths of ITEMS. Use VERTICAL
2068if the ITEMS are laid out vertically and the number of columns
2069should be minimized."
2070 (let ((result (which-key--list-to-pages
2071 keys available-lines available-width))
2072 (min-lines (or min-lines 0))
2073 found prev-result)
2074 (if (or (null result)
2075 vertical
2076 (> (which-key--pages-num-pages result) 1)
2077 (= 1 available-lines))
2078 result
2079 ;; simple search for a fitting page
2080 (while (and (> available-lines min-lines)
2081 (not found))
2082 (setq available-lines (cl-decf available-lines)
2083 prev-result result
2084 result (which-key--list-to-pages
2085 keys available-lines available-width)
2086 found (> (which-key--pages-num-pages result) 1)))
2087 (if found prev-result result))))
2088
2089(defun which-key--create-pages (keys &optional prefix-keys prefix-title)
2090 "Create page strings using `which-key--list-to-pages'.
2091Will try to find the best number of rows and columns using the
2092given dimensions and the length and wdiths of KEYS. SEL-WIN-WIDTH
2093is the width of the live window."
2094 (let* ((max-dims (which-key--popup-max-dimensions))
2095 (max-lines (car max-dims))
2096 (max-width (cdr max-dims))
2097 (prefix-desc (key-description prefix-keys))
2098 (full-prefix (which-key--full-prefix prefix-desc))
2099 (prefix (when (eq which-key-show-prefix 'left)
2100 (+ 2 (which-key--string-width full-prefix))))
2101 (prefix-top-bottom (member which-key-show-prefix '(bottom top)))
2102 (avl-lines (if prefix-top-bottom (- max-lines 1) max-lines))
2103 (min-lines (min avl-lines which-key-min-display-lines))
2104 (avl-width (if prefix (- max-width prefix) max-width))
2105 (vertical (or (and (eq which-key-popup-type 'side-window)
2106 (member which-key-side-window-location '(left right)))
2107 (eq which-key-max-display-columns 1)))
2108 result)
2109 (setq result
2110 (which-key--create-pages-1
2111 keys avl-lines avl-width min-lines vertical))
2112 (when (and result
2113 (> (which-key--pages-num-pages result) 0))
2114 (setf (which-key--pages-prefix result) prefix-keys)
2115 (setf (which-key--pages-prefix-title result)
2116 (or prefix-title
2117 (which-key--maybe-get-prefix-title
2118 (key-description prefix-keys))))
2119 (when prefix-top-bottom
2120 ;; Add back the line earlier reserved for the page information.
2121 (setf (which-key--pages-height result) max-lines))
2122 (when (and (= (which-key--pages-num-pages result) 1)
2123 (> which-key-min-display-lines
2124 (which-key--pages-height result)))
2125 ;; result is shorter than requested, so we artificially increase the
2126 ;; height. See #325. Note this only has an effect if
2127 ;; `which-key-allow-imprecise-window-fit' is non-nil.
2128 (setf (which-key--pages-height result) which-key-min-display-lines))
2129 (which-key--debug-message "Frame height: %s
2130Frame pixel width: %s
2131Frame char width: %s
2132Frame width: %s
2133Which-key initial width: %s
2134Which-key adjusted width: %s
2135Minibuffer height: %s
2136Max dimensions: (%s, %s)
2137Available for bindings: (%s, %s)
2138Popup type info: (%s, %s, %s)
2139Computed page widths: %s
2140Actual lines: %s"
2141 (frame-height)
2142 (frame-pixel-width)
2143 (frame-char-width)
2144 (window-total-width (frame-root-window))
2145 (which-key--width-or-percentage-to-width
2146 which-key-side-window-max-width)
2147 (which-key--total-width-to-text
2148 (which-key--width-or-percentage-to-width
2149 which-key-side-window-max-width))
2150 (window-text-height (minibuffer-window))
2151 max-lines
2152 max-width
2153 avl-lines
2154 avl-width
2155 which-key-popup-type
2156 which-key-side-window-location
2157 which-key-side-window-max-width
2158 (which-key--pages-widths result)
2159 (which-key--pages-height result))
2160 result)))
2161
2162(defun which-key--lighter-status ()
2163 "Possibly show number of keys and total in the mode line."
2164 (when which-key-show-remaining-keys
2165 (let ((n-shown (car (which-key--pages-keys/page which-key--pages-obj)))
2166 (n-tot (which-key--pages-total-keys which-key--pages-obj)))
2167 (setcar (cdr (assq 'which-key-mode minor-mode-alist))
2168 (format " WK: %s/%s keys" n-shown n-tot)))))
2169
2170(defun which-key--lighter-restore ()
2171 "Restore the lighter for which-key."
2172 (when which-key-show-remaining-keys
2173 (setcar (cdr (assq 'which-key-mode minor-mode-alist))
2174 which-key-lighter)))
2175
2176(defun which-key--echo (text)
2177 "Echo TEXT to minibuffer without logging."
2178 (let (message-log-max)
2179 (message "%s" text)))
2180
2181(defun which-key--next-page-hint (prefix-keys)
2182 "Return string for next page hint."
2183 (let* ((paging-key (concat prefix-keys " " which-key-paging-key))
2184 (paging-key-bound (eq 'which-key-C-h-dispatch
2185 (key-binding (kbd paging-key))))
2186 (key (key-description (vector help-char)))
2187 (key (if paging-key-bound
2188 (concat key " or " which-key-paging-key)
2189 key)))
2190 (when (and which-key-use-C-h-commands
2191 (not (equal (vector help-char)
2192 (vconcat (kbd prefix-keys)))))
2193 (which-key--propertize (format "[%s paging/help]" key)
2194 'face 'which-key-note-face))))
2195
2196(defun which-key--full-prefix (prefix-keys &optional -prefix-arg dont-prop-keys)
2197 "Return a description of the full key sequence up to now.
2198Include prefix arguments."
2199 (let* ((left (eq which-key-show-prefix 'left))
2200 (prefix-arg (if -prefix-arg -prefix-arg prefix-arg))
2201 (str (concat
2202 (universal-argument--description)
2203 (when prefix-arg " ")
2204 prefix-keys))
2205 (dash (if (and (not (string= prefix-keys ""))
2206 (null left)) "-" "")))
2207 (if (or (eq which-key-show-prefix 'echo) dont-prop-keys)
2208 (concat str dash)
2209 (concat (which-key--propertize-key str)
2210 (which-key--propertize dash 'face 'which-key-key-face)))))
2211
2212(defun which-key--get-popup-map ()
2213 "Generate transient-map for use in the top level binding display."
2214 (unless which-key--automatic-display
2215 (let ((map (make-sparse-keymap)))
2216 (define-key map (kbd which-key-paging-key) #'which-key-C-h-dispatch)
2217 (when which-key-use-C-h-commands
2218 ;; Show next page even when C-h is pressed
2219 (define-key map (vector help-char) #'which-key-C-h-dispatch))
2220 map)))
2221
2222(defun which-key--process-page (pages-obj)
2223 "Add information to the basic list of key bindings.
2224Include, if applicable, the current prefix, the name of the current
2225prefix, and a page count."
2226 (let* ((page (car (which-key--pages-pages pages-obj)))
2227 (height (which-key--pages-height pages-obj))
2228 (n-pages (which-key--pages-num-pages pages-obj))
2229 (page-n (car (which-key--pages-page-nums pages-obj)))
2230 (prefix-desc (key-description (which-key--pages-prefix pages-obj)))
2231 (prefix-title (which-key--pages-prefix-title pages-obj))
2232 (full-prefix (which-key--full-prefix prefix-desc))
2233 (nxt-pg-hint (which-key--next-page-hint prefix-desc))
2234 ;; not used in left case
2235 (status-line
2236 (concat (which-key--propertize prefix-title 'face 'which-key-note-face)
2237 (when (< 1 n-pages)
2238 (which-key--propertize (format " (%s of %s)" page-n n-pages)
2239 'face 'which-key-note-face)))))
2240 (pcase which-key-show-prefix
2241 (`left
2242 (let* ((page-cnt (which-key--propertize (format "%s/%s" page-n n-pages)
2243 'face 'which-key-separator-face))
2244 (first-col-width (+ 2 (max (which-key--string-width full-prefix)
2245 (which-key--string-width page-cnt))))
2246 (prefix (format (concat "%-" (int-to-string first-col-width) "s")
2247 full-prefix))
2248 (page-cnt (if (> n-pages 1)
2249 (format
2250 (concat "%-" (int-to-string first-col-width) "s")
2251 page-cnt)
2252 (make-string first-col-width 32)))
2253 lines first-line new-end)
2254 (if (= 1 height)
2255 (cons (concat prefix page) nil)
2256 (setq lines (split-string page "\n")
2257 first-line (concat prefix (car lines) "\n" page-cnt)
2258 new-end (concat "\n" (make-string first-col-width 32)))
2259 (cons
2260 (concat first-line (mapconcat #'identity (cdr lines) new-end))
2261 nil))))
2262 (`top
2263 (cons
2264 (concat (when (or (= 0 echo-keystrokes)
2265 (not (eq which-key-side-window-location 'bottom)))
2266 (concat full-prefix " "))
2267 status-line " " nxt-pg-hint "\n" page)
2268 nil))
2269 (`bottom
2270 (cons
2271 (concat page "\n"
2272 (when (or (= 0 echo-keystrokes)
2273 (not (eq which-key-side-window-location 'bottom)))
2274 (concat full-prefix " "))
2275 status-line " " nxt-pg-hint)
2276 nil))
2277 (`echo
2278 (cons page
2279 (lambda ()
2280 (which-key--echo
2281 (concat full-prefix (when prefix-desc " ")
2282 status-line (when status-line " ")
2283 nxt-pg-hint)))))
2284 (`mode-line
2285 (cons page
2286 (lambda ()
2287 (with-current-buffer which-key--buffer
2288 (setq-local mode-line-format
2289 (concat " " full-prefix
2290 " " status-line
2291 " " nxt-pg-hint))))))
2292 (_ (cons page nil)))))
2293
2294(defun which-key--show-page (&optional n)
2295 "Show current page.
2296N changes the current page to the Nth page relative to the
2297current one."
2298 (which-key--init-buffer) ;; in case it was killed
2299 (let ((prefix-keys (which-key--current-key-string))
2300 golden-ratio-mode)
2301 (if (null which-key--pages-obj)
2302 (message "%s- which-key can't show keys: There is not \
2303enough space based on your settings and frame size." prefix-keys)
2304 (when n
2305 (setq which-key--pages-obj
2306 (which-key--pages-set-current-page which-key--pages-obj n)))
2307 (let ((page-echo (which-key--process-page which-key--pages-obj))
2308 (height (which-key--pages-height which-key--pages-obj))
2309 (width (car (which-key--pages-widths which-key--pages-obj))))
2310 (which-key--lighter-status)
2311 (if (eq which-key-popup-type 'minibuffer)
2312 (which-key--echo (car page-echo))
2313 (with-current-buffer which-key--buffer
2314 (erase-buffer)
2315 (insert (car page-echo))
2316 (goto-char (point-min)))
2317 (when (cdr page-echo) (funcall (cdr page-echo)))
2318 (which-key--show-popup (cons height width)))))
2319 ;; used for paging at top-level
2320 (if (fboundp 'set-transient-map)
2321 (set-transient-map (which-key--get-popup-map))
2322 (with-no-warnings
2323 (set-temporary-overlay-map (which-key--get-popup-map))))))
2324
2325;;; Paging functions
2326
2327;;;###autoload
2328(defun which-key-reload-key-sequence (&optional key-seq)
2329 "Simulate entering the key sequence KEY-SEQ.
2330KEY-SEQ should be a list of events as produced by
2331`listify-key-sequence'. If nil, KEY-SEQ defaults to
2332`which-key--current-key-list'. Any prefix arguments that were
2333used are reapplied to the new key sequence."
2334 (let* ((key-seq (or key-seq (which-key--current-key-list)))
2335 (next-event (mapcar (lambda (ev) (cons t ev)) key-seq)))
2336 (setq prefix-arg current-prefix-arg
2337 unread-command-events next-event)))
2338
2339(defun which-key-turn-page (delta)
2340 "Show the next page of keys."
2341 (which-key-reload-key-sequence)
2342 (if which-key--last-try-2-loc
2343 (let ((which-key-side-window-location which-key--last-try-2-loc)
2344 (which-key--multiple-locations t))
2345 (which-key--show-page delta))
2346 (which-key--show-page delta))
2347 (which-key--start-paging-timer))
2348
2349;;;###autoload
2350(defun which-key-show-standard-help (&optional _)
2351 "Call the command in `which-key--prefix-help-cmd-backup'.
2352Usually this is `describe-prefix-bindings'."
2353 (interactive)
2354 (let ((which-key-inhibit t)
2355 (popup-showing (which-key--popup-showing-p)))
2356 (which-key--hide-popup-ignore-command)
2357 (cond ((and (eq which-key--prefix-help-cmd-backup
2358 'describe-prefix-bindings)
2359 ;; If the popup is not showing, we call
2360 ;; `describe-prefix-bindings' directly.
2361 popup-showing)
2362 ;; This is essentially what `describe-prefix-bindings' does. We can't
2363 ;; use this function directly, because the prefix will not be correct
2364 ;; when we enter using `which-key-C-h-dispatch'.
2365 (describe-bindings (kbd (which-key--current-key-string))))
2366 ((functionp which-key--prefix-help-cmd-backup)
2367 (funcall which-key--prefix-help-cmd-backup)))))
2368
2369;;;###autoload
2370(defun which-key-show-next-page-no-cycle ()
2371 "Show next page of keys or `which-key-show-standard-help'."
2372 (interactive)
2373 (let ((which-key-inhibit t))
2374 (if (which-key--on-last-page)
2375 (which-key-show-standard-help)
2376 (which-key-turn-page 1))))
2377
2378;;;###autoload
2379(defun which-key-show-previous-page-no-cycle ()
2380 "Show previous page of keys if one exists."
2381 (interactive)
2382 (let ((which-key-inhibit t))
2383 (unless (which-key--on-first-page)
2384 (which-key-turn-page -1))))
2385
2386;;;###autoload
2387(defun which-key-show-next-page-cycle (&optional _)
2388 "Show the next page of keys, cycling from end to beginning."
2389 (interactive)
2390 (let ((which-key-inhibit t))
2391 (which-key-turn-page 1)))
2392
2393;;;###autoload
2394(defun which-key-show-previous-page-cycle (&optional _)
2395 "Show the previous page of keys, cycling from beginning to end."
2396 (interactive)
2397 (let ((which-key-inhibit t))
2398 (which-key-turn-page -1)))
2399
2400;;;###autoload
2401(defun which-key-show-top-level (&optional _)
2402 "Show top-level bindings."
2403 (interactive)
2404 (which-key--create-buffer-and-show nil nil nil "Top-level bindings"))
2405
2406;;;###autoload
2407(defun which-key-show-major-mode (&optional all)
2408 "Show top-level bindings in the map of the current major mode.
2409This function will also detect evil bindings made using
2410`evil-define-key' in this map. These bindings will depend on the
2411current evil state. "
2412 (interactive "P")
2413 (let ((map-sym (intern (format "%s-map" major-mode))))
2414 (if (and (boundp map-sym) (keymapp (symbol-value map-sym)))
2415 (which-key--show-keymap
2416 "Major-mode bindings"
2417 (symbol-value map-sym)
2418 (apply-partially #'which-key--map-binding-p (symbol-value map-sym))
2419 all)
2420 (message "which-key: No map named %s" map-sym))))
2421
2422;;;###autoload
2423(defun which-key-show-full-major-mode ()
2424 "Show all bindings in the map of the current major mode.
2425This function will also detect evil bindings made using
2426`evil-define-key' in this map. These bindings will depend on the
2427current evil state. "
2428 (interactive)
2429 (which-key-show-major-mode t))
2430
2431;;;###autoload
2432(defun which-key-dump-bindings (prefix buffer-name)
2433 "Dump bindings from PREFIX into buffer named BUFFER-NAME.
2434PREFIX should be a string suitable for `kbd'."
2435 (interactive "sPrefix: \nB")
2436 (let* ((buffer (get-buffer-create buffer-name))
2437 (keys (which-key--get-bindings (kbd prefix))))
2438 (with-current-buffer buffer
2439 (point-max)
2440 (save-excursion
2441 (dolist (key keys)
2442 (insert (apply #'format "%s%s%s\n" key)))))
2443 (switch-to-buffer-other-window buffer)))
2444
2445;;;###autoload
2446(defun which-key-undo-key (&optional _)
2447 "Undo last keypress and force which-key update."
2448 (interactive)
2449 (let* ((key-lst (butlast (which-key--current-key-list)))
2450 (which-key-inhibit t))
2451 (cond (which-key--prior-show-keymap-args
2452 (if (keymapp (cdr (car-safe which-key--prior-show-keymap-args)))
2453 (let ((args (pop which-key--prior-show-keymap-args)))
2454 (which-key--show-keymap (car args) (cdr args)))
2455 (which-key--hide-popup)))
2456 (key-lst
2457 (which-key-reload-key-sequence key-lst)
2458 (which-key--create-buffer-and-show (apply #'vector key-lst)))
2459 (t (setq which-key--automatic-display nil)
2460 (which-key-show-top-level)))))
2461(defalias 'which-key-undo #'which-key-undo-key)
2462
2463(defun which-key-abort (&optional _)
2464 "Abort key sequence."
2465 (interactive)
2466 (let ((which-key-inhibit t))
2467 (which-key--hide-popup-ignore-command)
2468 (keyboard-quit)))
2469
2470(defun which-key-digit-argument (key)
2471 "Version of `digit-argument' for use in `which-key-C-h-map'."
2472 (interactive)
2473 (let ((last-command-event (string-to-char key)))
2474 (digit-argument key))
2475 (let ((current-prefix-arg prefix-arg))
2476 (which-key-reload-key-sequence)))
2477
2478(defun which-key-toggle-docstrings (&optional _)
2479 "Toggle the display of docstrings."
2480 (interactive)
2481 (unless (eq which-key-show-docstrings 'docstring-only)
2482 (setq which-key-show-docstrings (null which-key-show-docstrings)))
2483 (which-key-reload-key-sequence)
2484 (which-key--create-buffer-and-show (which-key--current-prefix)))
2485
2486;;;###autoload
2487(defun which-key-C-h-dispatch ()
2488 "Dispatch C-h commands by looking up key in `which-key-C-h-map'.
2489This command is always accessible (from any prefix) if
2490`which-key-use-C-h-commands' is non nil."
2491 (interactive)
2492 (cond ((and (not (which-key--popup-showing-p))
2493 which-key-show-early-on-C-h)
2494 (let ((current-prefix
2495 (butlast
2496 (listify-key-sequence
2497 (funcall which-key-this-command-keys-function)))))
2498 (which-key-reload-key-sequence current-prefix)
2499 (if which-key-idle-secondary-delay
2500 (which-key--start-timer which-key-idle-secondary-delay t)
2501 (which-key--start-timer 0.05 t))))
2502 ((not (which-key--popup-showing-p))
2503 (which-key-show-standard-help))
2504 (t
2505 (if (not (which-key--popup-showing-p))
2506 (which-key-show-standard-help)
2507 (let* ((prefix-keys (which-key--current-key-string))
2508 (full-prefix (which-key--full-prefix prefix-keys current-prefix-arg t))
2509 (prompt (concat (when (string-equal prefix-keys "")
2510 (which-key--propertize
2511 (concat " "
2512 (which-key--pages-prefix-title
2513 which-key--pages-obj))
2514 'face 'which-key-note-face))
2515 full-prefix
2516 (which-key--propertize
2517 (substitute-command-keys
2518 which-key-C-h-map-prompt)
2519 'face 'which-key-note-face)))
2520 (key (let ((key (read-key prompt)))
2521 (if (numberp key)
2522 (string key)
2523 (vector key))))
2524 (cmd (lookup-key which-key-C-h-map key))
2525 (which-key-inhibit t))
2526 (if cmd (funcall cmd key) (which-key-turn-page 0)))))))
2527
2528;;; Update
2529
2530(defun which-key--any-match-p (regexps string)
2531 "Non-nil if any of REGEXPS match STRING."
2532 (catch 'match
2533 (dolist (regexp regexps)
2534 (when (string-match-p regexp string)
2535 (throw 'match t)))))
2536
2537(defun which-key--try-2-side-windows
2538 (bindings prefix-keys prefix-title loc1 loc2 &rest _ignore)
2539 "Try to show BINDINGS (PAGE-N) in LOC1 first.
2540Only if no bindings fit fallback to LOC2."
2541 (let (pages1)
2542 (let ((which-key-side-window-location loc1)
2543 (which-key--multiple-locations t))
2544 (setq pages1 (which-key--create-pages
2545 bindings prefix-keys prefix-title)))
2546 (if pages1
2547 (progn
2548 (setq which-key--pages-obj pages1)
2549 (let ((which-key-side-window-location loc1)
2550 (which-key--multiple-locations t))
2551 (which-key--show-page))
2552 loc1)
2553 (let ((which-key-side-window-location loc2)
2554 (which-key--multiple-locations t))
2555 (setq which-key--pages-obj
2556 (which-key--create-pages bindings prefix-keys prefix-title))
2557 (which-key--show-page)
2558 loc2))))
2559
2560(defun which-key--read-keymap ()
2561 "Read keymap symbol from minibuffer."
2562 (intern
2563 (completing-read "Keymap: " obarray
2564 (lambda (m)
2565 (and (boundp m)
2566 (keymapp (symbol-value m))
2567 (not (equal (symbol-value m)
2568 (make-sparse-keymap)))))
2569 t
2570 (let ((sym (symbol-at-point)))
2571 (and (boundp sym)
2572 (keymapp (symbol-value sym))
2573 (symbol-name sym)))
2574 'which-key-keymap-history)))
2575
2576;;;###autoload
2577(defun which-key-show-keymap (keymap &optional no-paging)
2578 "Show the top-level bindings in KEYMAP using which-key.
2579KEYMAP is selected interactively from all available keymaps.
2580
2581If NO-PAGING is non-nil, which-key will not intercept subsequent
2582keypresses for the paging functionality."
2583 (interactive (list (which-key--read-keymap)))
2584 (which-key--show-keymap (symbol-name keymap)
2585 (symbol-value keymap)
2586 nil nil no-paging))
2587
2588;;;###autoload
2589(defun which-key-show-full-keymap (keymap)
2590 "Show all bindings in KEYMAP using which-key.
2591KEYMAP is selected interactively from all available keymaps."
2592 (interactive (list (which-key--read-keymap)))
2593 (which-key--show-keymap (symbol-name keymap)
2594 (symbol-value keymap)
2595 nil t))
2596
2597;;;###autoload
2598(defun which-key-show-minor-mode-keymap (&optional all)
2599 "Show the top-level bindings in KEYMAP using which-key.
2600KEYMAP is selected interactively by mode in
2601`minor-mode-map-alist'."
2602 (interactive)
2603 (let ((mode-sym
2604 (intern
2605 (completing-read
2606 "Minor Mode: "
2607 (mapcar #'car
2608 (cl-remove-if-not
2609 (lambda (entry)
2610 (and (symbol-value (car entry))
2611 (not (equal (cdr entry) (make-sparse-keymap)))))
2612 minor-mode-map-alist))
2613 nil t nil 'which-key-keymap-history))))
2614 (which-key--show-keymap (symbol-name mode-sym)
2615 (cdr (assq mode-sym minor-mode-map-alist))
2616 all)))
2617;;;###autoload
2618(defun which-key-show-full-minor-mode-keymap ()
2619 "Show all bindings in KEYMAP using which-key.
2620KEYMAP is selected interactively by mode in
2621`minor-mode-map-alist'."
2622 (interactive)
2623 (which-key-show-minor-mode-keymap t))
2624
2625(defun which-key--show-keymap
2626 (keymap-name keymap &optional prior-args all no-paging filter)
2627 (when prior-args (push prior-args which-key--prior-show-keymap-args))
2628 (let ((bindings (which-key--get-bindings nil keymap filter all)))
2629 (if (null bindings)
2630 (message "which-key: No bindings found in %s" keymap-name)
2631 (cond ((listp which-key-side-window-location)
2632 (setq which-key--last-try-2-loc
2633 (apply #'which-key--try-2-side-windows
2634 bindings nil keymap-name
2635 which-key-side-window-location)))
2636 (t (setq which-key--pages-obj
2637 (which-key--create-pages bindings nil keymap-name))
2638 (which-key--show-page)))
2639 (unless no-paging
2640 (let* ((key (read-key))
2641 (key-desc (key-description (list key)))
2642 (next-def (lookup-key keymap (vector key))))
2643 (cond ((and which-key-use-C-h-commands
2644 (numberp key) (= key help-char))
2645 (which-key-C-h-dispatch))
2646 ((keymapp next-def)
2647 (which-key--hide-popup-ignore-command)
2648 (which-key--show-keymap
2649 (concat keymap-name " " key-desc)
2650 next-def
2651 (cons keymap-name keymap)))
2652 (t (which-key--hide-popup))))))))
2653
2654(defun which-key--evil-operator-filter (binding)
2655 (let ((def (intern (cdr binding))))
2656 (and (functionp def)
2657 (not (evil-get-command-property def :suppress-operator)))))
2658
2659(defun which-key--show-evil-operator-keymap ()
2660 (if which-key--inhibit-next-operator-popup
2661 (setq which-key--inhibit-next-operator-popup nil)
2662 (let ((keymap
2663 (make-composed-keymap (list evil-operator-shortcut-map
2664 evil-operator-state-map
2665 evil-motion-state-map))))
2666 (when (keymapp keymap)
2667 (let ((formatted-keys
2668 (which-key--get-bindings
2669 nil keymap #'which-key--evil-operator-filter)))
2670 (cond ((null formatted-keys)
2671 (message "which-key: Keymap empty"))
2672 ((listp which-key-side-window-location)
2673 (setq which-key--last-try-2-loc
2674 (apply #'which-key--try-2-side-windows
2675 formatted-keys nil "evil operator/motion keys"
2676 which-key-side-window-location)))
2677 (t (setq which-key--pages-obj
2678 (which-key--create-pages
2679 formatted-keys
2680 nil "evil operator/motion keys"))
2681 (which-key--show-page)))))
2682 (let ((key (read-key)))
2683 (when (memq key '(?f ?F ?t ?T ?`))
2684 ;; these keys trigger commands that read the next char manually
2685 (setq which-key--inhibit-next-operator-popup t))
2686 (cond ((and which-key-use-C-h-commands (numberp key) (= key help-char))
2687 (which-key-C-h-dispatch))
2688 ((and (numberp key) (= key ?\C-\[))
2689 (which-key--hide-popup)
2690 (keyboard-quit))
2691 (t
2692 (which-key--hide-popup)
2693 (setq unread-command-events (vector key))))))))
2694
2695(defun which-key--create-buffer-and-show
2696 (&optional prefix-keys from-keymap filter prefix-title)
2697 "Fill `which-key--buffer' with key descriptions and reformat.
2698Finally, show the buffer."
2699 (let ((start-time (current-time))
2700 (formatted-keys (which-key--get-bindings
2701 prefix-keys from-keymap filter))
2702 (prefix-desc (key-description prefix-keys)))
2703 (cond ((null formatted-keys)
2704 (message "%s- which-key: There are no keys to show" prefix-desc))
2705 ((listp which-key-side-window-location)
2706 (setq which-key--last-try-2-loc
2707 (apply #'which-key--try-2-side-windows
2708 formatted-keys prefix-keys prefix-title
2709 which-key-side-window-location)))
2710 (t (setq which-key--pages-obj
2711 (which-key--create-pages
2712 formatted-keys prefix-keys prefix-title))
2713 (which-key--show-page)))
2714 (which-key--debug-message
2715 "On prefix \"%s\" which-key took %.0f ms." prefix-desc
2716 (* 1000 (float-time (time-since start-time))))))
2717
2718(defun which-key--update ()
2719 "Function run by timer to possibly trigger `which-key--create-buffer-and-show'."
2720 (let ((prefix-keys (funcall which-key-this-command-keys-function))
2721 delay-time)
2722 (cond ((and (> (length prefix-keys) 0)
2723 (or (keymapp (key-binding prefix-keys))
2724 ;; Some keymaps are stored here like iso-transl-ctl-x-8-map
2725 (keymapp (which-key--safe-lookup-key
2726 key-translation-map prefix-keys))
2727 ;; just in case someone uses one of these
2728 (keymapp (which-key--safe-lookup-key
2729 function-key-map prefix-keys)))
2730 (not which-key-inhibit)
2731 (or (null which-key-allow-regexps)
2732 (which-key--any-match-p
2733 which-key-allow-regexps (key-description prefix-keys)))
2734 (or (null which-key-inhibit-regexps)
2735 (not
2736 (which-key--any-match-p
2737 which-key-inhibit-regexps (key-description prefix-keys))))
2738 ;; Do not display the popup if a command is currently being
2739 ;; executed
2740 (or (run-hook-with-args-until-success
2741 'which-key-inhibit-display-hook)
2742 (null this-command))
2743 (let ((max-dim (which-key--popup-max-dimensions)))
2744 (> (min (car-safe max-dim) (cdr-safe max-dim)) 0)))
2745 (when (and (not (equal prefix-keys (which-key--current-prefix)))
2746 (or (null which-key-delay-functions)
2747 (null (setq delay-time
2748 (run-hook-with-args-until-success
2749 'which-key-delay-functions
2750 (key-description prefix-keys)
2751 (length prefix-keys))))
2752 (sit-for delay-time)))
2753 (setq which-key--automatic-display t)
2754 (which-key--create-buffer-and-show prefix-keys)
2755 (when (and which-key-idle-secondary-delay
2756 (not which-key--secondary-timer-active))
2757 (which-key--start-timer which-key-idle-secondary-delay t))))
2758 ((and which-key-show-transient-maps
2759 ;; Assuming that if this is not true we're in
2760 ;; `which-key-show-top-level', which would then be overwritten.
2761 (> (length prefix-keys) 0)
2762 (keymapp overriding-terminal-local-map)
2763 ;; basic test for it being a hydra
2764 (not (eq (lookup-key overriding-terminal-local-map "\C-u")
2765 'hydra--universal-argument)))
2766 (which-key--create-buffer-and-show
2767 nil overriding-terminal-local-map))
2768 ((and which-key-show-operator-state-maps
2769 (bound-and-true-p evil-state)
2770 (eq evil-state 'operator)
2771 (not (which-key--popup-showing-p)))
2772 (which-key--show-evil-operator-keymap))
2773 (which-key--automatic-display
2774 (which-key--hide-popup)))))
2775
2776;;; Timers
2777
2778(defun which-key--start-timer (&optional delay secondary)
2779 "Activate idle timer to trigger `which-key--update'."
2780 (which-key--stop-timer)
2781 (setq which-key--secondary-timer-active secondary)
2782 (setq which-key--timer
2783 (run-with-idle-timer (or delay which-key-idle-delay)
2784 t #'which-key--update)))
2785
2786(defun which-key--stop-timer ()
2787 "Deactivate idle timer for `which-key--update'."
2788 (when which-key--timer (cancel-timer which-key--timer)))
2789
2790(defun which-key--start-paging-timer ()
2791 "Activate timer to restart which-key after paging."
2792 (when which-key--paging-timer (cancel-timer which-key--paging-timer))
2793 (which-key--stop-timer)
2794 (setq which-key--paging-timer
2795 (run-with-idle-timer
2796 0.2 t (lambda ()
2797 (when (or (not (member real-last-command
2798 which-key--paging-functions))
2799 (and (< 0 (length (this-single-command-keys)))
2800 (not (equal (which-key--current-prefix)
2801 (funcall which-key-this-command-keys-function)))))
2802 (cancel-timer which-key--paging-timer)
2803 (if which-key-idle-secondary-delay
2804 ;; we haven't executed a command yet so the secandary
2805 ;; timer is more relevant here
2806 (which-key--start-timer which-key-idle-secondary-delay t)
2807 (which-key--start-timer)))))))
2808
2809(provide 'which-key)
2810;;; which-key.el ends here
diff --git a/test/lisp/which-key-tests.el b/test/lisp/which-key-tests.el
new file mode 100644
index 00000000000..1f2b1965ec3
--- /dev/null
+++ b/test/lisp/which-key-tests.el
@@ -0,0 +1,267 @@
1;;; which-key-tests.el --- Tests for which-key.el -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
4
5;; Author: Justin Burkett <justin@burkett.cc>
6;; Maintainer: Justin Burkett <justin@burkett.cc>
7
8;; This program is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or
11;; (at your option) any later version.
12
13;; This program is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with this program. If not, see <http://www.gnu.org/licenses/>.
20
21;;; Commentary:
22
23;; Tests for which-key.el
24
25;;; Code:
26
27(require 'which-key)
28(require 'ert)
29
30(ert-deftest which-key-test--keymap-based-bindings ()
31 (let ((map (make-sparse-keymap))
32 (prefix-map (make-sparse-keymap)))
33 (define-key prefix-map "x" #'ignore)
34 (define-key map "\C-a" 'complete)
35 (define-key map "\C-b" prefix-map)
36 (which-key-add-keymap-based-replacements map
37 "C-a" '("mycomplete" . complete)
38 "C-b" "mymap"
39 "C-c" "mymap2")
40 (define-key map "\C-ca" 'foo)
41 (should (equal
42 (which-key--get-keymap-bindings map)
43 '(("C-a" . "mycomplete")
44 ("C-b" . "group:mymap")
45 ("C-c" . "group:mymap2"))))))
46
47(ert-deftest which-key-test--named-prefix-keymap ()
48 (define-prefix-command 'which-key-test--named-map)
49 (let ((map (make-sparse-keymap)))
50 (define-key map "\C-a" 'which-key-test--named-map)
51 (should (equal
52 (which-key--get-keymap-bindings map)
53 '(("C-a" . "which-key-test--named-map"))))))
54
55(ert-deftest which-key-test--prefix-declaration ()
56 "Test `which-key-declare-prefixes' and
57`which-key-declare-prefixes-for-mode'. See Bug #109."
58 (let* ((major-mode 'test-mode)
59 which-key-replacement-alist)
60 (which-key-add-key-based-replacements
61 "SPC C-c" '("complete" . "complete title")
62 "SPC C-k" "cancel")
63 (which-key-add-major-mode-key-based-replacements 'test-mode
64 "C-c C-c" '("complete" . "complete title")
65 "C-c C-k" "cancel")
66 (should (equal
67 (which-key--maybe-replace '("SPC C-k" . ""))
68 '("SPC C-k" . "cancel")))
69 (should (equal
70 (which-key--maybe-replace '("C-c C-c" . ""))
71 '("C-c C-c" . "complete")))))
72
73(ert-deftest which-key-test--maybe-replace ()
74 "Test `which-key--maybe-replace'. See #154"
75 (let ((which-key-replacement-alist
76 '((("C-c [a-d]" . nil) . ("C-c a" . "c-c a"))
77 (("C-c .+" . nil) . ("C-c *" . "c-c *"))))
78 (test-mode-1 't)
79 (test-mode-2 'nil)
80 which-key-allow-multiple-replacements)
81 (which-key-add-key-based-replacements
82 "C-c ." "test ."
83 "SPC ." "SPC ."
84 "C-c \\" "regexp quoting"
85 "C-c [" "bad regexp"
86 "SPC t1" (lambda (kb)
87 (cons (car kb)
88 (if test-mode-1
89 "[x] test mode"
90 "[ ] test mode")))
91 "SPC t2" (lambda (kb)
92 (cons (car kb)
93 (if test-mode-2
94 "[x] test mode"
95 "[ ] test mode"))))
96 (should (equal
97 (which-key--maybe-replace '("C-c g" . "test"))
98 '("C-c *" . "c-c *")))
99 (should (equal
100 (which-key--maybe-replace '("C-c b" . "test"))
101 '("C-c a" . "c-c a")))
102 (should (equal
103 (which-key--maybe-replace '("C-c ." . "not test ."))
104 '("C-c ." . "test .")))
105 (should (not
106 (equal
107 (which-key--maybe-replace '("C-c +" . "not test ."))
108 '("C-c ." . "test ."))))
109 (should (equal
110 (which-key--maybe-replace '("C-c [" . "orig bad regexp"))
111 '("C-c [" . "bad regexp")))
112 (should (equal
113 (which-key--maybe-replace '("C-c \\" . "pre quoting"))
114 '("C-c \\" . "regexp quoting")))
115 ;; see #155
116 (should (equal
117 (which-key--maybe-replace '("SPC . ." . "don't replace"))
118 '("SPC . ." . "don't replace")))
119 (should (equal
120 (which-key--maybe-replace '("SPC t 1" . "test mode"))
121 '("SPC t 1" . "[x] test mode")))
122 (should (equal
123 (which-key--maybe-replace '("SPC t 2" . "test mode"))
124 '("SPC t 2" . "[ ] test mode")))))
125
126(ert-deftest which-key-test--maybe-replace-multiple ()
127 "Test `which-key-allow-multiple-replacements'. See #156."
128 (let ((which-key-replacement-alist
129 '(((nil . "helm") . (nil . "HLM"))
130 ((nil . "projectile") . (nil . "PRJTL"))))
131 (which-key-allow-multiple-replacements t))
132 (should (equal
133 (which-key--maybe-replace '("C-c C-c" . "helm-x"))
134 '("C-c C-c" . "HLM-x")))
135 (should (equal
136 (which-key--maybe-replace '("C-c C-c" . "projectile-x"))
137 '("C-c C-c" . "PRJTL-x")))
138 (should (equal
139 (which-key--maybe-replace '("C-c C-c" . "helm-projectile-x"))
140 '("C-c C-c" . "HLM-PRJTL-x")))))
141
142(ert-deftest which-key-test--key-extraction ()
143 "Test `which-key--extract-key'. See #161."
144 (should (equal (which-key--extract-key "SPC a") "a"))
145 (should (equal (which-key--extract-key "C-x a") "a"))
146 (should (equal (which-key--extract-key "<left> b a") "a"))
147 (should (equal (which-key--extract-key "<left> a .. c") "a .. c"))
148 (should (equal (which-key--extract-key "M-a a .. c") "a .. c")))
149
150(ert-deftest which-key-test--get-keymap-bindings ()
151 (skip-unless (require 'evil nil t))
152 (defvar evil-local-mode)
153 (defvar evil-state)
154 (declare-function evil-define-key* "ext:evil")
155 (let ((map (make-sparse-keymap))
156 (evil-local-mode t)
157 (evil-state 'normal)
158 which-key-replacement-alist)
159 (define-key map [which-key-a] '(which-key "blah"))
160 (define-key map "b" #'ignore)
161 (define-key map "c" "c")
162 (define-key map "dd" "dd")
163 (define-key map "eee" "eee")
164 (define-key map "f" [123 45 6])
165 (define-key map (kbd "M-g g") "M-gg")
166 (evil-define-key* 'normal map (kbd "C-h") "C-h-normal")
167 (evil-define-key* 'insert map (kbd "C-h") "C-h-insert")
168 (should (equal
169 (sort (which-key--get-keymap-bindings map)
170 (lambda (a b) (string-lessp (car a) (car b))))
171 '(("M-g" . "prefix")
172 ("c" . "c")
173 ("d" . "prefix")
174 ("e" . "prefix")
175 ("f" . "{ - C-f"))))
176 (should (equal
177 (sort (which-key--get-keymap-bindings map nil nil nil nil t)
178 (lambda (a b) (string-lessp (car a) (car b))))
179 '(("C-h" . "C-h-normal")
180 ("M-g" . "prefix")
181 ("c" . "c")
182 ("d" . "prefix")
183 ("e" . "prefix")
184 ("f" . "{ - C-f"))))
185 (should (equal
186 (sort (which-key--get-keymap-bindings map nil nil nil t)
187 (lambda (a b) (string-lessp (car a) (car b))))
188 '(("M-g g" . "M-gg")
189 ("c" . "c")
190 ("d d" . "dd")
191 ("e e e" . "eee")
192 ("f" . "{ - C-f"))))))
193
194(ert-deftest which-key-test--nil-replacement ()
195 (let ((which-key-replacement-alist
196 '(((nil . "winum-select-window-[1-9]") . t))))
197 (should (equal
198 (which-key--maybe-replace '("C-c C-c" . "winum-select-window-1"))
199 '()))))
200
201(ert-deftest which-key-test--key-sorting ()
202 (let ((keys '(("a" . "z")
203 ("A" . "Z")
204 ("b" . "y")
205 ("B" . "Y")
206 ("p" . "prefix")
207 ("SPC" . "x")
208 ("C-a" . "w"))))
209 (let ((which-key-sort-uppercase-first t))
210 (should
211 (equal
212 (mapcar #'car (sort (copy-sequence keys) #'which-key-key-order))
213 '("SPC" "A" "B" "a" "b" "p" "C-a"))))
214 (let (which-key-sort-uppercase-first)
215 (should
216 (equal
217 (mapcar #'car (sort (copy-sequence keys) #'which-key-key-order))
218 '("SPC" "a" "b" "p" "A" "B" "C-a"))))
219 (let ((which-key-sort-uppercase-first t))
220 (should
221 (equal
222 (mapcar #'car (sort (copy-sequence keys) #'which-key-key-order-alpha))
223 '("SPC" "A" "a" "B" "b" "p" "C-a"))))
224 (let (which-key-sort-uppercase-first)
225 (should
226 (equal
227 (mapcar #'car (sort (copy-sequence keys) #'which-key-key-order-alpha))
228 '("SPC" "a" "A" "b" "B" "p" "C-a"))))
229 (let ((which-key-sort-uppercase-first t))
230 (should
231 (equal
232 (mapcar #'car (sort (copy-sequence keys)
233 #'which-key-prefix-then-key-order))
234 '("SPC" "A" "B" "a" "b" "C-a" "p"))))
235 (let (which-key-sort-uppercase-first)
236 (should
237 (equal
238 (mapcar #'car (sort (copy-sequence keys)
239 #'which-key-prefix-then-key-order))
240 '("SPC" "a" "b" "A" "B" "C-a" "p"))))
241 (let ((which-key-sort-uppercase-first t))
242 (should
243 (equal
244 (mapcar 'car (sort (copy-sequence keys)
245 #'which-key-prefix-then-key-order-reverse))
246 '("p" "SPC" "A" "B" "a" "b" "C-a"))))
247 (let (which-key-sort-uppercase-first)
248 (should
249 (equal
250 (mapcar #'car (sort (copy-sequence keys)
251 #'which-key-prefix-then-key-order-reverse))
252 '("p" "SPC" "a" "b" "A" "B" "C-a"))))
253 (let ((which-key-sort-uppercase-first t))
254 (should
255 (equal
256 (mapcar #'car (sort (copy-sequence keys)
257 #'which-key-description-order))
258 '("p" "C-a" "SPC" "b" "B" "a" "A"))))
259 (let (which-key-sort-uppercase-first)
260 (should
261 (equal
262 (mapcar #'car (sort (copy-sequence keys)
263 #'which-key-description-order))
264 '("p" "C-a" "SPC" "b" "B" "a" "A"))))))
265
266(provide 'which-key-tests)
267;;; which-key-tests.el ends here