bug#5557: <left-margin> <double-wheel-down> is undefined

[Stefan Kangas <stefan@marxist.se>]

[-- Attachment #1: Type: text/plain, Size: 497 bytes --]

tags 5557 + patch
thanks

martin rudalics <rudalics@gmx.at> writes:

> Nowadays practically all applications scroll the window vertically
> regardless of where the mouse pointer is - even when it's on the
> horizontal scroll bar.  The only exception is the title bar where some
> window managers optionally "roll" the window in or out.

That strengthens the case for doing the same in Emacs.

I have attached a patch which implements this functionality.
Any comments?

Best regards,
Stefan Kangas

[-- Attachment #2: 0001-Bind-mwheel-scroll-also-for-fringe-and-margin.patch --]
[-- Type: text/x-diff, Size: 5361 bytes --]

From e857c79874b65f0ff8d83c5622c0748cb795d5b1 Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefankangas@gmail.com>
Date: Thu, 13 Aug 2020 07:30:03 +0200
Subject: [PATCH] Bind mwheel-scroll also for fringe and margin

* lisp/mwheel.el (mouse-wheel-mode): Bind mwheel-scroll also for
fringe and margin.
(mouse-wheel--create-scroll-keys)
(mouse-wheel--create-scroll-keys-get-key): New helper functions
for 'mouse-wheel-mode'.

* lisp/emacs-lisp/cl-lib.el (cl-mapcar): Add autoload cookie.
* test/lisp/mwheel-tests.el: New file.
---
 lisp/emacs-lisp/cl-lib.el |  1 +
 lisp/mwheel.el            | 26 ++++++++++++++++++++++++--
 test/lisp/mwheel-tests.el | 39 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 64 insertions(+), 2 deletions(-)
 create mode 100644 test/lisp/mwheel-tests.el

diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 7a26d9a90f..7595fc4ee6 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -347,6 +347,7 @@ 'cl-copy-seq
 
 (declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs &optional acc))
 
+;;;###autoload
 (defun cl-mapcar (cl-func cl-x &rest cl-rest)
   "Apply FUNCTION to each element of SEQ, and make a list of the results.
 If there are several SEQs, FUNCTION is called with that many arguments,
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 317f2cd8ed..9697126dc2 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -360,6 +360,26 @@ mouse-wheel--remove-bindings
     (when (memq (lookup-key (current-global-map) key) funs)
       (global-unset-key key))))
 
+(defun mouse-wheel--create-scroll-keys-get-key (binding event)
+  "Given BINDING and EVENT, return symbol for key.
+Arguments are like in `mouse-wheel--create-scroll-keys'."
+  (intern (concat (pcase (caar binding)
+                    ('alt "A-") ('control "C-") ('hyper "H-")
+                    ('meta "M-") ('shift "S-") ('super "s-"))
+                  (symbol-name event))))
+
+(defun mouse-wheel--create-scroll-keys (binding event)
+  "Return list of key vectors for BINDING and EVENT.
+BINDING is an element in `mouse-wheel-scroll-amount'.  EVENT is
+an event used for scrolling, e.g. `mouse-wheel-down-event'."
+  (let ((prefixes (list 'left-margin 'right-margin
+                        'left-fringe 'right-fringe))
+        (key (if (consp binding)
+                 (mouse-wheel--create-scroll-keys-get-key binding event)
+               event)))
+    (cons (vector key) ; default case: no prefix.
+          (cl-mapcar #'vector prefixes (make-list (length prefixes) key)))))
+
 (define-minor-mode mouse-wheel-mode
   "Toggle mouse wheel support (Mouse Wheel mode)."
   :init-value t
@@ -384,14 +404,16 @@ mouse-wheel-mode
        ;; Bindings for changing font size.
        ((and (consp binding) (eq (cdr binding) 'text-scale))
         (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
+          ;; Add binding.
           (let ((key `[,(list (caar binding) event)]))
             (global-set-key key 'mouse-wheel-text-scale)
             (push key mwheel-installed-text-scale-bindings))))
        ;; Bindings for scrolling.
        (t
         (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
-                             mouse-wheel-right-event mouse-wheel-left-event))
-          (let ((key `[(,@(if (consp binding) (car binding)) ,event)]))
+                             mouse-wheel-left-event mouse-wheel-right-event))
+          (dolist (key (mouse-wheel--create-scroll-keys binding event))
+            ;; Add binding.
             (global-set-key key 'mwheel-scroll)
             (push key mwheel-installed-bindings))))))))
 
diff --git a/test/lisp/mwheel-tests.el b/test/lisp/mwheel-tests.el
new file mode 100644
index 0000000000..737154cb78
--- /dev/null
+++ b/test/lisp/mwheel-tests.el
@@ -0,0 +1,39 @@
+;;; mwheel-tests.el --- tests for mwheel.el  -*- lexical-binding:t -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'mwheel)
+
+(ert-deftest mwheel-test--create-scroll-keys-get-key ()
+  (should (equal (mouse-wheel--create-scroll-keys-get-key '((shift) . 1) 'mouse-7)
+                 'S-mouse-7))
+  (should (equal (mouse-wheel--create-scroll-keys-get-key '((meta) . 9) 'mouse-4)
+                 'M-mouse-4)))
+
+(ert-deftest mwheel-test--create-scroll-keys ()
+  (should (equal (mouse-wheel--create-scroll-keys '((shift) . 1) 'mouse-7)
+                 '([S-mouse-7]
+                   [left-margin S-mouse-7]
+                   [right-margin S-mouse-7]
+                   [left-fringe S-mouse-7]
+                   [right-fringe S-mouse-7]))))
+
+;;; mwheel-tests.el ends here
-- 
2.28.0