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