From e857c79874b65f0ff8d83c5622c0748cb795d5b1 Mon Sep 17 00:00:00 2001 From: Stefan Kangas 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 . + +;;; 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