From 731a416b8c9a396dda2a16163c4ae2766c09c13e Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Thu, 18 Nov 2021 07:23:31 -1000
Subject: [PATCH] ui: register: scrolling pushes selection, like accounts
 screen

---
 hledger-ui/Hledger/UI/RegisterScreen.hs | 33 ++++++++++++++++++++++---
 1 file changed, 29 insertions(+), 4 deletions(-)

diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs
index 167dbaaf0..a45cee9e8 100644
--- a/hledger-ui/Hledger/UI/RegisterScreen.hs
+++ b/hledger-ui/Hledger/UI/RegisterScreen.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Hledger.UI.RegisterScreen
  (registerScreen
@@ -22,7 +23,7 @@ import qualified Data.Vector as V
 import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp))
 import Brick
 import Brick.Widgets.List
-  (handleListEvent, list, listElementsL, listMoveDown, listMoveTo, listNameL, listSelectedElement, listSelectedL, renderList, listElements)
+  (handleListEvent, list, listElementsL, listMoveDown, listMoveTo, listNameL, listSelectedElement, listSelectedL, renderList, listElements, listSelected, listMoveUp)
 import Brick.Widgets.Edit
 import Lens.Micro.Platform
 import Safe
@@ -378,9 +379,31 @@ rsHandle ui@UIState{
           where mnextelement = listSelectedElement $ listMoveDown rsList
 
         -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
-        -- TODO moving the selection when necessary to allow the scroll.
-        MouseDown _n BScrollDown _mods _loc -> vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> continue ui
-        MouseDown _n BScrollUp   _mods _loc -> vScrollBy (viewportScroll $ rsList ^. listNameL) (-1) >> continue ui
+        -- The selection will be moved when necessary to keep it visible and allow the scroll.
+        MouseDown name BScrollDown _mods _loc -> do
+          mvp <- lookupViewport name
+          let mselidx = listSelected rsList
+          case (mvp, mselidx) of
+            (Just VP{_vpTop}, Just selidx) -> do
+              let
+                pushsel | selidx <= _vpTop && selidx < (listheight-1) = listMoveDown
+                        | otherwise = id
+                  where listheight = rsListSize rsList
+              viewportScroll name `vScrollBy` 1
+              continue ui{aScreen=s{rsList=pushsel rsList}}
+            _ -> continue ui
+
+        MouseDown name BScrollUp _mods _loc -> do
+          mvp <- lookupViewport name
+          let mselidx = listSelected rsList
+          case (mvp, mselidx) of
+            (Just VP{_vpTop, _vpSize=(_,vpheight)}, Just selidx) -> do
+              let
+                pushsel | selidx >= _vpTop + vpheight - 1 && selidx > 0 = listMoveUp
+                        | otherwise = id
+              viewportScroll name `vScrollBy` (-1)
+              continue ui{aScreen=s{rsList=pushsel rsList}}
+            _ -> continue ui
 
         -- if page down or end leads to a blank padding item, stop at last non-blank
         VtyEvent e@(EvKey k           []) | k `elem` [KPageDown, KEnd] -> do
@@ -410,3 +433,5 @@ isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
 rsCenterAndContinue ui = do
   scrollSelectionToMiddle $ rsList $ aScreen ui
   continue ui
+
+rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements
\ No newline at end of file