slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ui: register: scrolling pushes selection, like accounts screen

Browse Source
This commit is contained in:
Simon Michael 2021-11-18 07:23:31 -10:00
parent 3a57814402
commit 731a416b8c
1 changed files with 29 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
hledger-ui/Hledger/UI/RegisterScreen.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hledger.UI.RegisterScreen module Hledger.UI.RegisterScreen
(registerScreen (registerScreen
@ -22,7 +23,7 @@ import qualified Data.Vector as V
import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp)) import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp))
import Brick import Brick
import Brick.Widgets.List 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 Brick.Widgets.Edit
import Lens.Micro.Platform import Lens.Micro.Platform
import Safe import Safe
@ -378,9 +379,31 @@ rsHandle ui@UIState{
where mnextelement = listSelectedElement $ listMoveDown rsList where mnextelement = listSelectedElement $ listMoveDown rsList
-- mouse scroll wheel scrolls the viewport up or down to its maximum extent, -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
-- TODO moving the selection when necessary to allow the scroll. -- The selection will be moved when necessary to keep it visible and allow the scroll.
MouseDown _n BScrollDown _mods _loc -> vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> continue ui MouseDown name BScrollDown _mods _loc -> do
MouseDown _n BScrollUp _mods _loc -> vScrollBy (viewportScroll $ rsList ^. listNameL) (-1) >> continue ui 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 -- 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 VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do
@ -410,3 +433,5 @@ isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
rsCenterAndContinue ui = do rsCenterAndContinue ui = do
scrollSelectionToMiddle $ rsList $ aScreen ui scrollSelectionToMiddle $ rsList $ aScreen ui
continue ui continue ui
rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements