[WIP] Basic mouse support

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 <mouse-4>" prefix)) #'mwheel-scroll)
+      (local-set-key (kbd (format "%s <mouse-5>" prefix)) #'mwheel-scroll)
+
+      (with-current-buffer which-key--buffer
+        (local-set-key (kbd (format "%s <mouse-4>" prefix)) #'mwheel-scroll)
+        (local-set-key (kbd (format "%s <mouse-5>" 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)))))