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 OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hledger.UI.RegisterScreen
(registerScreen
@ -22,7 +23,7 @@ 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)
(handleListEvent, list, listElementsL, listMoveDown, listMoveTo, listNameL, listSelectedElement, listSelectedL, renderList, listElements, listSelected, listMoveUp)
import Brick.Widgets.Edit
import Lens.Micro.Platform
import Safe
@ -378,9 +379,31 @@ rsHandle ui@UIState{
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
-- 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
-- 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
@ -410,3 +433,5 @@ isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
rsCenterAndContinue ui = do
scrollSelectionToMiddle $ rsList $ aScreen ui
continue ui
rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements