ui: refactor, generalise listScrollPushingSelection

hledger-ui/Hledger/UI/AccountsScreen.hs

@@ -13,11 +13,10 @@ where
 
 import Brick
 import Brick.Widgets.List
-  (handleListEvent, list, listElementsL, listMoveDown, listMoveTo, listNameL, listSelectedElement, listSelectedL, renderList, listElements, listSelected, listMoveUp)
 import Brick.Widgets.Edit
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
-import Data.List
+import Data.List hiding (reverse)
 import Data.Maybe
 import qualified Data.Text as T
 import Data.Time.Calendar (Day)
@@ -339,36 +338,12 @@ asHandle ui0@UIState{
           vScrollBy (viewportScroll $ _asList^.listNameL) 1 >> continue ui
           where mnextelement = listSelectedElement $ listMoveDown _asList
 
-        -- mouse scroll wheel scrolls the viewport up or down to its maximum extent.
-        -- 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 _asList
-          case (mvp, mselidx) of
-            (Just VP{_vpTop}, Just selidx) -> do
-              let
-                listheight = asListSize _asList
-                pushsel | selidx <= _vpTop && selidx < (listheight-1) = listMoveDown
-                        | otherwise = id
-                ui' = ui{aScreen=scr{_asList=pushsel _asList}}
-              viewportScroll name `vScrollBy` 1
-              continue ui'
-
-            _ -> continue ui
-
-        MouseDown name BScrollUp _mods _loc -> do
-          mvp <- lookupViewport name
-          let mselidx = listSelected _asList
-          case (mvp, mselidx) of
-            (Just VP{_vpTop, _vpSize=(_,vpheight)}, Just selidx) -> do
-              let
-                pushsel | selidx >= _vpTop + vpheight - 1 && selidx > 0 = listMoveUp
-                        | otherwise = id
-                ui'   = ui{aScreen=scr{_asList=pushsel _asList}}
-              viewportScroll name `vScrollBy` (-1)
-              continue ui'
-
-            _ -> continue ui
+        -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
+        -- pushing the selection when necessary.
+        MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do
+          let scrollamt = if btn==BScrollUp then -1 else 1
+          list' <- listScrollPushingSelection name _asList (asListSize _asList) scrollamt
+          continue ui{aScreen=scr{_asList=list'}}
 
         -- 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

hledger-ui/Hledger/UI/RegisterScreen.hs

@@ -22,8 +22,7 @@ import Data.Time.Calendar
 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, listSelected, listMoveUp)
+import Brick.Widgets.List hiding (reverse)
 import Brick.Widgets.Edit
 import Lens.Micro.Platform
 import Safe
@@ -379,31 +378,11 @@ rsHandle ui@UIState{
           where mnextelement = listSelectedElement $ listMoveDown rsList
 
         -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
-        -- 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
+        -- pushing the selection when necessary.
+        MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do
+          let scrollamt = if btn==BScrollUp then -1 else 1
+          list' <- listScrollPushingSelection name rsList (rsListSize rsList) scrollamt
+          continue ui{aScreen=s{rsList=list'}}
 
         -- 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

hledger-ui/Hledger/UI/UIUtils.hs

@@ -2,6 +2,7 @@
 
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Hledger.UI.UIUtils (
    borderDepthStr
@@ -25,6 +26,7 @@ module Hledger.UI.UIUtils (
   ,suspend
   ,redraw
   ,reportSpecSetFutureAndForecast
+  ,listScrollPushingSelection
   )
 where
 
@@ -33,7 +35,7 @@ import Brick.Widgets.Border
 import Brick.Widgets.Border.Style
 import Brick.Widgets.Dialog
 import Brick.Widgets.Edit
-import Brick.Widgets.List (List, listSelectedL, listNameL, listItemHeightL)
+import Brick.Widgets.List (List, listSelectedL, listNameL, listItemHeightL, listSelected, listMoveDown, listMoveUp, GenericList, Splittable)
 import Control.Monad.IO.Class
 import Data.Bifunctor (second)
 import Data.List
@@ -360,3 +362,22 @@ reportSpecSetFutureAndForecast d forecast rspec =
          Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
         ,Not generatedTransactionTag
       ]
+
+-- Vertically scroll the named list with the given number of non-empty items
+-- by the given positive or negative number of items (usually 1 or -1).
+-- The selection will be moved when necessary to keep it visible and allow the scroll.
+listScrollPushingSelection :: (Ord n, Foldable t, Splittable t) => 
+  n -> GenericList n t e -> Int -> Int -> EventM n (GenericList n t e)
+listScrollPushingSelection name list listheight scrollamt = do
+  mvp <- lookupViewport name
+  let mselidx = listSelected list
+  case (mvp, mselidx) of
+    (Just VP{_vpTop, _vpSize=(_,vpheight)}, Just selidx) -> do
+      viewportScroll name `vScrollBy` scrollamt
+      return $ pushsel list
+      where
+        pushsel 
+          | scrollamt > 0, selidx <= _vpTop                && selidx < (listheight-1) = listMoveDown
+          | scrollamt < 0, selidx >= _vpTop + vpheight - 1 && selidx > 0              = listMoveUp
+          | otherwise = id
+    _ -> return list