;;; scroll-without-point.el --- modern mouse-wheel scrolling  -*- lexical-binding: t; -*-

;; Copyright (C) 2021 John Ankarström

;; Author: John Ankarström <john@ankarstrom.se>
;; Created: 2 Dec 2021
;; Version: 0.4

;; Keywords: scroll
;; URL: http://ankarstrom.se/~john/emacs/scroll-without-point.el

;; This file is not part of GNU Emacs.

;; Permission to use, copy, modify and/or distribute this software for
;; any purpose with or without fee is hereby granted.

;;; Commentary:

;; When `scroll-without-point-mode' is enabled, mouse-wheel scrolling
;; doesn't affect the position of the cursor or the transient mark.

;; Any command that isn't a mouse click returns the view to the
;; original position of the cursor. A mouse click repositions the
;; cursor without returning the view to the original position.

;; This behavior is closer to how modern text editors scroll. Note,
;; however, that `scroll-without-point-mode' affects only mouse-wheel
;; scrolling. It does NOT affect any other type of scrolling.

;; TODO: Support multiple windows with the same buffer.

;;; History:

;; 2021-12-10 (0.4)
;;    * Don't activate in all buffers.
;;    * Properly finish scrolling if scroll-without-point-mode was
;;      deactivated while cursor was "off-screen".

;; 2021-12-08 (0.3)
;;    * Add scroll-without-point-ignore-commands user option.
;;    * Don't return on move-to-window-line(-top-bottom).
;;    * Don't return after unbound key.

;; 2021-12-08 (0.2)
;;    * Add support for inactive windows.
;;    * Add support for hl-line-mode.

;;; Code:

;;;###autoload
(define-minor-mode scroll-without-point-mode
  "When `scroll-without-point-mode' is enabled, mouse-wheel
scrolling doesn't affect the position of the cursor or the
transient mark.

Any command that isn't a mouse click returns the view to the
original position of the cursor. A mouse click repositions the
cursor without returning the view to the original position.

This behavior is closer to how modern text editors scroll. Note,
however, that `scroll-without-point-mode' affects only mouse-wheel
scrolling. It does NOT affect any other type of scrolling."
  nil " SWP" nil)

;;;###autoload
(define-globalized-minor-mode global-scroll-without-point-mode
  scroll-without-point-mode
  scroll-without-point-mode)

(defcustom scroll-without-point-ignore-commands nil
  "List of additional commands to be ignored by `scroll-without-point-mode'.

Do not add potentially destructive commands to this list, such as
`helm-M-x'."
  :group 'scroll-without-point
  :type '(repeat symbol))

(defvar-local scroll-without-point--cursor-type t
  "Original cursor type.")

(defvar-local scroll-without-point--mark-active nil
  "True if mark was active before scroll.")

(defvar-local scroll-without-point--point nil
  "Original position of point before scroll.")

(defvar-local scroll-without-point--scrollingp nil
  "True if currently scrolling without point.")

(defvar-local scroll-without-point--window-start nil
  "Original position of window start before scroll.")

(defun scroll-without-point--after-scroll (event)
  "Restore/hide cursor after scroll."
  (with-current-buffer (window-buffer (caadr event))
    (when scroll-without-point--scrollingp
      (if (scroll-without-point--point-visible-p)
	  (when (not cursor-type)
	    (scroll-without-point--return)
	    (scroll-without-point--show)
	    ;; If scroll-without-point-mode was deactivated while
	    ;; cursor was "off-screen", stop scrolling without point.
	    (when (not scroll-without-point-mode)
	      (setq scroll-without-point--scrollingp nil)))
	(when cursor-type
	  (setq scroll-without-point--cursor-type cursor-type)
	  (setq cursor-type nil)
	  (when (and (boundp 'show-paren--overlay)
		     show-paren-mode)
	    (delete-overlay show-paren--overlay)
	    (delete-overlay show-paren--overlay-1))
	  (deactivate-mark))))))

(defun scroll-without-point--before-command ()
  "Stop scrolling without point before (certain) commands."
  (unless (or (not this-command)
	      (memq this-command (append '(mwheel-scroll handle-select-window) scroll-without-point-ignore-commands))
	      (and (memq this-command '(mouse-drag-region mouse-set-point))
		   (not (equal (window-at (cadr (mouse-position)) (cddr (mouse-position)) (car (mouse-position)))
			       (get-buffer-window)))))
    (unless (or (memq this-command '(move-to-window-line move-to-window-line-top-bottom))
		(and (listp last-input-event)
		     (memq (event-basic-type (car last-input-event)) '(mouse-1 mouse-2 mouse-3))))
      (scroll-without-point--return))
    (scroll-without-point--show)
    (remove-hook 'pre-command-hook #'scroll-without-point--before-command t)
    (setq scroll-without-point--scrollingp nil)))

(defun scroll-without-point--before-scroll (event)
  "Before scroll, save cursor state and start scrolling without point."
  (with-current-buffer (window-buffer (caadr event))
    (unless scroll-without-point--scrollingp
      (setq scroll-without-point--scrollingp t)
      (setq scroll-without-point--mark-active mark-active)
      (setq scroll-without-point--point (point))
      (add-hook 'pre-command-hook #'scroll-without-point--before-command 0 t))))

(defun scroll-without-point--run-unless-scrolling (f &rest args)
  "Run F with ARGS unless scrolling without point."
  (unless (and scroll-without-point-mode
	       scroll-without-point--scrollingp)
    (apply f args)))

(defun scroll-without-point--mwheel-scroll (f event)
  "Override mouse scroll while `scroll-without-point-mode' is active."
  (when scroll-without-point-mode
    (scroll-without-point--before-scroll event))
  (funcall f event)
  (when (or scroll-without-point-mode
	    scroll-without-point--scrollingp)
    (scroll-without-point--after-scroll event)))

(defun scroll-without-point--point-visible-p ()
  "Return true if point is fully visible in the current window."
  (let ((visible (pos-visible-in-window-p scroll-without-point--point (get-buffer-window) t)))
    (and visible (not (cddr visible)))))

(defun scroll-without-point--return ()
  "Restore cursor's original position and re-activate the mark."
  (with-selected-window (get-buffer-window)
      (goto-char scroll-without-point--point))
  (when scroll-without-point--mark-active
    (activate-mark)))

(defun scroll-without-point--show ()
  "Show the cursor again."
  (setq cursor-type scroll-without-point--cursor-type))

(defun scroll-without-point-return ()
  "Manually return to original position before mouse scroll."
  (interactive)
  (goto-char scroll-without-point--point))

(with-eval-after-load 'mwheel
  (advice-add 'mwheel-scroll :around #'scroll-without-point--mwheel-scroll))

(with-eval-after-load 'paren
  (advice-add 'show-paren-function :around #'scroll-without-point--run-unless-scrolling))

(with-eval-after-load 'hl-line
  (advice-add 'hl-line-move :around #'scroll-without-point--run-unless-scrolling))

(provide 'scroll-without-point)

;;; scroll-without-point.el ends here