diff --git a/which-key.el b/which-key.el index 825e1cb..49be931 100644 --- a/which-key.el +++ b/which-key.el @@ -410,8 +410,10 @@ prefixes in `which-key-paging-prefixes'" (defvar which-key--paging-functions '(which-key-C-h-dispatch which-key-turn-page which-key-show-next-page-cycle + which-key-show-next-page-cycle-mouse which-key-show-next-page-no-cycle which-key-show-previous-page-cycle + which-key-show-previous-page-cycle-mouse which-key-show-previous-page-no-cycle which-key-undo-key which-key-undo)) @@ -941,9 +943,31 @@ total height." ;;; Show/hide which-key buffer +(defun which-key--mouse-event-inside-which-key-p (event) + "Determine if the mouse EVENT occurred inside which-key buffer." + ;; TODO: How to handle 'custom popup types + (cl-case which-key-popup-type + ;; Emacs hides the minibuffer by default, I have not found a way to disable + ;; that temporarily yet, as such the case below does not really help + (minibuffer (minibufferp (window-buffer (posn-window (event-start event))))) + (side-window (and (buffer-live-p which-key--buffer) + (equal (posn-window (event-start event)) + (get-buffer-window which-key--buffer)))) + (frame (and (frame-live-p which-key--frame) + (equal (window-frame (posn-window (event-start event))) + (get-buffer-window which-key--frame)))))) + (defun which-key--hide-popup () "This function is called to hide the which-key buffer." - (unless (member real-this-command which-key--paging-functions) + (unless (or (member real-this-command which-key--paging-functions) + ;; Do not hide the popup the if the last event was a mouse + ;; event and was inside which-key popup + (and (or (mouse-event-p last-command-event) + ;; 'mwheel-scroll events are not recognized as mouse + ;; events + (equal real-this-command 'mwheel-scroll)) + (which-key--mouse-event-inside-which-key-p last-command-event))) + (setq which-key--current-page-n nil which-key--current-prefix nil which-key--using-top-level nil @@ -952,6 +976,7 @@ total height." which-key--current-show-keymap-name nil which-key--prior-show-keymap-args nil which-key--on-last-page nil) + (when (and which-key-idle-secondary-delay which-key--secondary-timer-active) (which-key--start-timer)) @@ -1002,7 +1027,13 @@ is shown, or if there is no need to start the closing timer." ;; (minibuffer (which-key--show-buffer-minibuffer act-popup-dim)) (side-window (which-key--show-buffer-side-window act-popup-dim)) (frame (which-key--show-buffer-frame act-popup-dim)) - (custom (funcall which-key-custom-show-popup-function act-popup-dim))))) + (custom (funcall which-key-custom-show-popup-function act-popup-dim))) + (when (and (bufferp which-key--buffer) + (buffer-live-p which-key--buffer)) + (with-current-buffer which-key--buffer + (setq-local mwheel-scroll-up-function 'which-key-show-next-page-cycle-mouse) + (setq-local mwheel-scroll-down-function 'which-key-show-previous-page-cycle-mouse))) + (which-key--setup-popup-mouse-scrolling-map))) (defun which-key--fit-buffer-to-window-horizontally (&optional window &rest params) "Slightly modified version of `fit-buffer-to-window'. @@ -1772,6 +1803,17 @@ including prefix arguments." (concat (which-key--propertize-key str) (propertize dash 'face 'which-key-key-face))))) +(defun which-key--setup-popup-mouse-scrolling-map () + "Generate map to be used to scroll the popup." + (when which-key--current-prefix + (let ((prefix (key-description which-key--current-prefix))) + (local-set-key (kbd (format "%s " prefix)) #'mwheel-scroll) + (local-set-key (kbd (format "%s " prefix)) #'mwheel-scroll) + + (with-current-buffer which-key--buffer + (local-set-key (kbd (format "%s " prefix)) #'mwheel-scroll) + (local-set-key (kbd (format "%s " prefix)) #'mwheel-scroll))))) + (defun which-key--get-popup-map () "Generate transient-map for use in the top level binding display." (unless which-key--current-prefix @@ -1943,6 +1985,19 @@ case do nothing." (which-key-turn-page 0) (which-key-turn-page -1)))) +(defun which-key-show-next-page-cycle-mouse (event) + "Show the next page of keys, cycling from end to beginning +after last page." + (interactive "e") + (which-key-show-next-page-cycle)) + +(defun which-key-show-previous-page-cycle-mouse (event) + + "Show the previous page of keys, cycling from end to beginning +after last page." + (interactive "e") + (which-key-show-previous-page-cycle)) + ;;;###autoload (defun which-key-show-next-page-cycle () "Show the next page of keys, cycling from end to beginning @@ -2268,7 +2323,10 @@ Finally, show the buffer." (setq which-key--paging-timer (run-with-idle-timer 0.2 t (lambda () - (when (or (not (member real-last-command which-key--paging-functions)) + (when (or (not (or (member real-last-command which-key--paging-functions) + (and (or (mouse-event-p last-command-event) + (equal real-last-command 'mwheel-scroll)) + (which-key--mouse-event-inside-which-key-p last-command-event)))) (and (< 0 (length (this-single-command-keys))) (not (equal which-key--current-prefix (this-single-command-keys)))))