ui: mouse scrolls accounts, register screens

hledger-ui/Hledger/UI/AccountsScreen.hs

@@ -2,6 +2,7 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Hledger.UI.AccountsScreen
  (accountsScreen
@@ -12,7 +13,7 @@ where
 
 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 Control.Monad
 import Control.Monad.IO.Class (liftIO)
@@ -21,7 +22,7 @@ import Data.Maybe
 import qualified Data.Text as T
 import Data.Time.Calendar (Day)
 import qualified Data.Vector as V
-import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft))
+import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp))
 import Lens.Micro.Platform
 import Safe
 import System.Console.ANSI
@@ -331,10 +332,39 @@ asHandle ui0@UIState{
         -- prevent moving down over blank padding items;
         -- instead scroll down by one, until maximally scrolled - shows the end has been reached
         VtyEvent (EvKey (KDown)     []) | isBlankElement mnextelement -> do
-          vScrollBy (viewportScroll $ _asList^.listNameL) 1
+          vScrollBy (viewportScroll $ _asList^.listNameL) 1 >> continue ui
-          continue ui
+          where mnextelement = listSelectedElement $ listMoveDown _asList
-          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
 
         -- 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
@@ -382,3 +412,5 @@ isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just ""
 asCenterAndContinue ui = do
   scrollSelectionToMiddle $ _asList $ aScreen ui
   continue ui
+
+asListSize = V.length . V.takeWhile ((/="").asItemAccountName) . listElements

hledger-ui/Hledger/UI/RegisterScreen.hs

@@ -19,7 +19,7 @@ import Data.Maybe
 import qualified Data.Text as T
 import Data.Time.Calendar
 import qualified Data.Vector as V
-import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft))
+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)
@@ -367,13 +367,15 @@ rsHandle ui@UIState{
           where 
             clickeddate = maybe "" rsItemDate $ listElements rsList !? y
 
-        -- prevent moving down over blank padding items;
+        -- when at the last item, instead of moving down, scroll down by one, until maximally scrolled
-        -- instead scroll down by one, until maximally scrolled - shows the end has been reached
         VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
-          vScrollBy (viewportScroll $ rsList^.listNameL) 1
+          vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> continue ui
-          continue ui
+          where mnextelement = listSelectedElement $ listMoveDown rsList
-          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
 
         -- 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