diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs index d07970aa5..a9c45c6b4 100644 --- a/hledger-ui/Hledger/UI/AccountsScreen.hs +++ b/hledger-ui/Hledger/UI/AccountsScreen.hs @@ -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 + diff --git a/hledger-ui/Hledger/UI/ErrorScreen.hs b/hledger-ui/Hledger/UI/ErrorScreen.hs index a7d61b6df..b15f9faff 100644 --- a/hledger-ui/Hledger/UI/ErrorScreen.hs +++ b/hledger-ui/Hledger/UI/ErrorScreen.hs @@ -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 diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 77e37c465..1db7d7b77 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -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 diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs index 641905fe5..4397826de 100644 --- a/hledger-ui/Hledger/UI/RegisterScreen.hs +++ b/hledger-ui/Hledger/UI/RegisterScreen.hs @@ -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 - -- _ -> "" -- 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 + + diff --git a/hledger-ui/Hledger/UI/TransactionScreen.hs b/hledger-ui/Hledger/UI/TransactionScreen.hs index 53c690b22..10b8679b8 100644 --- a/hledger-ui/Hledger/UI/TransactionScreen.hs +++ b/hledger-ui/Hledger/UI/TransactionScreen.hs @@ -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 diff --git a/hledger-ui/Hledger/UI/UIScreens.hs b/hledger-ui/Hledger/UI/UIScreens.hs new file mode 100644 index 000000000..cfc5939be --- /dev/null +++ b/hledger-ui/Hledger/UI/UIScreens.hs @@ -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 + -- _ -> "" -- 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`" + diff --git a/hledger-ui/Hledger/UI/UIState.hs b/hledger-ui/Hledger/UI/UIState.hs index a8dbd49ef..847be7f5c 100644 --- a/hledger-ui/Hledger/UI/UIState.hs +++ b/hledger-ui/Hledger/UI/UIState.hs @@ -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 diff --git a/hledger-ui/Hledger/UI/UITypes.hs b/hledger-ui/Hledger/UI/UITypes.hs index 8af7dcb9e..2075b101c 100644 --- a/hledger-ui/Hledger/UI/UITypes.hs +++ b/hledger-ui/Hledger/UI/UITypes.hs @@ -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 + diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs index a188916d4..b9e5032f7 100644 --- a/hledger-ui/Hledger/UI/UIUtils.hs +++ b/hledger-ui/Hledger/UI/UIUtils.hs @@ -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 diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index 86da654b8..31e113cf5 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -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