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