From: Tak Kunihiro <homeros.misasa@gmail.com>
To: Dani Moncayo <dmoncayo@gmail.com>
Cc: 27932@debbugs.gnu.org, "Richard M. Stallman" <rms@gnu.org>
Subject: bug#27932: 26.0.50; Feature request: prevent scroll commands from changing the buffer location of point
Date: Mon, 07 Aug 2017 21:32:41 +0900 [thread overview]
Message-ID: <m17eyfpnh2.fsf@misasa.okayama-u.ac.jp> (raw)
In-Reply-To: <CAH8Pv0iPd==2KmqvEKM4wOPn1ext5cQYqKTU8v4-nz0x31JUxg@mail.gmail.com> (Dani Moncayo's message of "Mon, 7 Aug 2017 07:54:21 +0200")
> The proposed feature is that any _scrolling_command_ (e.g. C-v, M-v,
> mouse-wheel, ...) should perform its scrolling without altering the
> location of point (wrt its buffer).
I propose targeting mouse-wheel and scroll-bar-toolkit-scroll only, and
having a pseudo point.
This is in a middle, but I think building blocks are there.
;;; touchpad.el --- Scroll two dimensionally by touchpad
;; Copyright (C) 2017 Tak Kunihiro
;; Author: Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
;; Package-Requires: ((emacs "26"))
;; Keywords: mouse
;; Version: 1.0
;; This program 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.
;; This program 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 This program. If not, see <http://www.gnu.org/licenses/>.
;; Usage:
;;
;; To interactively toggle the mode:
;;
;; M-x touchpad-mode RET
;;
;; To make the mode permanent, put these in your init file:
;;
;; (require 'touchpad)
;; (touchpad-mode 1)
;;; Commentary:
;; Touchpad mode is a global minor mode which makes swiping touchpad
;; scroll smoothly. This package disables `auto-hscroll-mode' during
;; scroll by the touchpad because of following two aspects.
;; (1) It should be off during vertical scroll. Let’s consider a
;; buffer with empty and long alternative lines and when point is
;; at the end of a long line at the top of window. After
;; `scroll-up 1', point jumps to the beginning of the next empty
;; line and you see scope shifts suddenly leftward. This behavior
;; is sometimes unexpected one.
;; (2) It should be off during horizontal scroll. During horizontal
;; scroll, you may scroll a little in vertical direction without
;; intention. The horizontal scroll should be tolerance against
;; such perturbation.
;; After scroll by the touchpad, you want to set `auto-hscroll-mode'
;; back again otherwise too inconvenient for edition by the keyboard.
;;
;; Approach of this package is to turn on another minor-mode
;; `touchpad--view-mode' with `auto-hscroll-mode' nil, at the beginning
;; of `mwheel-scroll'. The minor mode is turned off upon key input
;; from the keyboard that moves point.
;;
;; This package also converts point and region to
;; `mouse-secondary-start' and `mouse-secondary-overlay'. When
;; `touchpad-restore-point-flag' is non-nil, point will be moved to
;; `mouse-secondary-start' when `touchpad--view-mode' is turned off.
;;; Code:
(require 'mwheel)
(defvar touchpad-restore-point-flag t
"Restore point when `touchpad--view-mode' is turned off.")
(defvar touchpad--cursor-type cursor-type
"Cursor used by user.
This variable is used internally to restore original `cursor-type'.")
(defvar touchpad--auto-hscroll-mode nil
"Value of auto-hscroll-mode specified by user.
This variable is used internally to restore original `auto-hscroll-mode'.")
;;;###autoload
(define-minor-mode touchpad-mode
"A minor mode to scroll text two dimensionally.
With a prefix argument ARG, enable Touchpad Mode if ARG is
positive, and disable it otherwise. If called from Lisp, enable
Touchpad Mode if ARG is omitted or nil."
:init-value nil
:group 'scrolling
:global t
:version "26.1"
:keymap (let ((map (make-sparse-keymap)))
;; Extend primary by shift click
(define-key map [S-down-mouse-1] 'ignore)
(define-key map [S-mouse-1] 'mouse-save-then-kill)
(if (not (eq system-type 'ms-dos))
(global-set-key [C-S-down-mouse-1] 'mouse-appearance-menu))
;; Change size of font ize by wheel up and down
(define-key map (kbd "<C-wheel-up>") 'touchpad-text-scale-increase)
(define-key map (kbd "<C-wheel-down>") 'touchpad-text-scale-decrease)
map)
(if touchpad-mode
(progn
(advice-add 'mwheel-scroll :before 'touchpad-enable--view-mode)
;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2017-04/msg00700.html
;; (add-hook 'mwheel-pre-scroll-hook 'touchpad-enable--view-mode)
(advice-add 'ns-handle-scroll-bar-event :before 'touchpad-enable--view-mode)
(advice-add 'scroll-bar-toolkit-scroll :before 'touchpad-enable--view-mode)
(setq mwheel-tilt-scroll-p t))
(advice-remove 'mwheel-scroll #'touchpad-enable--view-mode)
;; (remove-hook 'mwheel-pre-scroll-hook 'touchpad-enable--view-mode)
(advice-remove 'ns-handle-scroll-bar-event #'touchpad-enable--view-mode)
(advice-remove 'scroll-bar-toolkit-scroll #'touchpad-enable--view-mode)
(dolist (var '(mwheel-tilt-scroll-p))
(custom-reevaluate-setting var))))
;;; To enable Enable minor mode by hook instead of advice, patch shown
;;; by following URL should be accepted.
;;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2017-04/msg00700.html
;; (defun touchpad-enable--view-mode ()
;; "Enable minor mode `touchpad--view-mode' to disable `auto-hscroll-mode'.
;; This is supposed to be called before actual scrolling."
;; (let ((buffer (window-buffer (mwheel-event-window last-input-event))))
;; (with-current-buffer buffer
;; (touchpad--view-mode 1)))) ; Turn on minor-mode.
(defun touchpad-enable--view-mode (func &rest args)
"Enable minor mode `touchpad--view-mode' to disable `auto-hscroll-mode'.
This is supposed to be adviced before `mwheel-scroll'."
(let ((buffer (window-buffer (mwheel-event-window last-input-event)))
(point (point)))
(when auto-hscroll-mode
(setq touchpad--auto-hscroll-mode auto-hscroll-mode)) ; 26.1
(unless touchpad--view-mode ; Switch from off to on.
(when (fboundp 'mouse-set-secondary-from-primary)
(mouse-set-secondary-from-primary))
(when touchpad-restore-point-flag
(touchpad-set-point point))
(with-current-buffer buffer
(touchpad--view-mode 1)))))
(copy-face 'cursor 'touchpad-point-face) ; 'cursor, 'region, 'secondary-selection, 'mode-line
;; (set-face-foreground 'touchpad-point-face "white")
(defun touchpad-point-overlay ()
"Return an overlay which records the current point in the visiting buffer."
(let ((overlays (overlays-in (point-min) (point-max)))
ol)
(while overlays
(let ((overlay (car overlays)))
(if (eq (overlay-get overlay 'face) 'touchpad-point-face)
(progn (setq ol overlay)
(setq overlays nil))
(setq overlays (cdr overlays)))))
(unless ol
;; create a new overlay.
;; (info "(elisp) Overlay Properties")
(setq ol (make-overlay (point-min) (point-min) nil t t))
(delete-overlay ol)
;; (overlay-put ol 'priority 100)
(overlay-put ol 'face 'touchpad-point-face))
ol))
(defun touchpad-set-point (pos)
"Move `touchpad-point-overlay' to the current point."
(if (eolp)
(let ((string (propertize "|" 'face 'touchpad-point-face))) ; "|", " "
(move-overlay (touchpad-point-overlay) pos pos) ; empty overlay cursor char
(overlay-put (touchpad-point-overlay) 'after-string string))
(when (overlay-get (touchpad-point-overlay) 'after-string)
(overlay-put (touchpad-point-overlay) 'after-string nil)) ; remove cursor char
(move-overlay (touchpad-point-overlay) pos (1+ pos))))
(defun touchpad-remove-point ()
"Remove `touchpad-point-overlay' in the visiting buffer."
(when (overlay-get (touchpad-point-overlay) 'after-string)
(overlay-put (touchpad-point-overlay) 'after-string nil)) ; remove cursor char
(delete-overlay (touchpad-point-overlay))) ; remove overlay
(defun touchpad-point ()
"Return point from `touchpad-point-overlay'."
(overlay-start (touchpad-point-overlay)))
;;; Following definition is necessary until the patch is accepted by
;;; bug-gnu-emacs. The code should be located on `mouse.el'.
;;; http://lists.gnu.org/archive/html/bug-gnu-emacs/2017-06/msg00938.html
(unless (fboundp 'mouse-set-secondary-from-primary)
(defun mouse-set-secondary-from-primary ()
"Set the secondary selection to text in the region.
When region does not exists, set mouse-secondary-start to the point.
When point is in the secondary selection, do nothing."
(interactive)
(cond
((region-active-p) ; Create mouse-secondary-overlay from region.
(delete-overlay mouse-secondary-overlay)
(move-overlay mouse-secondary-overlay (region-beginning) (region-end)))
((member 'secondary-selection ; Do nothing.
(mapcar (lambda (xxx) (overlay-get xxx 'face))
(overlays-at (point)))))
(t (delete-overlay mouse-secondary-overlay) ; Create mouse-secondary-start from point.
(push-mark (point))
(setq mouse-secondary-start (make-marker))
(move-marker mouse-secondary-start (point))))))
(defun touchpad-disable--view-mode ()
"Disable minor mode `touchpad--view-mode' to enable `auto-hscroll-mode' back.
Then invoke command that is bound to the original key."
(interactive)
(touchpad--view-mode 0) ; Turn off minor-mode.
(when touchpad-restore-point-flag
(touchpad-remove-point))
(call-interactively (key-binding (this-command-keys))))
(defun touchpad-disable--view-mode-1 ()
"Restore point then call `touchpad-disable--view-mode'."
(interactive)
(when touchpad-restore-point-flag
(goto-char (touchpad-point))
(touchpad-remove-point))
(touchpad-disable--view-mode))
(define-minor-mode touchpad--view-mode
"A minor-mode with `auto-hscroll-mode' off.
This minor mode is used internally."
:init-value nil
:lighter " view"
:keymap (let ((map (make-sparse-keymap)))
;; Extend secondary instead of primary by shift click.
(define-key map [remap mouse-save-then-kill] 'mouse-secondary-save-then-kill)
;; Turn off touchpad--view-mode and do what is supposed to do.
;; * do not restore point
(define-key map [remap mouse-set-region] 'touchpad-disable--view-mode)
;; (define-key map [remap mouse-drag-region] 'touchpad-disable--view-mode) ; Lisp nesting exceeds ‘max-lisp-eval-depth’
(define-key map [remap keyboard-quit] 'touchpad-disable--view-mode)
(define-key map [remap mouse-set-point] 'touchpad-disable--view-mode)
(define-key map [remap mark-whole-buffer] 'touchpad-disable--view-mode)
(define-key map [remap mark-page] 'touchpad-disable--view-mode)
(define-key map [remap mark-paragraph] 'touchpad-disable--view-mode)
(define-key map [remap mark-word] 'touchpad-disable--view-mode)
(define-key map [remap goto-char] 'touchpad-disable--view-mode)
(define-key map [remap goto-line] 'touchpad-disable--view-mode)
(define-key map [remap move-to-column] 'touchpad-disable--view-mode)
(define-key map [remap isearch-forward] 'touchpad-disable--view-mode)
(define-key map [remap isearch-backward] 'touchpad-disable--view-mode)
;; (define-key map [remap scroll-up-command] 'touchpad-disable--view-mode)
;; (define-key map [remap scroll-down-command] 'touchpad-disable--view-mode)
;; (define-key map [remap beginning-of-buffer] 'touchpad-disable--view-mode)
;; (define-key map [remap end-of-buffer] 'touchpad-disable--view-mode)
;; * restore point
(define-key map [remap recenter-top-bottom] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap right-char] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap forward-char] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap forward-word] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap forward-sentence] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap forward-paragraph] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap forward-page] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap left-char] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap backward-char] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap backward-word] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap backward-sentence] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap backward-paragraph] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap backward-page] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap move-beginning-of-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap beginning-of-visual-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap move-end-of-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap end-of-visual-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap next-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap next-error] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap previous-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap previous-error] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap beginning-of-defun] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap end-of-defun] 'touchpad-disable--view-mode-1) ; restore point
;; * restore point and revise buffer
(define-key map [remap self-insert-command] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap delete-char] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap kill-word] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap kill-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap quoted-insert] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap transpose-chars] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap transpose-words] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap yank] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap toggle-input-method] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap delete-backward-char] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap just-one-space] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap dabbrev-expand] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap mark-sexp] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap delete-indentation] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap helm-command-prefix] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap paredit-backward-slurp-sexp] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap paredit-splice-sexp-killing-backward] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap mark-sexp] 'touchpad-disable--view-mode-1) ; restore point
;; * local setup
(define-key map [remap mew-summary-previous-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap mew-summary-next-line] 'touchpad-disable--view-mode-1) ; restore point
(define-key map [remap skk-insert] 'touchpad-disable--view-mode-1) ; restore point
map)
:group 'scrolling
(if touchpad--view-mode
(progn
(setq-local auto-hscroll-mode nil)
(setq-local cursor-type 'hollow))
(setq-local auto-hscroll-mode touchpad--auto-hscroll-mode)
(setq-local cursor-type touchpad--cursor-type)))
(defun touchpad-text-scale-increase (event)
"Increase the height of the default face in the current buffer by 1 step."
(interactive "e")
(save-excursion
(mouse-set-point event)
(text-scale-increase 1)))
(defun touchpad-text-scale-decrease (event)
"Decrease the height of the default face in the current buffer by 1 step."
(interactive "e")
(save-excursion
(mouse-set-point event)
(text-scale-decrease 1)))
;;;; ChangeLog:
;; 2017-08-07 Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
;;
;; touchpad-mode: version 1.0
;;
;; * touchpad.el: New package.
(provide 'touchpad)
;;; touchpad.el ends here
next prev parent reply other threads:[~2017-08-07 12:32 UTC|newest]
Thread overview: 19+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-08-03 13:34 bug#27932: 26.0.50; Feature request: prevent scroll commands from changing the buffer location of point Dani Moncayo
2017-08-03 16:42 ` Eli Zaretskii
[not found] ` <CAH8Pv0gjYZZAfciNTaqKcj37C51dSdJOzD+4AZFFY2wjOu6Fgg@mail.gmail.com>
[not found] ` <83ini3yi49.fsf@gnu.org>
2017-08-04 6:34 ` Dani Moncayo
2017-08-04 21:36 ` Richard Stallman
2017-08-05 6:44 ` Eli Zaretskii
2017-08-05 20:19 ` Richard Stallman
2017-08-06 17:18 ` Eli Zaretskii
2017-08-06 21:00 ` Dani Moncayo
2017-08-07 2:28 ` Eli Zaretskii
2017-08-07 5:54 ` Dani Moncayo
2017-08-07 12:32 ` Tak Kunihiro [this message]
2017-08-07 16:38 ` Eli Zaretskii
2017-08-07 21:09 ` Dani Moncayo
2017-08-03 17:56 ` martin rudalics
2017-08-03 23:16 ` Tak Kunihiro
2017-08-04 6:15 ` Eli Zaretskii
2017-08-04 6:39 ` Tak Kunihiro
2017-08-04 8:01 ` Eli Zaretskii
2017-08-04 10:33 ` Tak Kunihiro
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=m17eyfpnh2.fsf@misasa.okayama-u.ac.jp \
--to=homeros.misasa@gmail.com \
--cc=27932@debbugs.gnu.org \
--cc=dmoncayo@gmail.com \
--cc=rms@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.