diff --git a/ai-code-ghostel-image-preview.el b/ai-code-ghostel-image-preview.el index 28465d80..055446f4 100644 --- a/ai-code-ghostel-image-preview.el +++ b/ai-code-ghostel-image-preview.el @@ -227,6 +227,85 @@ ordinary pixel-scroll command." (overlay-get overlay 'ai-code-session-image-preview)) (overlays-at (window-start window)))))) +(defun ai-code-ghostel-image-preview--preview-above (window pixels) + "Return the preview an upward scroll of PIXELS in WINDOW would enter. +The value is (OVERLAY . ROWS): OVERLAY is the nearest local preview +ending at or above WINDOW's start, and ROWS counts the rows between its +lower edge and that start. Return nil when WINDOW already starts at a +preview, and when the scroll stops at or below the preview's lower edge." + (when (and (window-live-p window) + (buffer-live-p (window-buffer window)) + (not (ai-code-ghostel-image-preview--preview-at-window-start-p + window))) + (with-current-buffer (window-buffer window) + (let* ((start (window-start window)) + (line-height (with-selected-window window + (default-line-height))) + (reach (- pixels (window-vscroll window t))) + nearest) + (when (> reach 0) + ;; A preview ROWS rows above is entered once the scroll exceeds + ;; the height of those rows. + (let ((limit (save-excursion + (goto-char start) + (forward-line (- (/ (1- reach) line-height))) + (point)))) + (dolist (overlay (overlays-in (max (point-min) (1- limit)) start)) + (let ((end (overlay-end overlay))) + (when (and (overlay-get overlay + 'ai-code-session-image-preview) + (<= limit end start) + (or (null nearest) + (> end (overlay-end nearest)))) + (setq nearest overlay)))))) + (when nearest + (cons nearest (count-lines (overlay-end nearest) start))))))) + +(defun ai-code-ghostel-image-preview--preview-on-window-start-row-p (window) + "Return non-nil when WINDOW starts on the link row of a local preview." + (when (and (window-live-p window) + (buffer-live-p (window-buffer window))) + (with-current-buffer (window-buffer window) + (save-excursion + (goto-char (window-start window)) + (cl-some + (lambda (overlay) + (overlay-get overlay 'ai-code-session-image-preview)) + (overlays-at (line-end-position))))))) + +(defun ai-code-ghostel-image-preview--preview-pixel-height (overlay window) + "Return the pixel height in WINDOW of OVERLAY's preview and its link row. +The link row and the row holding the image make one display line as far +as scrolling is concerned." + (let ((line-height (with-selected-window window (default-line-height))) + (image-height + (or (ignore-errors + (cdr (image-size (overlay-get overlay 'display) t + (window-frame window)))) + 0))) + (+ line-height (max line-height (ceiling image-height))))) + +(defun ai-code-ghostel-image-preview--enter-preview-from-below + (window overlay pixels) + "Start WINDOW on OVERLAY's link row with the preview's last PIXELS in view. +Return the pixels left to scroll once the whole preview is in view. + +The window starts at the beginning of the link row and hides the rest +with its vscroll, which is how `pixel-scroll-precision' and +`ultra-scroll' themselves leave a window inside a tall line. Starting +at OVERLAY itself would start it in the middle of that line, and +`ultra-scroll' then takes the line for one it has not shown yet." + (let* ((height (ai-code-ghostel-image-preview--preview-pixel-height + overlay window)) + (shown (min pixels height))) + (set-window-start window + (with-current-buffer (window-buffer window) + (save-excursion + (goto-char (overlay-start overlay)) + (line-beginning-position)))) + (ai-code-ghostel-image-preview--set-window-vscroll window (- height shown)) + (- pixels shown))) + (defun ai-code-ghostel-image-preview--clamp-up-event (event window) "Clamp upward EVENT to WINDOW's partially hidden preview top." (let* ((delta-pair (nth 4 event)) @@ -883,6 +962,25 @@ Optional DELAYS overrides the default scan delays." (ai-code-ghostel-image-preview-schedule-visible-linkify window (list ai-code-ghostel-image-preview-scroll-linkify-delay))) +(defun ai-code-ghostel-image-preview--scroll-up-onto-preview (event window) + "Scroll WINDOW onto the preview above it for upward wheel EVENT. +Return non-nil when EVENT was handled here. Both `ultra-scroll' and +`pixel-scroll-precision' can fail to cross a preview's lower edge +upwards, and then leave the window on the row below the preview." + (let* ((delta-pair (and (consp event) (nth 4 event))) + ;; emacs-mac has no pixel delta pair: it reports trackpad pixels + ;; in a property list in place of the line count. + (plist (and (consp event) (nth 3 event))) + (delta (cond ((consp delta-pair) (cdr delta-pair)) + ((consp plist) (plist-get plist :scrolling-delta-y))))) + (when (and (numberp delta) + (> delta 0) + (ai-code-ghostel-image-preview--preview-above + window (round delta))) + (with-selected-window window + (ai-code-ghostel-image-preview--scroll-pixels (- (round delta)))) + t))) + (defun ai-code-ghostel-image-preview-scroll (event) "Handle precision scroll EVENT in an enabled Ghostel session." (interactive "e") @@ -890,20 +988,25 @@ Optional DELAYS overrides the default scan delays." (selected-window)))) (when (window-live-p window) (ai-code-ghostel-image-preview--note-user-scroll window)) - (if (and window - ai-code-ghostel-image-preview-prefer-ultra-scroll - (ai-code-ghostel-image-preview--window-has-preview-p window) - (or (fboundp 'ultra-scroll) - (require 'ultra-scroll nil t))) - (let ((event - (ai-code-ghostel-image-preview--clamp-up-event event window))) - (if (and (featurep 'mac-win) - (fboundp 'ultra-scroll-mac)) - (ultra-scroll-mac event) - (ultra-scroll event))) - (if (fboundp 'pixel-scroll-precision) - (pixel-scroll-precision event) - (mwheel-scroll event))) + (cond + ((and (window-live-p window) + (ai-code-ghostel-image-preview--scroll-up-onto-preview + event window))) + ((and window + ai-code-ghostel-image-preview-prefer-ultra-scroll + (ai-code-ghostel-image-preview--window-has-preview-p window) + (or (fboundp 'ultra-scroll) + (require 'ultra-scroll nil t))) + (let ((event + (ai-code-ghostel-image-preview--clamp-up-event event window))) + (if (and (featurep 'mac-win) + (fboundp 'ultra-scroll-mac)) + (ultra-scroll-mac event) + (ultra-scroll event)))) + ((fboundp 'pixel-scroll-precision) + (pixel-scroll-precision event)) + (t + (mwheel-scroll event))) (when (window-live-p window) (ai-code-ghostel-image-preview-schedule-visible-linkify window (list ai-code-ghostel-image-preview-scroll-linkify-delay))))) @@ -925,7 +1028,8 @@ FORWARD is non-nil when the scroll revealed later text. A window that starts at a preview first draws the preview's leading newline as an empty row: skip that row forward, or show the preview's link row backward. A text row left partly hidden is shown whole so rows stay -aligned once an image preview scrolls out of view." +aligned once an image preview scrolls out of view; a preview's link row +is left alone while it hides part of the image below it." (let ((vscroll (window-vscroll window t)) (line-height (with-selected-window window (default-line-height)))) (cond @@ -936,9 +1040,30 @@ aligned once an image preview scrolls out of view." window line-height) (ai-code-ghostel-image-preview--show-link-row window)))) ((and (/= old-start (window-start window)) - (> vscroll 0)) + (> vscroll 0) + (or (< vscroll line-height) + (not + (ai-code-ghostel-image-preview--preview-on-window-start-row-p + window)))) (ai-code-ghostel-image-preview--set-window-vscroll window 0))))) +(defun ai-code-ghostel-image-preview--keep-point-visible (window) + "Move WINDOW's point up onto a row WINDOW shows whole. +Scrolling toward earlier text pushes the last rows out of WINDOW. With +point left on one of them, redisplay scrolls back to show point, which +undoes the scroll." + (with-current-buffer (window-buffer window) + (unless (pos-visible-in-window-p (window-point window) window) + (let ((start (window-start window))) + (set-window-point + window + (save-excursion + (goto-char (max start (or (window-end window t) start))) + (while (and (> (point) start) + (not (pos-visible-in-window-p (point) window))) + (forward-line -1)) + (point))))))) + (defun ai-code-ghostel-image-preview--scroll-pixels (pixels) "Scroll the selected window by PIXELS toward later text. Negative PIXELS scroll toward earlier text." @@ -947,29 +1072,57 @@ Negative PIXELS scroll toward earlier text." (forward (> pixels 0))) (if forward (pixel-scroll-precision-scroll-down pixels) - (let ((pixels (- pixels)) - (vscroll (window-vscroll window t))) - ;; From the top of a preview, `pixel-scroll-precision-scroll-up' - ;; can fail to measure the row above it and signal - ;; `beginning-of-buffer' instead of scrolling. Step onto the - ;; preview's link row, which lies VSCROLL pixels above. - (when (and (> pixels vscroll) - (ai-code-ghostel-image-preview--preview-at-window-start-p - window)) - (ai-code-ghostel-image-preview--show-link-row window) - (setq pixels (- pixels vscroll))) - (when (> pixels 0) - (pixel-scroll-precision-scroll-up pixels)))) - (ai-code-ghostel-image-preview--align-window-start window start forward))) + (let ((pixels (- pixels))) + ;; Emacs cannot always measure backwards across a preview. From + ;; the rows below one, `pixel-scroll-precision-scroll-up' can + ;; signal `beginning-of-buffer' and leave the window stuck there. + ;; Walk to the preview's lower edge and step onto it by hand. + (when-let* ((above (ai-code-ghostel-image-preview--preview-above + window pixels))) + (let ((rows (cdr above)) + (line-height (default-line-height))) + (setq pixels + (ai-code-ghostel-image-preview--enter-preview-from-below + window (car above) + (- pixels + (window-vscroll window t) + ;; A window starting right below a preview draws the + ;; preview's trailing newline as an empty row at its + ;; top. The preview's last pixels take its place. + (if (zerop rows) + (- line-height) + (* rows line-height)))))) + ;; The preview was not in view when the caller recorded the + ;; scroll. Record it now, or Ghostel anchors the window back to + ;; live output on its next redraw. + (ai-code-ghostel-image-preview--note-user-scroll window)) + (let ((vscroll (window-vscroll window t))) + ;; From the top of a preview, the same function can fail to + ;; measure the row above it. Step onto the preview's link row, + ;; which lies VSCROLL pixels above. + (when (and (> pixels vscroll) + (ai-code-ghostel-image-preview--preview-at-window-start-p + window)) + (ai-code-ghostel-image-preview--show-link-row window) + (setq pixels (- pixels vscroll))) + (when (> pixels 0) + (pixel-scroll-precision-scroll-up pixels))))) + (ai-code-ghostel-image-preview--align-window-start window start forward) + (unless forward + (ai-code-ghostel-image-preview--keep-point-visible window)))) (defun ai-code-ghostel-image-preview--scroll-lines (lines) "Scroll the selected window LINES rows by pixels over image previews. Positive LINES scroll toward later text. Return non-nil when a local -preview is visible and the scroll was handled here." +preview is visible, or is about to be scrolled into view from above, and +the scroll was handled here." (let ((window (selected-window))) (when (and (integerp lines) (/= lines 0) - (ai-code-ghostel-image-preview--window-has-preview-p window)) + (or (ai-code-ghostel-image-preview--window-has-preview-p window) + (and (< lines 0) + (ai-code-ghostel-image-preview--preview-above + window (* (- lines) (default-line-height)))))) (ai-code-ghostel-image-preview--note-user-scroll window) (ai-code-ghostel-image-preview--scroll-pixels (* lines (default-line-height))) diff --git a/test/test_ai-code-ghostel-image-preview.el b/test/test_ai-code-ghostel-image-preview.el index 602ec38e..62ed4f8a 100644 --- a/test/test_ai-code-ghostel-image-preview.el +++ b/test/test_ai-code-ghostel-image-preview.el @@ -791,6 +791,226 @@ (should (equal (run -18 '(20 30 t) '(20 12 t)) '((up 18) (link-row)))))))) +(defmacro test-ai-code-ghostel-image-preview--with-preview-rows (&rest body) + "Run BODY in a window showing five rows, with a preview after row 1. +BODY sees WINDOW, the preview OVERLAY, and ROW, a function returning the +start of a row. `window-start' and `window-vscroll' answer from the +START and VSCROLL variables, and the line height is 18 pixels." + (declare (indent 0)) + `(save-window-excursion + (with-temp-buffer + (insert "row 0\nrow 1 image.png\nrow 2\nrow 3\nrow 4\n") + (let* ((window (selected-window)) + (row (lambda (n) + (save-excursion + (goto-char (point-min)) + (forward-line n) + (point)))) + (overlay (make-overlay (1- (funcall row 2)) (funcall row 2))) + (start (funcall row 2)) + (vscroll 0)) + (overlay-put overlay 'ai-code-session-image-preview t) + (set-window-buffer window (current-buffer)) + (cl-letf (((symbol-function 'window-start) + (lambda (&optional _window) start)) + ((symbol-function 'window-vscroll) + (lambda (&optional _window _pixels) vscroll)) + ((symbol-function 'default-line-height) (lambda () 18))) + ,@body))))) + +(ert-deftest test-ai-code-ghostel-image-preview--preview-above-needs-reach () + "An upward scroll should enter a preview only past the preview's lower edge." + (test-ai-code-ghostel-image-preview--with-preview-rows + (cl-flet ((above (pixels) + (ai-code-ghostel-image-preview--preview-above window pixels))) + ;; Directly below the preview, any upward scroll enters it. + (should (equal (above 1) (cons overlay 0))) + (should (equal (above 18) (cons overlay 0))) + ;; The hidden part of the first row comes into view first. + (setq vscroll 10) + (should-not (above 10)) + (should (equal (above 11) (cons overlay 0))) + ;; One row below, the scroll must exceed that row. + (setq start (funcall row 3) vscroll 0) + (should-not (above 18)) + (should (equal (above 19) (cons overlay 1))) + (setq start (funcall row 4)) + (should-not (above 36)) + (should (equal (above 54) (cons overlay 2))) + ;; A window already on the preview has nothing to enter. + (setq start (overlay-start overlay)) + (should-not (above 54)) + ;; Nor has a window above it. + (setq start (funcall row 1)) + (should-not (above 54))))) + +(ert-deftest test-ai-code-ghostel-image-preview--pixel-scroll-enters-preview-from-below () + "Scrolling up from below a preview should step onto it without measuring." + (test-ai-code-ghostel-image-preview--with-preview-rows + (let (log) + (cl-letf (((symbol-function + 'ai-code-ghostel-image-preview--preview-pixel-height) + (lambda (_overlay _window) 420)) + ((symbol-function 'set-window-start) + (lambda (_window position &optional _noforce) + (push (list 'start position) log) + (setq start position))) + ((symbol-function + 'ai-code-ghostel-image-preview--set-window-vscroll) + (lambda (_window value) + (push (list 'vscroll value) log) + (setq vscroll value))) + ((symbol-function 'pixel-scroll-precision-scroll-up) + (lambda (delta) (push (list 'up delta) log))) + ((symbol-function + 'ai-code-ghostel-image-preview--keep-point-visible) + #'ignore)) + (cl-flet ((run (pixels from-row from-vscroll) + (setq start (funcall row from-row) + vscroll from-vscroll + log nil) + (ai-code-ghostel-image-preview--scroll-pixels pixels) + (nreverse log))) + (let ((link-row (funcall row 1))) + ;; Directly below, the empty row drawn for the preview's + ;; trailing newline already counts as one line of it. + (should (equal (run -18 2 0) + `((start ,link-row) (vscroll 384)))) + (should (equal (run -18 2 10) + `((start ,link-row) (vscroll 394)))) + ;; From further down, the rows in between come first. + (should (equal (run -54 4 0) + `((start ,link-row) (vscroll 402)))) + ;; Past the whole preview, the rest is an ordinary scroll. + (should (equal (run -500 2 0) + `((start ,link-row) (vscroll 0) (up 98)))) + ;; A scroll that stops below the preview is left to Emacs. + (should (equal (run -18 3 0) '((up 18)))))))))) + +(ert-deftest test-ai-code-ghostel-image-preview--alignment-keeps-preview-link-row () + "A link row hiding part of its preview should keep its vscroll." + (test-ai-code-ghostel-image-preview--with-preview-rows + (let (reset) + (cl-letf (((symbol-function + 'ai-code-ghostel-image-preview--set-window-vscroll) + (lambda (_window value) (push value reset)))) + (cl-flet ((align (at-row with-vscroll) + (setq start (funcall row at-row) + vscroll with-vscroll + reset nil) + (ai-code-ghostel-image-preview--align-window-start + window (funcall row 3) nil) + reset)) + ;; On the link row, with the image partly hidden. + (should-not (align 1 384)) + ;; The link row itself is shown whole, like any text row. + (should (equal (align 1 6) '(0))) + (should (equal (align 0 100) '(0)))))))) + +(ert-deftest test-ai-code-ghostel-image-preview--wheel-enters-preview-from-below () + "An upward wheel event below a preview should not reach the scroll engines." + (let (above pixels engine) + (cl-letf (((symbol-function 'ai-code-ghostel-image-preview--event-window) + (lambda (_event) (selected-window))) + ((symbol-function + 'ai-code-ghostel-image-preview--note-user-scroll) + #'ignore) + ((symbol-function + 'ai-code-ghostel-image-preview--window-has-preview-p) + (lambda (_window) t)) + ((symbol-function 'ai-code-ghostel-image-preview--preview-above) + (lambda (_window reach) (and above (cons 'overlay reach)))) + ((symbol-function 'ai-code-ghostel-image-preview--scroll-pixels) + (lambda (delta) (push delta pixels))) + ((symbol-function 'ultra-scroll) + (lambda (&rest _args) (push 'ultra engine))) + ((symbol-function 'pixel-scroll-precision) + (lambda (&rest _args) (push 'precision engine))) + ((symbol-function + 'ai-code-ghostel-image-preview-schedule-visible-linkify) + #'ignore)) + (let ((ai-code-ghostel-image-preview-prefer-ultra-scroll t) + (up '(wheel-up nil 1 1 (0 . 20.4))) + (down '(wheel-down nil 1 1 (0 . -20.4)))) + (setq above t) + (ai-code-ghostel-image-preview-scroll up) + (should (equal pixels '(-20))) + (should-not engine) + ;; Scrolling down, or with no preview within reach, is unchanged. + (ai-code-ghostel-image-preview-scroll down) + (setq above nil) + (ai-code-ghostel-image-preview-scroll up) + (should (equal pixels '(-20))) + (should (equal engine '(ultra ultra))))))) + +(ert-deftest test-ai-code-ghostel-image-preview--wheel-enters-preview-reads-emacs-mac-delta () + "An emacs-mac trackpad event should enter a preview from below too." + (let ((window (selected-window)) + pixels) + (cl-letf (((symbol-function 'ai-code-ghostel-image-preview--preview-above) + (lambda (_window reach) (cons 'overlay reach))) + ((symbol-function 'ai-code-ghostel-image-preview--scroll-pixels) + (lambda (delta) (push delta pixels)))) + (should (ai-code-ghostel-image-preview--scroll-up-onto-preview + '(wheel-up nil 1 (:scrolling-delta-y 20.4 :phase changed)) + window)) + (should (equal pixels '(-20))) + ;; Scrolling down is left to the scroll engines. + (should-not (ai-code-ghostel-image-preview--scroll-up-onto-preview + '(wheel-down nil 1 (:scrolling-delta-y -20.4)) + window)) + ;; A wheeled mouse reports lines, not pixels. + (should-not (ai-code-ghostel-image-preview--scroll-up-onto-preview + '(wheel-up nil 1 (:delta-y 1.0)) + window)) + (should-not (ai-code-ghostel-image-preview--scroll-up-onto-preview + 'wheel-event window)) + (should (equal pixels '(-20)))))) + +(ert-deftest test-ai-code-ghostel-image-preview--line-scroll-reaches-preview-above () + "Line scrolling up should use pixels for a preview it is about to reveal." + (let (above pixels) + (cl-letf (((symbol-function + 'ai-code-ghostel-image-preview--window-has-preview-p) + (lambda (_window) nil)) + ((symbol-function 'ai-code-ghostel-image-preview--preview-above) + (lambda (_window reach) (and above (cons 'overlay reach)))) + ((symbol-function + 'ai-code-ghostel-image-preview--note-user-scroll) + #'ignore) + ((symbol-function + 'ai-code-ghostel-image-preview-schedule-visible-linkify) + #'ignore) + ((symbol-function 'ai-code-ghostel-image-preview--scroll-pixels) + (lambda (delta) (push delta pixels))) + ((symbol-function 'default-line-height) (lambda () 18))) + (setq above t) + (should (ai-code-ghostel-image-preview--scroll-lines -3)) + (should (equal pixels '(-54))) + ;; A preview above the window does not concern a downward scroll. + (should-not (ai-code-ghostel-image-preview--scroll-lines 3)) + (setq above nil) + (should-not (ai-code-ghostel-image-preview--scroll-lines -3)) + (should (equal pixels '(-54)))))) + +(ert-deftest test-ai-code-ghostel-image-preview--upward-scroll-keeps-point-visible () + "After scrolling up, point should sit on a row the window shows whole." + (test-ai-code-ghostel-image-preview--with-preview-rows + (let ((last-whole-row (funcall row 3))) + (setq start (funcall row 0)) + (cl-letf (((symbol-function 'pos-visible-in-window-p) + (lambda (&optional position _window _partially) + (<= position last-whole-row))) + ((symbol-function 'window-end) + (lambda (&optional _window _update) (point-max)))) + (set-window-point window (funcall row 4)) + (ai-code-ghostel-image-preview--keep-point-visible window) + (should (= (window-point window) last-whole-row)) + ;; A visible point stays where it is. + (set-window-point window (funcall row 2)) + (ai-code-ghostel-image-preview--keep-point-visible window) + (should (= (window-point window) (funcall row 2))))))) + (ert-deftest test-ai-code-ghostel-image-preview--line-scroll-declares-evil-properties () "Remapped evil scrolls should not replace the last change for `.'." (let (declared)