diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs index bf7a9d75c..eebc0dc53 100644 --- a/hledger-ui/Hledger/UI/AccountsScreen.hs +++ b/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 diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs index a45cee9e8..46ff22eb6 100644 --- a/hledger-ui/Hledger/UI/RegisterScreen.hs +++ b/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 diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs index 6d5098cc1..cc2399a3d 100644 --- a/hledger-ui/Hledger/UI/UIUtils.hs +++ b/hledger-ui/Hledger/UI/UIUtils.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module Hledger.UI.UIUtils ( borderDepthStr @@ -25,7 +26,8 @@ module Hledger.UI.UIUtils ( ,suspend ,redraw ,reportSpecSetFutureAndForecast -) + ,listScrollPushingSelection + ) where import Brick @@ -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