diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs index efd044f85..b05ac8bc6 100644 --- a/hledger-ui/Hledger/UI/AccountsScreen.hs +++ b/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 - continue ui - where - mnextelement = listSelectedElement $ listMoveDown _asList + 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 -- 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 \ No newline at end of file diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs index 2e5e8ffeb..bf11f3dcb 100644 --- a/hledger-ui/Hledger/UI/RegisterScreen.hs +++ b/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; - -- instead scroll down by one, until maximally scrolled - shows the end has been reached + -- when at the last item, instead of moving down, scroll down by one, until maximally scrolled VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do - vScrollBy (viewportScroll $ rsList^.listNameL) 1 - continue ui - where - mnextelement = listSelectedElement $ listMoveDown rsList + vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> continue ui + 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