;;; 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.2

;; 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-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
  (if scroll-without-point-mode
      (progn
	(advice-add 'mwheel-scroll :before #'scroll-without-point--before-scroll)
	(advice-add 'mwheel-scroll :after #'scroll-without-point--after-scroll))
    (advice-remove 'mwheel-scroll #'scroll-without-point--before-scroll)
    (advice-remove 'mwheel-scroll #'scroll-without-point--after-scroll)))

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

(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--advice (f &rest args)
  "Advice for functions that should be disabled while scrolling
without point."
  (unless (and scroll-without-point-mode
	       scroll-without-point--scrollingp)
    (apply f args)))

(defun scroll-without-point--after-scroll (event)
  (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))
	(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 ()
  (unless (or (memq this-command '(mwheel-scroll handle-select-window))
	      (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)))))

    ;; Return to original position unless this is a mouse click
    (unless (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)
  (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--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 ()
  (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 ()
  (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 'paren
  (advice-add 'show-paren-function :around #'scroll-without-point--advice))

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

(provide 'scroll-without-point)

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