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