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

dev: ui: refactor: simpler, more debuggable Screen type

Browse Source 
Follow-on from the brick 1.0 migration work (#1889, #1919).

These new types aim to be more restrictive, allowing fewer invalid
states, and easier to inspect and debug. The screen types store only
state, not behaviour (functions), and there is no longer a circular
dependency between UIState and Screen.
This commit is contained in:
Simon Michael 2022-09-02 13:36:05 -07:00
parent bc810063a5
commit a5f4d2fd6e
10 changed files with 691 additions and 483 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -5,8 +5,9 @@
{-# LANGUAGE RecordWildCards #-}
module Hledger.UI.AccountsScreen
(accountsScreen
,asInit
(asNew
,asDraw
,asHandle
,asSetSelectedAccount
)
where
@ -21,9 +22,9 @@ import Data.Maybe
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Vector as V
import Data.Vector ((!?))
import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp))
import Lens.Micro.Platform
import Safe
import System.Console.ANSI
import System.FilePath (takeFileName)
import Text.DocLayout (realLength)
@ -34,83 +35,16 @@ import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.UIScreens
import Hledger.UI.Editor
import Hledger.UI.RegisterScreen
import Hledger.UI.ErrorScreen
import Data.Vector ((!?))
import Hledger.UI.ErrorScreen (uiReloadJournal, uiCheckBalanceAssertions, uiReloadJournalIfChanged)
import Hledger.UI.RegisterScreen (rsCenterSelection)
accountsScreen :: Screen
accountsScreen = AccountsScreen{
sInit = asInit
,sDraw = asDraw
,sHandle = asHandle
,_asList = list AccountsList V.empty 1
,_asSelectedAccount = ""
}
asInit :: Day -> Bool -> UIState -> UIState
asInit d reset ui@UIState{
aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}},
ajournal=j,
aScreen=s@AccountsScreen{}
} = dlogUiTrace "asInit 1" $
ui{aScreen=s & asList .~ newitems'}
where
newitems = list AccountsList (V.fromList $ displayitems ++ blankitems) 1
-- decide which account is selected:
-- if reset is true, the first account;
-- otherwise, the previously selected account if possible;
-- otherwise, the first account with the same prefix (eg first leaf account when entering flat mode);
-- otherwise, the alphabetically preceding account.
newitems' = listMoveTo selidx newitems
where
selidx = case (reset, listSelectedElement $ _asList s) of
(True, _) -> 0
(_, Nothing) -> 0
(_, Just (_,AccountsScreenItem{asItemAccountName=a})) ->
headDef 0 $ catMaybes [
elemIndex a as
,findIndex (a `isAccountNamePrefixOf`) as
,Just $ max 0 (length (filter (< a) as) - 1)
]
where
as = map asItemAccountName displayitems
rspec' =
-- Further restrict the query based on the current period and future/forecast mode.
(reportSpecSetFutureAndForecast d (forecast_ $ inputopts_ copts) rspec)
-- always show declared accounts even if unused
{_rsReportOpts=ropts{declared_=True}}
-- run the report
(items,_total) = balanceReport rspec' j
-- pre-render the list items
displayitem (fullacct, shortacct, indent, bal) =
AccountsScreenItem{asItemIndentLevel = indent
,asItemAccountName = fullacct
,asItemDisplayAccountName = replaceHiddenAccountsNameWith "All" $ if tree_ ropts then shortacct else fullacct
,asItemMixedAmount = Just bal
}
displayitems = map displayitem items
-- blanks added for scrolling control, cf RegisterScreen.
-- XXX Ugly. Changing to 0 helps when debugging.
blankitems = replicate uiNumBlankItems
AccountsScreenItem{asItemIndentLevel = 0
,asItemAccountName = ""
,asItemDisplayAccountName = ""
,asItemMixedAmount = Nothing
}
asInit _ _ _ = dlogUiTrace "asInit 2" $ errorWrongScreenType "init function" -- PARTIAL:
asDraw :: UIState -> [Widget Name]
asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
,ajournal=j
,aScreen=s@AccountsScreen{}
,aScreen=AS sst
,aMode=mode
} = dlogUiTrace "asDraw 1" $
case mode of
@ -125,7 +59,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
-- ltrace "availwidth" $
c^.availWidthL
- 2 -- XXX due to margin ? shouldn't be necessary (cf UIUtils)
displayitems = s ^. asList . listElementsL
displayitems = sst ^. assList . listElementsL
acctwidths = V.map (\AccountsScreenItem{..} -> asItemIndentLevel + realLength asItemDisplayAccountName) displayitems
balwidths = V.map (maybe 0 (wbWidth . showMixedAmountB oneLine) . asItemMixedAmount) displayitems
@ -145,7 +79,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
colwidths | shortfall <= 0 = (preferredacctwidth, preferredbalwidth)
| otherwise = (adjustedacctwidth, adjustedbalwidth)
render $ defaultLayout toplabel bottomlabel $ renderList (asDrawItem colwidths) True (_asList s)
render $ defaultLayout toplabel bottomlabel $ renderList (asDrawItem colwidths) True (sst ^. assList)
where
ropts = _rsReportOpts rspec
@ -175,12 +109,12 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
,if real_ ropts then ["real"] else []
]
mdepth = depth_ ropts
curidx = case _asList s ^. listSelectedL of
curidx = case sst ^. assList . listSelectedL of
Nothing -> "-"
Just i -> show (i + 1)
totidx = show $ V.length nonblanks
where
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ s ^. asList . listElementsL
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ sst ^. assList . listElementsL
bottomlabel = case mode of
Minibuffer label ed -> minibuffer label ed
@ -231,19 +165,19 @@ asHandle ev = do
dlogUiTraceM "asHandle 1"
case ui0 of
ui1@UIState{
aScreen=scr@AccountsScreen{..}
,aopts=UIOpts{uoCliOpts=copts}
aopts=UIOpts{uoCliOpts=copts}
,ajournal=j
,aMode=mode
,aScreen=AS sst
} -> do
let
-- save the currently selected account, in case we leave this screen and lose the selection
selacct = case listSelectedElement _asList of
selacct = case listSelectedElement $ _assList sst of
Just (_, AccountsScreenItem{..}) -> asItemAccountName
Nothing -> scr ^. asSelectedAccount
ui = ui1{aScreen=scr & asSelectedAccount .~ selacct}
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ _asList^.listElementsL
Nothing -> sst ^. assSelectedAccount
ui = ui1{aScreen=AS sst{_assSelectedAccount=selacct}}
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ listElements $ _assList sst
lastnonblankidx = max 0 (length nonblanks - 1)
journalspan = journalDateSpan False j
d = copts^.rsDay
@ -325,51 +259,51 @@ asHandle ev = do
VtyEvent (EvKey (KChar '/') []) -> put' $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui
VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (put' $ regenerateScreens j d $ resetFilter ui)
VtyEvent e | e `elem` moveLeftEvents -> put' $ popScreen ui
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle (_assList sst) >> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
-- enter register screen for selected account (if there is one),
-- centering its selected transaction if possible
VtyEvent e | e `elem` moveRightEvents
, not $ isBlankElement $ listSelectedElement _asList -> asEnterRegister d selacct ui
, not $ isBlankElement $ listSelectedElement (_assList sst) -> asEnterRegisterScreen d selacct ui
-- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347
-- just use it to move the selection
MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickedacct -> do
put' ui{aScreen=scr} -- XXX does this do anything ?
where clickedacct = maybe "" asItemAccountName $ listElements _asList !? y
put' ui{aScreen=AS sst} -- XXX does this do anything ?
where clickedacct = maybe "" asItemAccountName $ listElements (_assList sst) !? y
-- and on MouseUp, enter the subscreen
MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickedacct -> do
asEnterRegister d clickedacct ui
where clickedacct = maybe "" asItemAccountName $ listElements _asList !? y
asEnterRegisterScreen d clickedacct ui
where clickedacct = maybe "" asItemAccountName $ listElements (_assList sst) !? y
-- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled
VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ _asList^.listNameL) 1
where mnextelement = listSelectedElement $ listMoveDown _asList
vScrollBy (viewportScroll $ (_assList sst)^.listNameL) 1
where mnextelement = listSelectedElement $ listMoveDown (_assList sst)
-- 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' <- nestEventM' _asList $ listScrollPushingSelection name (asListSize _asList) scrollamt
put' ui{aScreen=scr{_asList=list'}}
list' <- nestEventM' (_assList sst) $ listScrollPushingSelection name (asListSize (_assList sst)) scrollamt
put' ui{aScreen=AS sst{_assList=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
l <- nestEventM' _asList $ handleListEvent e
l <- nestEventM' (_assList sst) $ handleListEvent e
if isBlankElement $ listSelectedElement l
then do
let l' = listMoveTo lastnonblankidx l
scrollSelectionToMiddle l'
put' ui{aScreen=scr{_asList=l'}}
put' ui{aScreen=AS sst{_assList=l'}}
else
put' ui{aScreen=scr{_asList=l}}
put' ui{aScreen=AS sst{_assList=l}}
-- fall through to the list's event handler (handles up/down)
VtyEvent e -> do
list' <- nestEventM' _asList $ handleListEvent (normaliseMovementKeys e)
put' ui{aScreen=scr & asList .~ list' & asSelectedAccount .~ selacct }
list' <- nestEventM' (_assList sst) $ handleListEvent (normaliseMovementKeys e)
put' ui{aScreen=AS $ sst & assList .~ list' & assSelectedAccount .~ selacct }
MouseDown{} -> return ()
MouseUp{} -> return ()
@ -377,26 +311,33 @@ asHandle ev = do
_ -> dlogUiTraceM "asHandle 2" >> errorWrongScreenType "event handler"
asEnterRegister :: Day -> AccountName -> UIState -> EventM Name UIState ()
asEnterRegister d selacct ui = do
dlogUiTraceM "asEnterRegister"
asEnterRegisterScreen :: Day -> AccountName -> UIState -> EventM Name UIState ()
asEnterRegisterScreen d acct ui@UIState{ajournal=j, aopts=uopts} = do
dlogUiTraceM "asEnterRegisterScreen"
let
regscr = rsSetAccount selacct isdepthclipped registerScreen
regscr = rsNew uopts d j acct isdepthclipped
where
isdepthclipped = case getDepth ui of
Just de -> accountNameLevel selacct >= de
Just de -> accountNameLevel acct >= de
Nothing -> False
rsCenterSelection (screenEnter d regscr ui) >>= put'
ui1 = pushScreen regscr ui
rsCenterSelection ui1 >>= put'
asSetSelectedAccount a s@AccountsScreen{} = s & asSelectedAccount .~ a
-- | Set the selected account on an accounts screen. No effect on other screens.
asSetSelectedAccount :: AccountName -> Screen -> Screen
asSetSelectedAccount a (AS ass@ASS{}) = AS ass{_assSelectedAccount=a}
asSetSelectedAccount _ s = s
isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just ""
-- | Scroll the accounts screen's selection to the center. No effect if on another screen.
asCenterAndContinue :: EventM Name UIState ()
asCenterAndContinue = do
ui <- get'
scrollSelectionToMiddle (_asList $ aScreen ui)
case aScreen ui of
AS sst -> scrollSelectionToMiddle $ _assList sst
_ -> return ()
asListSize = V.length . V.takeWhile ((/="").asItemAccountName) . listElements

40
hledger-ui/Hledger/UI/ErrorScreen.hs
View File

@ -6,7 +6,8 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Hledger.UI.ErrorScreen
(errorScreen
(esDraw
,esHandle
,uiCheckBalanceAssertions
,uiReloadJournal
,uiReloadJournalIfChanged
@ -29,23 +30,12 @@ import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.UIScreens
import Hledger.UI.Editor
errorScreen :: Screen
errorScreen = ErrorScreen{
sInit = esInit
,sDraw = esDraw
,sHandle = esHandle
,esError = ""
}
esInit :: Day -> Bool -> UIState -> UIState
esInit _ _ ui@UIState{aScreen=ErrorScreen{}} = ui
esInit _ _ _ = error "init function called with wrong screen type, should not happen" -- PARTIAL:
esDraw :: UIState -> [Widget Name]
esDraw UIState{aopts=UIOpts{uoCliOpts=copts}
,aScreen=ErrorScreen{..}
,aScreen=ES ESS{..}
,aMode=mode
} =
case mode of
@ -54,7 +44,7 @@ esDraw UIState{aopts=UIOpts{uoCliOpts=copts}
_ -> [maincontent]
where
maincontent = Widget Greedy Greedy $ do
render $ defaultLayout toplabel bottomlabel $ withAttr (attrName "error") $ str $ esError
render $ defaultLayout toplabel bottomlabel $ withAttr (attrName "error") $ str $ _essError
where
toplabel =
withAttr (attrName "border" <> attrName "bold") (str "Oops. Please fix this problem then press g to reload")
@ -79,7 +69,7 @@ esHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
esHandle ev = do
ui0 <- get'
case ui0 of
ui@UIState{aScreen=ErrorScreen{..}
ui@UIState{aScreen=ES ESS{..}
,aopts=UIOpts{uoCliOpts=copts}
,ajournal=j
,aMode=mode
@ -100,7 +90,7 @@ esHandle ev = do
VtyEvent (EvKey (KChar c) []) | c `elem` ['h','?'] -> put' $ setMode Help ui
VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
where
(pos,f) = case parsewithString hledgerparseerrorpositionp esError of
(pos,f) = case parsewithString hledgerparseerrorpositionp _essError of
Right (f',l,c) -> (Just (l, Just c),f')
Left _ -> (endPosition, journalFilePath j)
e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] ->
@ -163,8 +153,8 @@ uiReloadJournal copts d ui = do
Right j -> regenerateScreens j d ui
Left err ->
case ui of
UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}}
_ -> screenEnter d errorScreen{esError=err} ui
UIState{aScreen=ES _} -> ui{aScreen=esNew err}
_ -> pushScreen (esNew err) ui
-- XXX GHC 9.2 warning:
-- hledger-ui/Hledger/UI/ErrorScreen.hs:164:59: warning: [-Wincomplete-record-updates]
-- Pattern match(es) are non-exhaustive
@ -183,20 +173,20 @@ uiReloadJournalIfChanged copts d j ui = do
ej <- runExceptT $ journalReloadIfChanged copts' d j
return $ case ej of
Right (j', _) -> regenerateScreens j' d ui
Left err -> case ui of
UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}}
_ -> screenEnter d errorScreen{esError=err} ui
Left err -> case aScreen ui of
ES _ -> ui{aScreen=esNew err}
_ -> pushScreen (esNew err) ui
-- Re-check any balance assertions in the current journal, and if any
-- fail, enter (or update) the error screen. Or if balance assertions
-- are disabled, do nothing.
uiCheckBalanceAssertions :: Day -> UIState -> UIState
uiCheckBalanceAssertions d ui@UIState{ajournal=j}
uiCheckBalanceAssertions _d ui@UIState{ajournal=j}
| ui^.ignore_assertions = ui
| otherwise =
case journalCheckBalanceAssertions j of
Nothing -> ui
Just err ->
case ui of
UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}}
_ -> screenEnter d errorScreen{esError=err} ui
UIState{aScreen=ES sst} -> ui{aScreen=ES sst{_essError=err}}
_ -> pushScreen (esNew err) ui

102
hledger-ui/Hledger/UI/Main.hs
View File

@ -25,17 +25,19 @@ import System.Directory (canonicalizePath)
import System.FilePath (takeDirectory)
import System.FSNotify (Event(Modified), isPollingManager, watchDir, withManager)
import Brick
import qualified Brick.BChan as BC
import Hledger
import Hledger.Cli hiding (progname,prognameandversion)
import Hledger.UI.Theme
import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.Theme
import Hledger.UI.UIState (uiState, getDepth)
import Hledger.UI.UIUtils (dlogUiTrace)
import Hledger.UI.AccountsScreen
import Hledger.UI.RegisterScreen
import Hledger.UI.UIUtils (dlogUiTrace)
import Hledger.UI.TransactionScreen
import Hledger.UI.ErrorScreen
----------------------------------------------------------------------
@ -63,7 +65,7 @@ main = do
_ -> withJournalDo copts' (runBrickUi opts)
runBrickUi :: UIOpts -> Journal -> IO ()
runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} j =
runBrickUi uopts0@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} j =
dlogUiTrace "========= runBrickUi" $ do
let
today = copts^.rsDay
@ -105,7 +107,7 @@ runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rs
-- There is also a freeform text area for extra query terms (/ key).
-- It's cleaner and less conflicting to keep the former out of the latter.
uopts' = uopts{
uopts = uopts0{
uoCliOpts=copts{
reportspec_=rspec{
_rsQuery=filteredQuery $ _rsQuery rspec, -- query with depth/date parts removed
@ -125,50 +127,32 @@ runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rs
filteredQuery q = simplifyQuery $ And [queryFromFlags ropts, filtered q]
where filtered = filterQuery (\x -> not $ queryIsDepth x || queryIsDate x)
(scr, prevscrs) = case uoRegister uopts' of
Nothing -> (accountsScreen, [])
(prevscrs, startscr) = case uoRegister uopts of
Nothing -> ([], acctsscr)
-- with --register, start on the register screen, and also put
-- the accounts screen on the prev screens stack so you can exit
-- to that as usual.
Just apat -> (rsSetAccount acct False registerScreen, [ascr'])
Just apat -> ([acctsscr'], regscr)
where
acctsscr' = asSetSelectedAccount acct acctsscr
regscr =
rsSetAccount acct False $
rsNew uopts today j acct forceinclusive
where
forceinclusive = case getDepth ui of
Just de -> accountNameLevel acct >= de
Nothing -> False
acct = fromMaybe (error' $ "--register "++apat++" did not match any account") -- PARTIAL:
. firstMatch $ journalAccountNamesDeclaredOrImplied j
firstMatch = case toRegexCI $ T.pack apat of
Right re -> find (regexMatchText re)
Left _ -> const Nothing
-- Initialising the accounts screen is awkward, requiring
-- another temporary UIState value..
ascr' = aScreen $
asInit today True
UIState{
astartupopts=uopts'
,aopts=uopts'
,ajournal=j
,aScreen=asSetSelectedAccount acct accountsScreen
,aPrevScreens=[]
,aMode=Normal
}
. firstMatch $ journalAccountNamesDeclaredOrImplied j
where
firstMatch = case toRegexCI $ T.pack apat of
Right re -> find (regexMatchText re)
Left _ -> const Nothing
where
acctsscr = asNew uopts today j Nothing
ui =
(sInit scr) today True $
UIState{
astartupopts=uopts'
,aopts=uopts'
,ajournal=j
,aScreen=scr
,aPrevScreens=prevscrs
,aMode=Normal
}
brickapp :: App UIState AppEvent Name
brickapp = App {
appStartEvent = return ()
, appAttrMap = const $ fromMaybe defaultTheme $ getTheme =<< uoTheme uopts'
, appChooseCursor = showFirstCursor
, appHandleEvent = \ev -> do ui' <- get; sHandle (aScreen ui') ev
, appDraw = \ui' -> sDraw (aScreen ui') ui'
}
ui = uiState uopts j prevscrs startscr
app = brickApp (uoTheme uopts)
-- print (length (show ui)) >> exitSuccess -- show any debug output to this point & quit
@ -179,10 +163,10 @@ runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rs
setMode (outputIface v) Mouse True
return v
if not (uoWatch uopts')
if not (uoWatch uopts)
then do
vty <- makevty
void $ customMain vty makevty Nothing brickapp ui
void $ customMain vty makevty Nothing app ui
else do
-- a channel for sending misc. events to the app
@ -242,4 +226,30 @@ runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rs
-- and start the app. Must be inside the withManager block. (XXX makevty too ?)
vty <- makevty
void $ customMain vty makevty (Just eventChan) brickapp ui
void $ customMain vty makevty (Just eventChan) app ui
brickApp :: Maybe String -> App UIState AppEvent Name
brickApp mtheme = App {
appStartEvent = return ()
, appAttrMap = const $ fromMaybe defaultTheme $ getTheme =<< mtheme
, appChooseCursor = showFirstCursor
, appHandleEvent = uiHandle
, appDraw = uiDraw
}
uiHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
uiHandle ev = do
ui <- get
case aScreen ui of
AS _ -> asHandle ev
RS _ -> rsHandle ev
TS _ -> tsHandle ev
ES _ -> esHandle ev
uiDraw :: UIState -> [Widget Name]
uiDraw ui =
case aScreen ui of
AS _ -> asDraw ui
RS _ -> rsDraw ui
TS _ -> tsDraw ui
ES _ -> esDraw ui

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

@ -7,7 +7,8 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Hledger.UI.RegisterScreen
(registerScreen
(rsNew
,rsDraw
,rsHandle
,rsSetAccount
,rsCenterSelection
@ -16,132 +17,32 @@ where
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor (bimap, Bifunctor (second))
import Data.List
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Calendar
import qualified Data.Vector as V
import Data.Vector ((!?))
import Graphics.Vty (Event(..),Key(..),Modifier(..), Button (BLeft, BScrollDown, BScrollUp))
import Brick
import Brick.Widgets.List hiding (reverse)
import Brick.Widgets.Edit
import Lens.Micro.Platform
import Safe
import System.Console.ANSI
import Hledger
import Hledger.Cli hiding (mode, progname,prognameandversion)
import Hledger.UI.UIOptions
-- import Hledger.UI.Theme
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.UIScreens
import Hledger.UI.Editor
import Hledger.UI.TransactionScreen
import Hledger.UI.ErrorScreen
import Data.Vector ((!?))
registerScreen :: Screen
registerScreen = RegisterScreen{
sInit = rsInit
,sDraw = rsDraw
,sHandle = rsHandle
,rsList = list RegisterList V.empty 1
,rsAccount = ""
,rsForceInclusive = False
}
rsSetAccount :: AccountName -> Bool -> Screen -> Screen
rsSetAccount a forceinclusive scr@RegisterScreen{} =
scr{rsAccount=replaceHiddenAccountsNameWith "*" a, rsForceInclusive=forceinclusive}
rsSetAccount _ _ scr = scr
rsInit :: Day -> Bool -> UIState -> UIState
rsInit d reset ui@UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}}, ajournal=j, aScreen=s@RegisterScreen{..}} =
dlogUiTrace "rsInit 1" $
ui{aScreen=s{rsList=newitems'}}
where
-- gather arguments and queries
-- XXX temp
inclusive = tree_ ropts || rsForceInclusive
thisacctq = Acct $ (if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex) rsAccount
-- adjust the report options and regenerate the ReportSpec, carefully as usual to avoid screwups (#1523)
ropts' = ropts {
-- ignore any depth limit, as in postingsReport; allows register's total to match accounts screen
depth_=Nothing
-- do not strip prices so we can toggle costs within the ui
, show_costs_=True
-- XXX aregister also has this, needed ?
-- always show historical balance
-- , balanceaccum_= Historical
}
wd = whichDate ropts'
rspec' = reportSpecSetFutureAndForecast d (forecast_ $ inputopts_ copts) .
either (error "rsInit: adjusting the query for register, should not have failed") id $ -- PARTIAL:
updateReportSpec ropts' rspec{_rsDay=d}
items = accountTransactionsReport rspec' j thisacctq
items' = (if empty_ ropts then id else filter (not . mixedAmountLooksZero . fifth6)) $ -- without --empty, exclude no-change txns
reverse -- most recent last
items
-- generate pre-rendered list items. This helps calculate column widths.
displayitems = map displayitem items'
where
displayitem (t, _, _issplit, otheracctsstr, change, bal) =
RegisterScreenItem{rsItemDate = showDate $ transactionRegisterDate wd (_rsQuery rspec') thisacctq t
,rsItemStatus = tstatus t
,rsItemDescription = tdescription t
,rsItemOtherAccounts = otheracctsstr
-- _ -> "<split>" -- should do this if accounts field width < 30
,rsItemChangeAmount = showamt change
,rsItemBalanceAmount = showamt bal
,rsItemTransaction = t
}
where showamt = showMixedAmountB oneLine{displayMaxWidth=Just 32}
-- blank items are added to allow more control of scroll position; we won't allow movement over these.
-- XXX Ugly. Changing to 0 helps when debugging.
blankitems = replicate uiNumBlankItems
RegisterScreenItem{rsItemDate = ""
,rsItemStatus = Unmarked
,rsItemDescription = ""
,rsItemOtherAccounts = ""
,rsItemChangeAmount = mempty
,rsItemBalanceAmount = mempty
,rsItemTransaction = nulltransaction
}
-- build the List
newitems = list RegisterList (V.fromList $ displayitems ++ blankitems) 1
-- decide which transaction is selected:
-- if reset is true, the last (latest) transaction;
-- otherwise, the previously selected transaction if possible;
-- otherwise, the transaction nearest in date to it;
-- or if there's several with the same date, the nearest in journal order;
-- otherwise, the last (latest) transaction.
newitems' = listMoveTo newselidx newitems
where
newselidx =
case (reset, listSelectedElement rsList) of
(True, _) -> endidx
(_, Nothing) -> endidx
(_, Just (_, RegisterScreenItem{rsItemTransaction=Transaction{tindex=prevselidx, tdate=prevseld}})) ->
headDef endidx $ catMaybes [
findIndex ((==prevselidx) . tindex . rsItemTransaction) displayitems
,findIndex ((==nearestidbydatethenid) . Just . tindex . rsItemTransaction) displayitems
]
where
nearestidbydatethenid = third3 <$> (headMay $ sort
[(abs $ diffDays (tdate t) prevseld, abs (tindex t - prevselidx), tindex t) | t <- ts])
ts = map rsItemTransaction displayitems
endidx = max 0 $ length displayitems - 1
rsInit _ _ _ = dlogUiTrace "rsInit 2" $ errorWrongScreenType "init function" -- PARTIAL:
import Hledger.UI.ErrorScreen (uiReloadJournal, uiCheckBalanceAssertions, uiReloadJournalIfChanged)
rsDraw :: UIState -> [Widget Name]
rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
,aScreen=RegisterScreen{..}
,aScreen=RS RSS{..}
,aMode=mode
} = dlogUiTrace "rsDraw 1" $
case mode of
@ -149,7 +50,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
-- Minibuffer e -> [minibuffer e, maincontent]
_ -> [maincontent]
where
displayitems = V.toList $ rsList ^. listElementsL
displayitems = V.toList $ listElements $ _rssList
maincontent = Widget Greedy Greedy $ do
-- calculate column widths, based on current available width
c <- getContext
@ -191,7 +92,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
acctswidth = maxdescacctswidth - descwidth
colwidths = (datewidth,descwidth,acctswidth,changewidth,balwidth)
render $ defaultLayout toplabel bottomlabel $ renderList (rsDrawItem colwidths) True rsList
render $ defaultLayout toplabel bottomlabel $ renderList (rsDrawItem colwidths) True _rssList
where
ropts = _rsReportOpts rspec
@ -199,7 +100,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
-- inclusive = tree_ ropts || rsForceInclusive
toplabel =
withAttr (attrName "border" <> attrName "bold") (str $ T.unpack $ replaceHiddenAccountsNameWith "All" rsAccount)
withAttr (attrName "border" <> attrName "bold") (str $ T.unpack $ replaceHiddenAccountsNameWith "All" _rssAccount)
-- <+> withAttr ("border" <> "query") (str $ if inclusive then "" else " exclusive")
<+> togglefilters
<+> str " transactions"
@ -222,11 +123,11 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
] of
[] -> str ""
fs -> withAttr (attrName "border" <> attrName "query") (str $ " " ++ intercalate ", " fs)
cur = str $ case rsList ^. listSelectedL of
cur = str $ case listSelected _rssList of
Nothing -> "-"
Just i -> show (i + 1)
total = str $ show $ length nonblanks
nonblanks = V.takeWhile (not . T.null . rsItemDate) $ rsList^.listElementsL
nonblanks = V.takeWhile (not . T.null . rsItemDate) $ listElements $ _rssList
-- query = query_ $ reportopts_ $ cliopts_ opts
@ -284,7 +185,7 @@ rsHandle ev = do
dlogUiTraceM "rsHandle 1"
case ui0 of
ui@UIState{
aScreen=scr@RegisterScreen{..}
aScreen=RS sst@RSS{..}
,aopts=UIOpts{uoCliOpts=copts}
,ajournal=j
,aMode=mode
@ -292,9 +193,15 @@ rsHandle ev = do
let
d = copts^.rsDay
journalspan = journalDateSpan False j
nonblanks = V.takeWhile (not . T.null . rsItemDate) $ rsList^.listElementsL
nonblanks = V.takeWhile (not . T.null . rsItemDate) $ listElements $ _rssList
lastnonblankidx = max 0 (length nonblanks - 1)
numberedtxns = zipWith (curry (second rsItemTransaction)) [(1::Integer)..] (V.toList nonblanks)
-- the transactions being shown and the currently selected or last transaction, if any:
mtxns :: Maybe ([NumberedTransaction], NumberedTransaction)
mtxns = case numberedtxns of
[] -> Nothing
nts@(_:_) -> Just (nts, maybe (last nts) (bimap ((+1).fromIntegral) rsItemTransaction) $
listSelectedElement _rssList) -- PARTIAL: last won't fail
case mode of
Minibuffer _ ed ->
case ev of
@ -338,7 +245,7 @@ rsHandle ev = do
VtyEvent (EvKey (KChar 'T') []) -> put' $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui
where
(pos,f) = case listSelectedElement rsList of
(pos,f) = case listSelectedElement _rssList of
Nothing -> (endPosition, journalFilePath j)
Just (_, RegisterScreenItem{
rsItemTransaction=Transaction{tsourcepos=(SourcePos f' l c,_)}}) -> (Just (unPos l, Just $ unPos c),f')
@ -361,7 +268,7 @@ rsHandle ev = do
VtyEvent (EvKey (KRight) [MShift]) -> put' $ regenerateScreens j d $ nextReportPeriod journalspan ui
VtyEvent (EvKey (KLeft) [MShift]) -> put' $ regenerateScreens j d $ previousReportPeriod journalspan ui
VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (put' $ regenerateScreens j d $ resetFilter ui)
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle rsList >> redraw
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _rssList >> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
-- exit screen on LEFT
@ -370,52 +277,50 @@ rsHandle ev = do
VtyEvent (EvMouseUp x _y (Just BLeft)) | x==0 -> put' $ popScreen ui
-- or on clicking a blank list item.
MouseUp _ (Just BLeft) Location{loc=(_,y)} | clickeddate == "" -> put' $ popScreen ui
where clickeddate = maybe "" rsItemDate $ listElements rsList !? y
where clickeddate = maybe "" rsItemDate $ listElements _rssList !? y
-- enter transaction screen on RIGHT
VtyEvent e | e `elem` moveRightEvents ->
case listSelectedElement rsList of
Just _ -> put' $ screenEnter d transactionScreen{tsAccount=rsAccount} ui
Nothing -> put' ui
case mtxns of Nothing -> return (); Just (nts, nt) -> rsEnterTransactionScreen _rssAccount nts nt ui
-- or on transaction click
-- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347
-- just use it to move the selection
MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickeddate -> do
put' $ ui{aScreen=scr{rsList=listMoveTo y rsList}}
where clickeddate = maybe "" rsItemDate $ listElements rsList !? y
put' $ ui{aScreen=RS sst{_rssList=listMoveTo y _rssList}}
where clickeddate = maybe "" rsItemDate $ listElements _rssList !? y
-- and on MouseUp, enter the subscreen
MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickeddate -> do
put' $ screenEnter d transactionScreen{tsAccount=rsAccount} ui
where clickeddate = maybe "" rsItemDate $ listElements rsList !? y
case mtxns of Nothing -> return (); Just (nts, nt) -> rsEnterTransactionScreen _rssAccount nts nt ui
where clickeddate = maybe "" rsItemDate $ listElements _rssList !? y
-- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled
VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ rsList ^. listNameL) 1
where mnextelement = listSelectedElement $ listMoveDown rsList
vScrollBy (viewportScroll $ listName $ _rssList) 1
where mnextelement = listSelectedElement $ listMoveDown _rssList
-- 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' <- nestEventM' rsList $ listScrollPushingSelection name (rsListSize rsList) scrollamt
put' ui{aScreen=scr{rsList=list'}}
list' <- nestEventM' _rssList $ listScrollPushingSelection name (rsListSize _rssList) scrollamt
put' ui{aScreen=RS sst{_rssList=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
l <- nestEventM' rsList $ handleListEvent e
l <- nestEventM' _rssList $ handleListEvent e
if isBlankElement $ listSelectedElement l
then do
let l' = listMoveTo lastnonblankidx l
scrollSelectionToMiddle l'
put' ui{aScreen=scr{rsList=l'}}
put' ui{aScreen=RS sst{_rssList=l'}}
else
put' ui{aScreen=scr{rsList=l}}
put' ui{aScreen=RS sst{_rssList=l}}
-- fall through to the list's event handler (handles other [pg]up/down events)
VtyEvent e -> do
let e' = normaliseMovementKeys e
newitems <- nestEventM' rsList $ handleListEvent e'
put' ui{aScreen=scr{rsList=newitems}}
newitems <- nestEventM' _rssList $ handleListEvent e'
put' ui{aScreen=RS sst{_rssList=newitems}}
MouseDown{} -> return ()
MouseUp{} -> return ()
@ -425,9 +330,26 @@ rsHandle ev = do
isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
rsCenterSelection :: UIState -> EventM Name UIState UIState
rsCenterSelection ui = do
scrollSelectionToMiddle $ rsList $ aScreen ui
return ui -- ui is unchanged, but this makes the function more chainable
rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements
rsSetAccount :: AccountName -> Bool -> Screen -> Screen
rsSetAccount a forceinclusive (RS st@RSS{}) =
RS st{_rssAccount=replaceHiddenAccountsNameWith "*" a, _rssForceInclusive=forceinclusive}
rsSetAccount _ _ st = st
-- | Scroll the selected item to the middle of the screen, when on the register screen.
-- No effect on other screens.
rsCenterSelection :: UIState -> EventM Name UIState UIState
rsCenterSelection ui@UIState{aScreen=RS sst} = do
scrollSelectionToMiddle $ _rssList sst
return ui -- ui is unchanged, but this makes the function more chainable
rsCenterSelection ui = return ui
rsEnterTransactionScreen :: AccountName -> [NumberedTransaction] -> NumberedTransaction -> UIState -> EventM Name UIState ()
rsEnterTransactionScreen acct nts nt ui = do
dlogUiTraceM "rsEnterTransactionScreen"
put' $
pushScreen (tsNew acct nts nt)
ui

97
hledger-ui/Hledger/UI/TransactionScreen.hs
View File

@ -6,7 +6,9 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Hledger.UI.TransactionScreen
( transactionScreen
( tsNew
, tsDraw
, tsHandle
) where
import Control.Monad
@ -14,74 +16,29 @@ import Control.Monad.Except (liftIO)
import Data.List
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 Lens.Micro ((^.))
import Brick
import Brick.Widgets.List (listElementsL, listMoveTo, listSelectedElement)
import Brick.Widgets.List (listMoveTo)
import Hledger
import Hledger.Cli hiding (mode, prices, progname,prognameandversion)
import Hledger.UI.UIOptions
-- import Hledger.UI.Theme
import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils
import Hledger.UI.UIScreens
import Hledger.UI.Editor
import Hledger.UI.ErrorScreen
import Brick.Widgets.Edit (editorText, renderEditor)
transactionScreen :: Screen
transactionScreen = TransactionScreen{
sInit = tsInit
,sDraw = tsDraw
,sHandle = tsHandle
,tsTransaction = (1,nulltransaction)
,tsTransactions = [(1,nulltransaction)]
,tsAccount = ""
}
tsInit :: Day -> Bool -> UIState -> UIState
tsInit _d _reset ui@UIState{aopts=UIOpts{}
,ajournal=_j
,aScreen=s@TransactionScreen{tsTransaction=(_,t),tsTransactions=nts}
,aPrevScreens=prevscreens
} =
ui{aScreen=s{tsTransaction=(i',t'),tsTransactions=nts'}}
where
i' = maybe 0 (toInteger . (+1)) . elemIndex t' $ map snd nts'
-- If the previous screen was RegisterScreen, use the listed and selected items as
-- the transactions. Otherwise, use the provided transaction and list.
(t',nts') = case prevscreens of
RegisterScreen{rsList=xs}:_ -> (seltxn, zip [1..] $ map rsItemTransaction nonblanks)
where
seltxn = maybe nulltransaction (rsItemTransaction . snd) $ listSelectedElement xs
nonblanks = V.toList . V.takeWhile (not . T.null . rsItemDate) $ xs ^. listElementsL
_ -> (t, nts)
tsInit _ _ _ = errorWrongScreenType "init function" -- PARTIAL:
-- Render a transaction suitably for the transaction screen.
showTxn :: ReportOpts -> ReportSpec -> Journal -> Transaction -> T.Text
showTxn ropts rspec j t =
showTransactionOneLineAmounts
$ maybe id (transactionApplyValuation prices styles periodlast (_rsDay rspec)) (value_ ropts)
$ maybe id (transactionToCost styles) (conversionop_ ropts) t
-- (if real_ ropts then filterTransactionPostings (Real True) else id) -- filter postings by --real
where
prices = journalPriceOracle (infer_prices_ ropts) j
styles = journalCommodityStyles j
periodlast =
fromMaybe (error' "TransactionScreen: expected a non-empty journal") $ -- PARTIAL: shouldn't happen
reportPeriodOrJournalLastDay rspec j
import Hledger.UI.ErrorScreen (uiReloadJournalIfChanged, uiCheckBalanceAssertions)
tsDraw :: UIState -> [Widget Name]
tsDraw UIState{aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}}
,ajournal=j
,aScreen=TransactionScreen{tsTransaction=(i,t')
,tsTransactions=nts
,tsAccount=acct
}
,aScreen=TS TSS{_tssTransaction=(i,t')
,_tssTransactions=nts
,_tssAccount=acct
}
,aMode=mode
} =
case mode of
@ -141,15 +98,29 @@ tsDraw UIState{aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec
tsDraw _ = errorWrongScreenType "draw function" -- PARTIAL:
-- Render a transaction suitably for the transaction screen.
showTxn :: ReportOpts -> ReportSpec -> Journal -> Transaction -> T.Text
showTxn ropts rspec j t =
showTransactionOneLineAmounts
$ maybe id (transactionApplyValuation prices styles periodlast (_rsDay rspec)) (value_ ropts)
$ maybe id (transactionToCost styles) (conversionop_ ropts) t
-- (if real_ ropts then filterTransactionPostings (Real True) else id) -- filter postings by --real
where
prices = journalPriceOracle (infer_prices_ ropts) j
styles = journalCommodityStyles j
periodlast =
fromMaybe (error' "TransactionScreen: expected a non-empty journal") $ -- PARTIAL: shouldn't happen
reportPeriodOrJournalLastDay rspec j
tsHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
tsHandle ev = do
ui0 <- get'
case ui0 of
ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransactions=nts}
,aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}}
,ajournal=j
,aMode=mode
} ->
ui@UIState{aScreen=TS TSS{_tssTransaction=(i,t), _tssTransactions=nts}
,aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}}
,ajournal=j
,aMode=mode
} ->
case mode of
Help ->
case ev of
@ -179,7 +150,7 @@ tsHandle ev = do
-- plog (if e == AppEvent FileChange then "file change" else "manual reload") "" `seq` return ()
ej <- liftIO . runExceptT $ journalReload copts
case ej of
Left err -> put' $ screenEnter d errorScreen{esError=err} ui
Left err -> put' $ pushScreen (esNew err) ui
Right j' -> put' $ regenerateScreens j' d ui
VtyEvent (EvKey (KChar 'I') []) -> put' $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui)
@ -209,12 +180,14 @@ tsHandle ev = do
_ -> errorWrongScreenType "event handler"
-- | Select a new transaction and update the previous register screen
tsSelect i t ui@UIState{aScreen=s@TransactionScreen{}} = case aPrevScreens ui of
tsSelect :: Integer -> Transaction -> UIState -> UIState
tsSelect i t ui@UIState{aScreen=TS sst} = case aPrevScreens ui of
x:xs -> ui'{aPrevScreens=rsSelect i x : xs}
[] -> ui'
where ui' = ui{aScreen=s{tsTransaction=(i,t)}}
where ui' = ui{aScreen=TS sst{_tssTransaction=(i,t)}}
tsSelect _ _ ui = ui
-- | Select the nth item on the register screen.
rsSelect i scr@RegisterScreen{..} = scr{rsList=listMoveTo (fromInteger $ i-1) rsList}
rsSelect :: Integer -> Screen -> Screen
rsSelect i (RS sst@RSS{..}) = RS sst{_rssList=listMoveTo (fromInteger $ i-1) _rssList}
rsSelect _ scr = scr

264
hledger-ui/Hledger/UI/UIScreens.hs Normal file
View File

@ -0,0 +1,264 @@
-- | Constructors and updaters for all hledger-ui screens.
--
-- Constructors (*New) create and initialise a new screen with valid state,
-- based on the provided options, reporting date, journal, and screen-specific parameters.
--
-- Updaters (*Update) recalculate an existing screen's state,
-- based on new options, reporting date, journal, and the old screen state.
--
-- These are gathered in this low-level module so that any screen's handler
-- can create or regenerate all other screens.
-- Drawing and event-handling code is elsewhere, in per-screen modules.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hledger.UI.UIScreens
(screenUpdate
,asNew
,asUpdate
,rsNew
,rsUpdate
,tsNew
,tsUpdate
,esNew
,esUpdate
)
where
import Brick.Widgets.List (listMoveTo, listSelectedElement, list)
import Data.List
import Data.Maybe
import Data.Time.Calendar (Day, diffDays)
import Safe
import qualified Data.Vector as V
import Hledger.Cli hiding (mode, progname,prognameandversion)
import Hledger.UI.UIOptions
import Hledger.UI.UITypes
import Hledger.UI.UIUtils
-- | Regenerate the content of any screen from new options, reporting date and journal.
screenUpdate :: UIOpts -> Day -> Journal -> Screen -> Screen
screenUpdate opts d j = \case
AS ass -> AS $ asUpdate opts d j ass
RS rss -> RS $ rsUpdate opts d j rss
TS tss -> TS $ tsUpdate tss
ES ess -> ES $ esUpdate ess
-- | Construct an accounts screen listing the appropriate set of accounts,
-- with the appropriate one selected.
-- Screen-specific arguments: the account to select if any.
asNew :: UIOpts -> Day -> Journal -> Maybe AccountName -> Screen
asNew uopts d j macct =
dlogUiTrace "asNew" $
AS $
asUpdate uopts d j $
ASS {
_assSelectedAccount = fromMaybe "" macct
,_assList = list AccountsList (V.fromList []) 1
}
-- | Recalculate an accounts screen from these options, reporting date, and journal.
asUpdate :: UIOpts -> Day -> Journal -> AccountsScreenState -> AccountsScreenState
asUpdate uopts d j ass = dlogUiTrace "asUpdate" ass{_assList=l}
where
UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} = uopts
-- decide which account is selected:
-- if selectfirst is true, the first account;
-- otherwise, the previously selected account if possible;
-- otherwise, the first account with the same prefix (eg first leaf account when entering flat mode);
-- otherwise, the alphabetically preceding account.
l =
listMoveTo selidx $
list AccountsList (V.fromList $ displayitems ++ blankitems) 1
where
selidx = headDef 0 $ catMaybes [
elemIndex a as
,findIndex (a `isAccountNamePrefixOf`) as
,Just $ max 0 (length (filter (< a) as) - 1)
]
where
a = _assSelectedAccount ass
as = map asItemAccountName displayitems
displayitems = map displayitem items
where
-- run the report
(items, _) = balanceReport rspec' j
where
rspec' =
-- Further restrict the query based on the current period and future/forecast mode.
(reportSpecSetFutureAndForecast d (forecast_ $ inputopts_ copts) rspec)
-- always show declared accounts even if unused
{_rsReportOpts=ropts{declared_=True}}
-- pre-render a list item
displayitem (fullacct, shortacct, indent, bal) =
AccountsScreenItem{asItemIndentLevel = indent
,asItemAccountName = fullacct
,asItemDisplayAccountName = replaceHiddenAccountsNameWith "All" $ if tree_ ropts then shortacct else fullacct
,asItemMixedAmount = Just bal
}
-- blanks added for scrolling control, cf RegisterScreen.
-- XXX Ugly. Changing to 0 helps when debugging.
blankitems = replicate uiNumBlankItems
AccountsScreenItem{asItemIndentLevel = 0
,asItemAccountName = ""
,asItemDisplayAccountName = ""
,asItemMixedAmount = Nothing
}
-- | Construct a register screen listing the appropriate set of transactions,
-- with the appropriate one selected.
-- Screen-specific arguments: the account whose register this is,
-- whether to force inclusive balances.
rsNew :: UIOpts -> Day -> Journal -> AccountName -> Bool -> Screen
rsNew uopts d j acct forceinclusive = -- XXX forcedefaultselection - whether to force selecting the last transaction.
dlogUiTrace "rsNew" $
RS $
rsUpdate uopts d j $
RSS {
_rssAccount = replaceHiddenAccountsNameWith "*" acct
,_rssForceInclusive = forceinclusive
,_rssList = list RegisterList (V.fromList []) 1
}
-- | Recalculate a register screen from these options, reporting date, and journal.
rsUpdate :: UIOpts -> Day -> Journal -> RegisterScreenState -> RegisterScreenState
rsUpdate uopts d j rss@RSS{_rssAccount, _rssForceInclusive, _rssList=oldlist} =
dlogUiTrace "rsUpdate"
rss{_rssList=l'}
where
UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} = uopts
-- gather arguments and queries
-- XXX temp
inclusive = tree_ ropts || _rssForceInclusive
thisacctq = Acct $ mkregex _rssAccount
where
mkregex = if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex
-- adjust the report options and report spec, carefully as usual to avoid screwups (#1523)
rspec' =
reportSpecSetFutureAndForecast d (forecast_ $ inputopts_ copts) .
either (error "rsUpdate: adjusting the query for register, should not have failed") id $ -- PARTIAL:
updateReportSpec ropts' rspec{_rsDay=d}
ropts' = ropts {
-- ignore any depth limit, as in postingsReport; allows register's total to match accounts screen
depth_=Nothing
-- do not strip prices so we can toggle costs within the ui
, show_costs_=True
-- XXX aregister also has this, needed ?
-- always show historical balance
-- , balanceaccum_= Historical
}
-- gather transactions to display
items = accountTransactionsReport rspec' j thisacctq
items' =
(if empty_ ropts then id else filter (not . mixedAmountLooksZero . fifth6)) $ -- without --empty, exclude no-change txns
reverse -- most recent last
items
-- pre-render the list items, helps calculate column widths
displayitems = map displayitem items'
where
displayitem (t, _, _issplit, otheracctsstr, change, bal) =
RegisterScreenItem{rsItemDate = showDate $ transactionRegisterDate wd (_rsQuery rspec') thisacctq t
,rsItemStatus = tstatus t
,rsItemDescription = tdescription t
,rsItemOtherAccounts = otheracctsstr
-- _ -> "<split>" -- should do this if accounts field width < 30
,rsItemChangeAmount = showamt change
,rsItemBalanceAmount = showamt bal
,rsItemTransaction = t
}
where
showamt = showMixedAmountB oneLine{displayMaxWidth=Just 3}
wd = whichDate ropts'
-- blank items are added to allow more control of scroll position; we won't allow movement over these.
-- XXX Ugly. Changing to 0 helps when debugging.
blankitems = replicate uiNumBlankItems
RegisterScreenItem{rsItemDate = ""
,rsItemStatus = Unmarked
,rsItemDescription = ""
,rsItemOtherAccounts = ""
,rsItemChangeAmount = mempty
,rsItemBalanceAmount = mempty
,rsItemTransaction = nulltransaction
}
-- build the new list widget
l = list RegisterList (V.fromList $ displayitems ++ blankitems) 1
-- ensure the appropriate list item is selected:
-- if forcedefaultselection is true, the last (latest) transaction; XXX still needed ?
-- otherwise, the previously selected transaction if possible;
-- otherwise, the transaction nearest in date to it;
-- or if there's several with the same date, the nearest in journal order;
-- otherwise, the last (latest) transaction.
l' = listMoveTo newselidx l
where
endidx = max 0 $ length displayitems - 1
newselidx =
-- case (forcedefaultselection, listSelectedElement _rssList) of
-- (True, _) -> endidx
-- (_, Nothing) -> endidx
-- (_, Just (_, RegisterScreenItem{rsItemTransaction=Transaction{tindex=prevselidx, tdate=prevseld}})) ->
-- headDef endidx $ catMaybes [
-- findIndex ((==prevselidx) . tindex . rsItemTransaction) displayitems
-- ,findIndex ((==nearestidbydatethenid) . Just . tindex . rsItemTransaction) displayitems
-- ]
-- where
-- nearestidbydatethenid = third3 <$> (headMay $ sort
-- [(abs $ diffDays (tdate t) prevseld, abs (tindex t - prevselidx), tindex t) | t <- ts])
-- ts = map rsItemTransaction displayitems
case listSelectedElement oldlist of
Nothing -> endidx
Just (_, RegisterScreenItem{rsItemTransaction=Transaction{tindex=prevselidx, tdate=prevseld}}) ->
headDef endidx $ catMaybes [
findIndex ((==prevselidx) . tindex . rsItemTransaction) displayitems
,findIndex ((==nearestidbydatethenid) . Just . tindex . rsItemTransaction) displayitems
]
where
nearestidbydatethenid = third3 <$> (headMay $ sort
[(abs $ diffDays (tdate t) prevseld, abs (tindex t - prevselidx), tindex t) | t <- ts])
ts = map rsItemTransaction displayitems
-- | Construct a transaction screen showing one of a given list of transactions,
-- with the ability to step back and forth through the list.
-- Screen-specific arguments: the account whose transactions are being shown,
-- the list of showable transactions, the currently shown transaction.
tsNew :: AccountName -> [NumberedTransaction] -> NumberedTransaction -> Screen
tsNew acct nts nt =
dlogUiTrace "tsNew" $
TS TSS{
_tssAccount = acct
,_tssTransactions = nts
,_tssTransaction = nt
}
-- | Recalculate a transaction screen. Currently a no-op since transaction screen
-- depends only on its screen-specific state.
tsUpdate :: TransactionScreenState -> TransactionScreenState
tsUpdate = dlogUiTrace "tsUpdate"
-- | Construct a error screen.
-- Screen-specific arguments: the error message to show.
esNew :: String -> Screen
esNew msg =
dlogUiTrace "esNew" $
ES ESS {
_essError = msg
,_essUnused = ()
}
-- | Recalculate an error screen. Currently a no-op since error screen
-- depends only on its screen-specific state.
esUpdate :: ErrorScreenState -> ErrorScreenState
esUpdate = dlogUiTrace "esUpdate`"

110
hledger-ui/Hledger/UI/UIState.hs
View File

@ -1,26 +1,77 @@
{- | UIState operations. -}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.UI.UIState
(uiState
,uiShowStatus
,setFilter
,setMode
,setReportPeriod
,showMinibuffer
,closeMinibuffer
,toggleCleared
,toggleConversionOp
,toggleIgnoreBalanceAssertions
,toggleEmpty
,toggleForecast
,toggleHistorical
,togglePending
,toggleUnmarked
,toggleReal
,toggleTree
,setTree
,setList
,toggleValue
,reportPeriod
,shrinkReportPeriod
,growReportPeriod
,nextReportPeriod
,previousReportPeriod
,resetReportPeriod
,moveReportPeriodToDate
,getDepth
,setDepth
,decDepth
,incDepth
,resetDepth
,popScreen
,pushScreen
,enableForecastPreservingPeriod
,resetFilter
,resetScreens
,regenerateScreens
)
where
import Brick.Widgets.Edit
import Data.Bifunctor (first)
import Data.Foldable (asum)
import Data.Either (fromRight)
import Data.List ((\\), foldl', sort)
import Data.List ((\\), sort)
import Data.Maybe (fromMaybe)
import Data.Semigroup (Max(..))
import qualified Data.Text as T
import Data.Text.Zipper (gotoEOL)
import Data.Time.Calendar (Day)
import Lens.Micro ((^.), over, set)
import Safe
import Hledger
import Hledger.Cli.CliOptions
import Hledger.UI.UITypes
import Hledger.UI.UIOptions (UIOpts)
import Hledger.UI.UIScreens (screenUpdate)
-- | Make an initial UI state with the given options, journal,
-- parent screen stack if any, and starting screen.
uiState :: UIOpts -> Journal -> [Screen] -> Screen -> UIState
uiState uopts j prevscrs scr = UIState {
astartupopts = uopts
,aopts = uopts
,ajournal = j
,aMode = Normal
,aScreen = scr
,aPrevScreens = prevscrs
}
-- | Toggle between showing only unmarked items or all items.
toggleUnmarked :: UIState -> UIState
@ -66,7 +117,7 @@ toggleStatus1 s ss = if ss == [s] then [] else [s]
-- pressing Y after first or second step starts new cycle:
-- [u] P [p]
-- [pc] P [p]
-- toggleStatus2 s ss
-- toggleStatus s ss
-- | ss == [s] = complement [s]
-- | ss == complement [s] = []
-- | otherwise = [s] -- XXX assume only three values
@ -218,10 +269,10 @@ resetFilter = set querystringNoUpdate [] . set realNoUpdate False . set statuses
. set empty__ True -- set period PeriodAll
. set rsQuery Any . set rsQueryOpts []
-- | Reset all options state to exactly what it was at startup
-- (preserving any command-line options/arguments).
resetOpts :: UIState -> UIState
resetOpts ui@UIState{astartupopts} = ui{aopts=astartupopts}
-- -- | Reset all options state to exactly what it was at startup
-- -- (preserving any command-line options/arguments).
-- resetOpts :: UIState -> UIState
-- resetOpts ui@UIState{astartupopts} = ui{aopts=astartupopts}
resetDepth :: UIState -> UIState
resetDepth = updateReportDepth (const Nothing)
@ -278,22 +329,6 @@ closeMinibuffer = setMode Normal
setMode :: Mode -> UIState -> UIState
setMode m ui = ui{aMode=m}
-- | Regenerate the content for the current and previous screens, from a new journal and current date.
regenerateScreens :: Journal -> Day -> UIState -> UIState
regenerateScreens j d ui@UIState{aScreen=s,aPrevScreens=ss} =
-- XXX clumsy due to entanglement of UIState and Screen.
-- sInit operates only on an appstate's current screen, so
-- remove all the screens from the appstate and then add them back
-- one at a time, regenerating as we go.
let
frst:rest = reverse $ s:ss :: [Screen]
ui0 = ui{ajournal=j, aScreen=frst, aPrevScreens=[]} :: UIState
ui1 = (sInit frst) d False ui0 :: UIState
ui2 = foldl' (\ui' s' -> (sInit s') d False $ pushScreen s' ui') ui1 rest :: UIState
in
ui2
pushScreen :: Screen -> UIState -> UIState
pushScreen scr ui = ui{aPrevScreens=(aScreen ui:aPrevScreens ui)
,aScreen=scr
@ -303,18 +338,19 @@ popScreen :: UIState -> UIState
popScreen ui@UIState{aPrevScreens=s:ss} = ui{aScreen=s, aPrevScreens=ss}
popScreen ui = ui
-- | Reset options to their startup values, discard screen navigation history,
-- and return to the top screen, regenerating it with the startup options
-- and the provided reporting date.
resetScreens :: Day -> UIState -> UIState
resetScreens d ui@UIState{aScreen=s,aPrevScreens=ss} =
(sInit topscreen) d True $
resetOpts $
closeMinibuffer ui{aScreen=topscreen, aPrevScreens=[]}
resetScreens d ui@UIState{astartupopts=origopts, ajournal=j, aScreen=s,aPrevScreens=ss} =
ui{aopts=origopts, aPrevScreens=[], aScreen=topscreen', aMode=Normal}
where
topscreen = case ss of _:_ -> last ss
[] -> s
topscreen' = screenUpdate origopts d j $ lastDef s ss
-- | Regenerate the content of the current and all parent screens
-- from a new journal and reporting date (and current options),
-- while preserving the screen navigation history.
regenerateScreens :: Journal -> Day -> UIState -> UIState
regenerateScreens j d ui@UIState{aopts=opts, aScreen=s,aPrevScreens=ss} =
ui{aScreen=screenUpdate opts d j s, aPrevScreens=map (screenUpdate opts d j) ss}
-- | Enter a new screen, saving the old screen & state in the
-- navigation history and initialising the new screen's state.
screenEnter :: Day -> Screen -> UIState -> UIState
screenEnter d scr ui = (sInit scr) d True $
pushScreen scr
ui

195
hledger-ui/Hledger/UI/UITypes.hs
View File

@ -36,6 +36,7 @@ Brick.defaultMain brickapp st
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE EmptyDataDeriving #-}
module Hledger.UI.UITypes where
@ -43,10 +44,9 @@ module Hledger.UI.UITypes where
-- import GHC.IO (unsafePerformIO)
import Data.Text (Text)
import Data.Time.Calendar (Day)
import Brick
import Brick.Widgets.List (List)
import Brick.Widgets.Edit (Editor)
import Lens.Micro.Platform
import Lens.Micro.Platform (makeLenses)
import Text.Show.Functions ()
-- import the Show instance for functions. Warning, this also re-exports it
@ -54,21 +54,29 @@ import Hledger
import Hledger.Cli (HasCliOpts(..))
import Hledger.UI.UIOptions
data AppEvent =
FileChange -- one of the Journal's files has been added/modified/removed
| DateChange Day Day -- the current date has changed since last checked (with the old and new values)
deriving (Eq, Show)
-- | hledger-ui's application state. This holds one or more stateful screens.
-- As you navigate through screens, the old ones are saved in a stack.
-- The app can be in one of several modes: normal screen operation,
-- showing a help dialog, entering data in the minibuffer etc.
data UIState = UIState {
astartupopts :: UIOpts -- ^ the command-line options and query arguments specified at startup
,aopts :: UIOpts -- ^ the command-line options and query arguments currently in effect
,ajournal :: Journal -- ^ the journal being viewed
,aPrevScreens :: [Screen] -- ^ previously visited screens, most recent first
,aScreen :: Screen -- ^ the currently active screen
,aMode :: Mode -- ^ the currently active mode
-- unchanging:
astartupopts :: UIOpts -- ^ the command-line options and query arguments specified at program start
-- can change while program runs:
,aopts :: UIOpts -- ^ the command-line options and query arguments currently in effect
,ajournal :: Journal -- ^ the journal being viewed (can change with --watch)
,aPrevScreens :: [Screen] -- ^ previously visited screens, most recent first
,aScreen :: Screen -- ^ the currently active screen
,aMode :: Mode -- ^ the currently active mode on the current screen
} deriving (Show)
-- | The mode modifies the screen's rendering and event handling.
-- It resets to Normal when entering a new screen.
-- | Any screen can be in one of several modes, which modifies
-- its rendering and event handling.
-- The mode resets to Normal when entering a new screen.
data Mode =
Normal
| Help
@ -89,60 +97,108 @@ data Name =
| TransactionEditor
deriving (Ord, Show, Eq)
data AppEvent =
FileChange -- one of the Journal's files has been added/modified/removed
| DateChange Day Day -- the current date has changed since last checked (with the old and new values)
deriving (Eq, Show)
-- | hledger-ui screen types & instances.
----------------------------------------------------------------------------------------------------
-- | hledger-ui screen types, v1, "one screen = one module"
-- These types aimed for maximum decoupling of modules and ease of adding more screens.
-- A new screen requires
-- 1. a new constructor in the Screen type,
-- 2. a new module implementing init/draw/handle functions,
-- 3. a call from any other screen which enters it.
-- Each screen type has generically named initialisation, draw, and event handling functions,
-- and zero or more uniquely named screen state fields, which hold the data for a particular
-- instance of this screen. Note the latter create partial functions, which means that some invalid
-- cases need to be handled, and also that their lenses are traversals, not single-value getters.
data Screen =
AccountsScreen {
sInit :: Day -> Bool -> UIState -> UIState -- ^ function to initialise or update this screen's state
,sDraw :: UIState -> [Widget Name] -- ^ brick renderer for this screen
,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState () -- ^ brick event handler for this screen
-- state fields.These ones have lenses:
,_asList :: List Name AccountsScreenItem -- ^ list widget showing account names & balances
,_asSelectedAccount :: AccountName -- ^ a backup of the account name from the list widget's selected item (or "")
}
| RegisterScreen {
sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: UIState -> [Widget Name]
,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
--
,rsList :: List Name RegisterScreenItem -- ^ list widget showing transactions affecting this account
,rsAccount :: AccountName -- ^ the account this register is for
,rsForceInclusive :: Bool -- ^ should this register always include subaccount transactions,
-- even when in flat mode ? (ie because entered from a
-- depth-clipped accounts screen item)
}
| TransactionScreen {
sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: UIState -> [Widget Name]
,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
--
,tsTransaction :: NumberedTransaction -- ^ the transaction we are currently viewing, and its position in the list
,tsTransactions :: [NumberedTransaction] -- ^ list of transactions we can step through
,tsAccount :: AccountName -- ^ the account whose register we entered this screen from
}
| ErrorScreen {
sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: UIState -> [Widget Name]
,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
--
,esError :: String -- ^ error message to show
}
deriving (Show)
-- XXX check for ideas: https://github.com/jtdaugherty/brick/issues/379#issuecomment-1191993357
-- data Screen =
-- AccountsScreen {
-- sInit :: Day -> Bool -> UIState -> UIState -- ^ function to initialise or update this screen's state
-- ,sDraw :: UIState -> [Widget Name] -- ^ brick renderer for this screen
-- ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState () -- ^ brick event handler for this screen
-- -- state fields.These ones have lenses:
-- ,_asList :: List Name AccountsScreenItem -- ^ list widget showing account names & balances
-- ,_asSelectedAccount :: AccountName -- ^ a backup of the account name from the list widget's selected item (or "")
-- }
-- | RegisterScreen {
-- sInit :: Day -> Bool -> UIState -> UIState
-- ,sDraw :: UIState -> [Widget Name]
-- ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
-- --
-- ,rsList :: List Name RegisterScreenItem -- ^ list widget showing transactions affecting this account
-- ,rsAccount :: AccountName -- ^ the account this register is for
-- ,rsForceInclusive :: Bool -- ^ should this register always include subaccount transactions,
-- -- even when in flat mode ? (ie because entered from a
-- -- depth-clipped accounts screen item)
-- }
-- | TransactionScreen {
-- sInit :: Day -> Bool -> UIState -> UIState
-- ,sDraw :: UIState -> [Widget Name]
-- ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
-- --
-- ,tsTransaction :: NumberedTransaction -- ^ the transaction we are currently viewing, and its position in the list
-- ,tsTransactions :: [NumberedTransaction] -- ^ list of transactions we can step through
-- ,tsAccount :: AccountName -- ^ the account whose register we entered this screen from
-- }
-- | ErrorScreen {
-- sInit :: Day -> Bool -> UIState -> UIState
-- ,sDraw :: UIState -> [Widget Name]
-- ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
-- --
-- ,esError :: String -- ^ error message to show
-- }
-- deriving (Show)
-- | Error message to use in case statements adapting to the different Screen shapes.
errorWrongScreenType :: String -> a
errorWrongScreenType lbl =
-- unsafePerformIO $ threadDelay 2000000 >> -- delay to allow console output to be seen
error' (unwords [lbl, "called with wrong screen type, should not happen"])
----------------------------------------------------------------------------------------------------
-- | hledger-ui screen types, v2, "more parts, but simpler parts"
-- These types aim to be more restrictive, allowing fewer invalid states, and easier to inspect
-- and debug. The screen types store only state, not behaviour (functions), and there is no longer
-- a circular dependency between UIState and Screen.
-- A new screen requires
-- 1. a new constructor in the Screen type,
-- 2. a new screen state type,
-- 3. new cases in the uiDraw and uiHandle functions,
-- 4. new constructor and updater functions in UIScreens, and a new case in screenUpdate
-- 5. a new module implementing draw and event-handling functions,
-- 6. a call from any other screen which enters it.
-- cf https://github.com/jtdaugherty/brick/issues/379#issuecomment-1192000374
-- | The various screens which a user can navigate to in hledger-ui,
-- along with any screen-specific parameters or data influencing what they display.
-- (The separate state types add code noise but seem to reduce partial code/invalid data a bit.)
data Screen =
AS AccountsScreenState
| RS RegisterScreenState
| TS TransactionScreenState
| ES ErrorScreenState
deriving (Show)
data AccountsScreenState = ASS {
-- screen parameters:
_assSelectedAccount :: AccountName -- ^ a copy of the account name from the list's selected item (or "")
-- view data derived from options, reporting date, journal, and screen parameters:
,_assList :: List Name AccountsScreenItem -- ^ list widget showing account names & balances
} deriving (Show)
data RegisterScreenState = RSS {
-- screen parameters:
_rssAccount :: AccountName -- ^ the account this register is for
,_rssForceInclusive :: Bool -- ^ should this register always include subaccount transactions,
-- even when in flat mode ? (ie because entered from a
-- depth-clipped accounts screen item)
-- view data derived from options, reporting date, journal, and screen parameters:
,_rssList :: List Name RegisterScreenItem -- ^ list widget showing transactions affecting this account
} deriving (Show)
data TransactionScreenState = TSS {
-- screen parameters:
_tssAccount :: AccountName -- ^ the account whose register we entered this screen from
,_tssTransactions :: [NumberedTransaction] -- ^ the transactions in that register, which we can step through
,_tssTransaction :: NumberedTransaction -- ^ the currently displayed transaction, and its position in the list
} deriving (Show)
data ErrorScreenState = ESS {
-- screen parameters:
_essError :: String -- ^ error message to show
,_essUnused :: () -- ^ dummy field to silence warning
} deriving (Show)
-- | An item in the accounts screen's list of accounts and balances.
data AccountsScreenItem = AccountsScreenItem {
@ -166,13 +222,27 @@ data RegisterScreenItem = RegisterScreenItem {
type NumberedTransaction = (Integer, Transaction)
-- These TH calls must come after most of the types above.
-- Fields named _foo produce lenses named foo.
-- XXX foo fields producing fooL lenses would be preferable
makeLenses ''AccountsScreenState
makeLenses ''RegisterScreenState
makeLenses ''TransactionScreenState
makeLenses ''ErrorScreenState
----------------------------------------------------------------------------------------------------
-- | Error message to use in case statements adapting to the different Screen shapes.
errorWrongScreenType :: String -> a
errorWrongScreenType lbl =
-- unsafePerformIO $ threadDelay 2000000 >> -- delay to allow console output to be seen
error' (unwords [lbl, "called with wrong screen type, should not happen"])
-- dummy monoid instance needed make lenses work with List fields not common across constructors
--instance Monoid (List n a)
-- where
-- mempty = list "" V.empty 1 -- XXX problem in 0.7, every list requires a unique Name
-- mappend l1 l2 = l1 & listElementsL .~ (l1^.listElementsL <> l2^.listElementsL)
makeLenses ''Screen
-- mappend l1 l = l1 & listElementsL .~ (l1^.listElementsL <> l^.listElementsL)
uioptslens f ui = (\x -> ui{aopts=x}) <$> f (aopts ui)
@ -193,3 +263,4 @@ instance HasReportOptsNoUpdate UIState where
instance HasReportOpts UIState where
reportOpts = uioptslens.reportOpts

12
hledger-ui/Hledger/UI/UIUtils.hs
View File

@ -58,7 +58,7 @@ import Hledger
import Hledger.Cli (CliOpts)
import Hledger.Cli.DocFiles
import Hledger.UI.UITypes
import Hledger.UI.UIState
-- | On posix platforms, send the system STOP signal to suspend the
-- current program. On windows, does nothing.
@ -105,7 +105,7 @@ defaultLayout :: Widget Name -> Widget Name -> Widget Name -> Widget Name
defaultLayout toplabel bottomlabel =
topBottomBorderWithLabels (str " "<+>toplabel<+>str " ") (str " "<+>bottomlabel<+>str " ") .
margin 1 0 Nothing
-- topBottomBorderWithLabel2 label .
-- topBottomBorderWithLabel label .
-- padLeftRight 1 -- XXX should reduce inner widget's width by 2, but doesn't
-- "the layout adjusts... if you use the core combinators"
@ -192,7 +192,7 @@ helpDialog _copts =
helpHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
helpHandle ev = do
ui <- get
let ui' = setMode Normal ui
let ui' = ui{aMode=Normal}
case ev of
VtyEvent e | e `elem` closeHelpEvents -> put' ui'
VtyEvent (EvKey (KChar 'p') []) -> suspendAndResume (runPagerForTopic "hledger-ui" Nothing >> return ui')
@ -295,8 +295,8 @@ topBottomBorderWithLabels toplabel bottomlabel body =
hBorderWithLabel (withAttr (attrName "border") bottomlabel)
---- XXX should be equivalent to the above, but isn't (page down goes offscreen)
--_topBottomBorderWithLabel2 :: Widget Name -> Widget Name -> Widget Name
--_topBottomBorderWithLabel2 label = \wrapped ->
--_topBottomBorderWithLabel :: Widget Name -> Widget Name -> Widget Name
--_topBottomBorderWithLabel label = \wrapped ->
-- let debugmsg = ""
-- in hBorderWithLabel (label <+> str debugmsg)
-- <=>
@ -309,7 +309,7 @@ topBottomBorderWithLabels toplabel bottomlabel body =
-- thickness, using the current background colour or the specified
-- colour.
-- XXX May disrupt border style of inner widgets.
-- XXX Should reduce the available size visible to inner widget, but doesn't seem to (cf rsDraw2).
-- XXX Should reduce the available size visible to inner widget, but doesn't seem to (cf rsDraw).
margin :: Int -> Int -> Maybe Color -> Widget Name -> Widget Name
margin h v mcolour w = Widget Greedy Greedy $ do
ctx <- getContext

1
hledger-ui/hledger-ui.cabal
View File

@ -56,6 +56,7 @@ executable hledger-ui
Hledger.UI.Theme
Hledger.UI.TransactionScreen
Hledger.UI.UIOptions
Hledger.UI.UIScreens
Hledger.UI.UIState
Hledger.UI.UITypes
Hledger.UI.UIUtils