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

ui: refactor: AppState -> UIState, cleanups

Browse Source
This commit is contained in:
Simon Michael 2016-06-10 17:30:45 -07:00
parent 0851851ea9
commit 47a8eb53c8
9 changed files with 376 additions and 396 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,7 +21,7 @@ import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import System.FilePath (takeFileName) import System.FilePath (takeFileName)
import qualified Data.Vector as V import qualified Data.Vector as V
import Graphics.Vty as Vty import Graphics.Vty
import Brick import Brick
-- import Brick.Widgets.Center -- import Brick.Widgets.Center
import Brick.Widgets.List import Brick.Widgets.List
@ -37,6 +37,7 @@ import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.UIOptions import Hledger.UI.UIOptions
-- import Hledger.UI.Theme -- import Hledger.UI.Theme
import Hledger.UI.UITypes import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils import Hledger.UI.UIUtils
import Hledger.UI.RegisterScreen import Hledger.UI.RegisterScreen
import Hledger.UI.ErrorScreen import Hledger.UI.ErrorScreen
@ -50,13 +51,13 @@ accountsScreen = AccountsScreen{
,_asSelectedAccount = "" ,_asSelectedAccount = ""
} }
asInit :: Day -> Bool -> AppState -> AppState asInit :: Day -> Bool -> UIState -> UIState
asInit d reset st@AppState{ asInit d reset ui@UIState{
aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}, aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}},
ajournal=j, ajournal=j,
aScreen=s@AccountsScreen{} aScreen=s@AccountsScreen{}
} = } =
st{aopts=uopts', aScreen=s & asList .~ newitems'} ui{aopts=uopts', aScreen=s & asList .~ newitems'}
where where
newitems = list (Name "accounts") (V.fromList displayitems) 1 newitems = list (Name "accounts") (V.fromList displayitems) 1
@ -103,8 +104,8 @@ asInit d reset st@AppState{
asInit _ _ _ = error "init function called with wrong screen type, should not happen" asInit _ _ _ = error "init function called with wrong screen type, should not happen"
asDraw :: AppState -> [Widget] asDraw :: UIState -> [Widget]
asDraw AppState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}} asDraw UIState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}}
,ajournal=j ,ajournal=j
,aScreen=s@AccountsScreen{} ,aScreen=s@AccountsScreen{}
,aMode=mode ,aMode=mode
@ -230,8 +231,8 @@ asDrawItem (acctwidth, balwidth) selected AccountsScreenItem{..} =
sel | selected = (<> "selected") sel | selected = (<> "selected")
| otherwise = id | otherwise = id
asHandle :: AppState -> Vty.Event -> EventM (Next AppState) asHandle :: UIState -> Event -> EventM (Next UIState)
asHandle st'@AppState{ asHandle ui0@UIState{
aScreen=scr@AccountsScreen{..} aScreen=scr@AccountsScreen{..}
,aopts=UIOpts{cliopts_=copts} ,aopts=UIOpts{cliopts_=copts}
,ajournal=j ,ajournal=j
@ -247,62 +248,62 @@ asHandle st'@AppState{
selacct = case listSelectedElement $ scr ^. asList of selacct = case listSelectedElement $ scr ^. asList of
Just (_, AccountsScreenItem{..}) -> asItemAccountName Just (_, AccountsScreenItem{..}) -> asItemAccountName
Nothing -> scr ^. asSelectedAccount Nothing -> scr ^. asSelectedAccount
st = st'{aScreen=scr & asSelectedAccount .~ selacct} ui = ui0{aScreen=scr & asSelectedAccount .~ selacct}
case mode of case mode of
Minibuffer ed -> Minibuffer ed ->
case ev of case ev of
EvKey KEsc [] -> continue $ stCloseMinibuffer st EvKey KEsc [] -> continue $ closeMinibuffer ui
EvKey KEnter [] -> continue $ regenerateScreens j d $ stFilter s $ stCloseMinibuffer st EvKey KEnter [] -> continue $ regenerateScreens j d $ setFilter s $ closeMinibuffer ui
where s = chomp $ unlines $ getEditContents ed where s = chomp $ unlines $ getEditContents ed
ev -> do ed' <- handleEvent ev ed ev -> do ed' <- handleEvent ev ed
continue $ st{aMode=Minibuffer ed'} continue $ ui{aMode=Minibuffer ed'}
Help -> Help ->
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
_ -> helpHandle st ev _ -> helpHandle ui ev
Normal -> Normal ->
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
-- EvKey (KChar 'l') [MCtrl] -> do -- EvKey (KChar 'l') [MCtrl] -> do
EvKey KEsc [] -> continue $ resetScreens d st EvKey KEsc [] -> continue $ resetScreens d ui
EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help st EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help ui
EvKey (KChar 'g') [] -> liftIO (stReloadJournalIfChanged copts d j st) >>= continue EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j ui) >>= continue
EvKey (KChar 'a') [] -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> stReloadJournalIfChanged copts d j st EvKey (KChar 'a') [] -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui
EvKey (KChar '0') [] -> continue $ regenerateScreens j d $ setDepth (Just 0) st EvKey (KChar '0') [] -> continue $ regenerateScreens j d $ setDepth (Just 0) ui
EvKey (KChar '1') [] -> continue $ regenerateScreens j d $ setDepth (Just 1) st EvKey (KChar '1') [] -> continue $ regenerateScreens j d $ setDepth (Just 1) ui
EvKey (KChar '2') [] -> continue $ regenerateScreens j d $ setDepth (Just 2) st EvKey (KChar '2') [] -> continue $ regenerateScreens j d $ setDepth (Just 2) ui
EvKey (KChar '3') [] -> continue $ regenerateScreens j d $ setDepth (Just 3) st EvKey (KChar '3') [] -> continue $ regenerateScreens j d $ setDepth (Just 3) ui
EvKey (KChar '4') [] -> continue $ regenerateScreens j d $ setDepth (Just 4) st EvKey (KChar '4') [] -> continue $ regenerateScreens j d $ setDepth (Just 4) ui
EvKey (KChar '5') [] -> continue $ regenerateScreens j d $ setDepth (Just 5) st EvKey (KChar '5') [] -> continue $ regenerateScreens j d $ setDepth (Just 5) ui
EvKey (KChar '6') [] -> continue $ regenerateScreens j d $ setDepth (Just 6) st EvKey (KChar '6') [] -> continue $ regenerateScreens j d $ setDepth (Just 6) ui
EvKey (KChar '7') [] -> continue $ regenerateScreens j d $ setDepth (Just 7) st EvKey (KChar '7') [] -> continue $ regenerateScreens j d $ setDepth (Just 7) ui
EvKey (KChar '8') [] -> continue $ regenerateScreens j d $ setDepth (Just 8) st EvKey (KChar '8') [] -> continue $ regenerateScreens j d $ setDepth (Just 8) ui
EvKey (KChar '9') [] -> continue $ regenerateScreens j d $ setDepth (Just 9) st EvKey (KChar '9') [] -> continue $ regenerateScreens j d $ setDepth (Just 9) ui
EvKey (KChar '-') [] -> continue $ regenerateScreens j d $ decDepth st EvKey (KChar '-') [] -> continue $ regenerateScreens j d $ decDepth ui
EvKey (KChar '_') [] -> continue $ regenerateScreens j d $ decDepth st EvKey (KChar '_') [] -> continue $ regenerateScreens j d $ decDepth ui
EvKey k [] | k `elem` [KChar '+', KChar '='] -> continue $ regenerateScreens j d $ incDepth st EvKey k [] | k `elem` [KChar '+', KChar '='] -> continue $ regenerateScreens j d $ incDepth ui
EvKey (KChar 'F') [] -> continue $ regenerateScreens j d $ stToggleFlat st EvKey (KChar 'F') [] -> continue $ regenerateScreens j d $ toggleFlat ui
EvKey (KChar 'E') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleEmpty st) EvKey (KChar 'E') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleEmpty ui)
EvKey (KChar 'C') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleCleared st) EvKey (KChar 'C') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleCleared ui)
EvKey (KChar 'U') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleUncleared st) EvKey (KChar 'U') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleUncleared ui)
EvKey (KChar 'R') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleReal st) EvKey (KChar 'R') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleReal ui)
EvKey k [] | k `elem` [KChar '/'] -> continue $ regenerateScreens j d $ stShowMinibuffer st EvKey k [] | k `elem` [KChar '/'] -> continue $ regenerateScreens j d $ showMinibuffer ui
EvKey k [] | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ stResetFilter st) EvKey k [] | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ resetFilter ui)
EvKey (KLeft) [] -> continue $ popScreen st EvKey (KLeft) [] -> continue $ popScreen ui
EvKey (k) [] | k `elem` [KRight, KEnter] -> scrollTopRegister >> continue (screenEnter d scr st) EvKey (k) [] | k `elem` [KRight, KEnter] -> scrollTopRegister >> continue (screenEnter d scr ui)
where where
scr = rsSetAccount selacct registerScreen scr = rsSetAccount selacct registerScreen
-- fall through to the list's event handler (handles up/down) -- fall through to the list's event handler (handles up/down)
ev -> do ev -> do
newitems <- handleEvent ev (scr ^. asList) newitems <- handleEvent ev (scr ^. asList)
continue $ st{aScreen=scr & asList .~ newitems continue $ ui{aScreen=scr & asList .~ newitems
& asSelectedAccount .~ selacct & asSelectedAccount .~ selacct
} }
-- continue =<< handleEventLensed st someLens ev -- continue =<< handleEventLensed ui someLens ev
where where
-- Encourage a more stable scroll position when toggling list items. -- Encourage a more stable scroll position when toggling list items.

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

@ -4,7 +4,7 @@
module Hledger.UI.ErrorScreen module Hledger.UI.ErrorScreen
(errorScreen (errorScreen
,stReloadJournalIfChanged ,uiReloadJournalIfChanged
) )
where where
@ -13,7 +13,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.Monoid import Data.Monoid
-- import Data.Maybe -- import Data.Maybe
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Graphics.Vty as Vty import Graphics.Vty
import Brick import Brick
-- import Brick.Widgets.List -- import Brick.Widgets.List
-- import Brick.Widgets.Border -- import Brick.Widgets.Border
@ -26,6 +26,7 @@ import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.UIOptions import Hledger.UI.UIOptions
-- import Hledger.UI.Theme -- import Hledger.UI.Theme
import Hledger.UI.UITypes import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils import Hledger.UI.UIUtils
errorScreen :: Screen errorScreen :: Screen
@ -36,12 +37,12 @@ errorScreen = ErrorScreen{
,esError = "" ,esError = ""
} }
esInit :: Day -> Bool -> AppState -> AppState esInit :: Day -> Bool -> UIState -> UIState
esInit _ _ st@AppState{aScreen=ErrorScreen{}} = st esInit _ _ ui@UIState{aScreen=ErrorScreen{}} = ui
esInit _ _ _ = error "init function called with wrong screen type, should not happen" esInit _ _ _ = error "init function called with wrong screen type, should not happen"
esDraw :: AppState -> [Widget] esDraw :: UIState -> [Widget]
esDraw AppState{ -- aopts=_uopts@UIOpts{cliopts_=_copts@CliOpts{reportopts_=_ropts@ReportOpts{query_=querystr}}}, esDraw UIState{ -- aopts=_uopts@UIOpts{cliopts_=_copts@CliOpts{reportopts_=_ropts@ReportOpts{query_=querystr}}},
aScreen=ErrorScreen{..} aScreen=ErrorScreen{..}
,aMode=mode} = ,aMode=mode} =
case mode of case mode of
@ -65,8 +66,8 @@ esDraw AppState{ -- aopts=_uopts@UIOpts{cliopts_=_copts@CliOpts{reportopts_=_rop
esDraw _ = error "draw function called with wrong screen type, should not happen" esDraw _ = error "draw function called with wrong screen type, should not happen"
esHandle :: AppState -> Vty.Event -> EventM (Next AppState) esHandle :: UIState -> Event -> EventM (Next UIState)
esHandle st@AppState{ esHandle ui@UIState{
aScreen=s@ErrorScreen{} aScreen=s@ErrorScreen{}
,aopts=UIOpts{cliopts_=copts} ,aopts=UIOpts{cliopts_=copts}
,ajournal=j ,ajournal=j
@ -75,35 +76,35 @@ esHandle st@AppState{
case mode of case mode of
Help -> Help ->
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
_ -> helpHandle st ev _ -> helpHandle ui ev
_ -> do _ -> do
d <- liftIO getCurrentDay d <- liftIO getCurrentDay
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
EvKey KEsc [] -> continue $ resetScreens d st EvKey KEsc [] -> continue $ resetScreens d ui
EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help st EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help ui
EvKey (KChar 'g') [] -> do EvKey (KChar 'g') [] -> do
(ej, _) <- liftIO $ journalReloadIfChanged copts d j (ej, _) <- liftIO $ journalReloadIfChanged copts d j
case ej of case ej of
Left err -> continue st{aScreen=s{esError=err}} -- show latest parse error Left err -> continue ui{aScreen=s{esError=err}} -- show latest parse error
Right j' -> continue $ regenerateScreens j' d $ popScreen st -- return to previous screen, and reload it Right j' -> continue $ regenerateScreens j' d $ popScreen ui -- return to previous screen, and reload it
-- EvKey (KLeft) [] -> continue $ popScreen st -- EvKey (KLeft) [] -> continue $ popScreen ui
-- EvKey (KRight) [] -> error (show curItem) where curItem = listSelectedElement is -- EvKey (KRight) [] -> error (show curItem) where curItem = listSelectedElement is
-- fall through to the list's event handler (handles [pg]up/down) -- fall through to the list's event handler (handles [pg]up/down)
_ -> do continue st _ -> do continue ui
-- is' <- handleEvent ev is -- is' <- handleEvent ev is
-- continue st{aScreen=s{rsState=is'}} -- continue ui{aScreen=s{rsState=is'}}
-- continue =<< handleEventLensed st someLens e -- continue =<< handleEventLensed ui someLens e
esHandle _ _ = error "event handler called with wrong screen type, should not happen" esHandle _ _ = error "event handler called with wrong screen type, should not happen"
-- If journal file(s) have changed, reload the journal and regenerate all screens. -- If journal file(s) have changed, reload the journal and regenerate all screens.
-- This is here so it can reference the error screen. -- This is here so it can reference the error screen.
stReloadJournalIfChanged :: CliOpts -> Day -> Journal -> AppState -> IO AppState uiReloadJournalIfChanged :: CliOpts -> Day -> Journal -> UIState -> IO UIState
stReloadJournalIfChanged copts d j st = do uiReloadJournalIfChanged copts d j ui = do
(ej, _) <- journalReloadIfChanged copts d j (ej, _) <- journalReloadIfChanged copts d j
return $ case ej of return $ case ej of
Right j' -> regenerateScreens j' d st Right j' -> regenerateScreens j' d ui
Left err -> screenEnter d errorScreen{esError=err} st Left err -> screenEnter d errorScreen{esError=err} ui

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

@ -107,10 +107,10 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} j = do
(error' $ "--register "++apat++" did not match any account") (error' $ "--register "++apat++" did not match any account")
$ filter (regexMatches apat . T.unpack) $ journalAccountNames j $ filter (regexMatches apat . T.unpack) $ journalAccountNames j
-- Initialising the accounts screen is awkward, requiring -- Initialising the accounts screen is awkward, requiring
-- another temporary AppState value.. -- another temporary UIState value..
ascr' = aScreen $ ascr' = aScreen $
asInit d True $ asInit d True $
AppState{ UIState{
aopts=uopts' aopts=uopts'
,ajournal=j ,ajournal=j
,aScreen=asSetSelectedAccount acct accountsScreen ,aScreen=asSetSelectedAccount acct accountsScreen
@ -118,8 +118,8 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} j = do
,aMode=Normal ,aMode=Normal
} }
st = (sInit scr) d True ui = (sInit scr) d True
AppState{ UIState{
aopts=uopts' aopts=uopts'
,ajournal=j ,ajournal=j
,aScreen=scr ,aScreen=scr
@ -127,20 +127,15 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} j = do
,aMode=Normal ,aMode=Normal
} }
brickapp :: App (AppState) V.Event brickapp :: App (UIState) V.Event
brickapp = App { brickapp = App {
appLiftVtyEvent = id appLiftVtyEvent = id
, appStartEvent = return , appStartEvent = return
, appAttrMap = const theme , appAttrMap = const theme
, appChooseCursor = showFirstCursor , appChooseCursor = showFirstCursor
, appHandleEvent = \st ev -> sHandle (aScreen st) st ev , appHandleEvent = \ui ev -> sHandle (aScreen ui) ui ev
, appDraw = \st -> sDraw (aScreen st) st , appDraw = \ui -> sDraw (aScreen ui) ui
-- XXX bizarro. removing the st arg and parameter above,
-- which according to GHCI does not change the type,
-- causes "Exception: draw function called with wrong screen type"
-- on entering a register. Likewise, removing the st ev args and parameters
-- causes an exception on exiting a register.
} }
void $ defaultMain brickapp st void $ defaultMain brickapp ui

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

@ -18,7 +18,7 @@ import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import qualified Data.Vector as V import qualified Data.Vector as V
import Graphics.Vty as Vty import Graphics.Vty
import Brick import Brick
import Brick.Widgets.List import Brick.Widgets.List
import Brick.Widgets.Edit import Brick.Widgets.Edit
@ -33,6 +33,7 @@ import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.UIOptions import Hledger.UI.UIOptions
-- import Hledger.UI.Theme -- import Hledger.UI.Theme
import Hledger.UI.UITypes import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils import Hledger.UI.UIUtils
import Hledger.UI.TransactionScreen import Hledger.UI.TransactionScreen
import Hledger.UI.ErrorScreen import Hledger.UI.ErrorScreen
@ -49,9 +50,9 @@ registerScreen = RegisterScreen{
rsSetAccount a scr@RegisterScreen{} = scr{rsAccount=a} rsSetAccount a scr@RegisterScreen{} = scr{rsAccount=a}
rsSetAccount _ scr = scr rsSetAccount _ scr = scr
rsInit :: Day -> Bool -> AppState -> AppState rsInit :: Day -> Bool -> UIState -> UIState
rsInit d reset st@AppState{aopts=opts, ajournal=j, aScreen=s@RegisterScreen{..}} = rsInit d reset ui@UIState{aopts=opts, ajournal=j, aScreen=s@RegisterScreen{..}} =
st{aScreen=s{rsList=newitems'}} ui{aScreen=s{rsList=newitems'}}
where where
-- gather arguments and queries -- gather arguments and queries
ropts = (reportopts_ $ cliopts_ opts) ropts = (reportopts_ $ cliopts_ opts)
@ -99,8 +100,8 @@ rsInit d reset st@AppState{aopts=opts, ajournal=j, aScreen=s@RegisterScreen{..}}
rsInit _ _ _ = error "init function called with wrong screen type, should not happen" rsInit _ _ _ = error "init function called with wrong screen type, should not happen"
rsDraw :: AppState -> [Widget] rsDraw :: UIState -> [Widget]
rsDraw AppState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}} rsDraw UIState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}}
,aScreen=RegisterScreen{..} ,aScreen=RegisterScreen{..}
,aMode=mode ,aMode=mode
} = } =
@ -219,8 +220,8 @@ rsDrawItem (datewidth,descwidth,acctswidth,changewidth,balwidth) selected Regist
sel | selected = (<> "selected") sel | selected = (<> "selected")
| otherwise = id | otherwise = id
rsHandle :: AppState -> Vty.Event -> EventM (Next AppState) rsHandle :: UIState -> Event -> EventM (Next UIState)
rsHandle st@AppState{ rsHandle ui@UIState{
aScreen=s@RegisterScreen{..} aScreen=s@RegisterScreen{..}
,aopts=UIOpts{cliopts_=copts} ,aopts=UIOpts{cliopts_=copts}
,ajournal=j ,ajournal=j
@ -231,31 +232,31 @@ rsHandle st@AppState{
case mode of case mode of
Minibuffer ed -> Minibuffer ed ->
case ev of case ev of
EvKey KEsc [] -> continue $ stCloseMinibuffer st EvKey KEsc [] -> continue $ closeMinibuffer ui
EvKey KEnter [] -> continue $ regenerateScreens j d $ stFilter s $ stCloseMinibuffer st EvKey KEnter [] -> continue $ regenerateScreens j d $ setFilter s $ closeMinibuffer ui
where s = chomp $ unlines $ getEditContents ed where s = chomp $ unlines $ getEditContents ed
ev -> do ed' <- handleEvent ev ed ev -> do ed' <- handleEvent ev ed
continue $ st{aMode=Minibuffer ed'} continue $ ui{aMode=Minibuffer ed'}
Help -> Help ->
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
_ -> helpHandle st ev _ -> helpHandle ui ev
Normal -> Normal ->
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
EvKey KEsc [] -> continue $ resetScreens d st EvKey KEsc [] -> continue $ resetScreens d ui
EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help st EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help ui
EvKey (KChar 'g') [] -> liftIO (stReloadJournalIfChanged copts d j st) >>= continue EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j ui) >>= continue
EvKey (KChar 'a') [] -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> stReloadJournalIfChanged copts d j st EvKey (KChar 'a') [] -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui
EvKey (KChar 'E') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleEmpty st) EvKey (KChar 'E') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleEmpty ui)
EvKey (KChar 'C') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleCleared st) EvKey (KChar 'C') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleCleared ui)
EvKey (KChar 'U') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleUncleared st) EvKey (KChar 'U') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleUncleared ui)
EvKey (KChar 'R') [] -> scrollTop >> (continue $ regenerateScreens j d $ stToggleReal st) EvKey (KChar 'R') [] -> scrollTop >> (continue $ regenerateScreens j d $ toggleReal ui)
EvKey k [] | k `elem` [KChar '/'] -> (continue $ regenerateScreens j d $ stShowMinibuffer st) EvKey k [] | k `elem` [KChar '/'] -> (continue $ regenerateScreens j d $ showMinibuffer ui)
EvKey k [] | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ stResetFilter st) EvKey k [] | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ resetFilter ui)
EvKey (KLeft) [] -> continue $ popScreen st EvKey (KLeft) [] -> continue $ popScreen ui
EvKey (k) [] | k `elem` [KRight, KEnter] -> do EvKey (k) [] | k `elem` [KRight, KEnter] -> do
case listSelectedElement rsList of case listSelectedElement rsList of
@ -267,13 +268,13 @@ rsHandle st@AppState{
in in
continue $ screenEnter d transactionScreen{tsTransaction=(i,t) continue $ screenEnter d transactionScreen{tsTransaction=(i,t)
,tsTransactions=numberedts ,tsTransactions=numberedts
,tsAccount=rsAccount} st ,tsAccount=rsAccount} ui
Nothing -> continue st Nothing -> continue ui
-- fall through to the list's event handler (handles [pg]up/down) -- fall through to the list's event handler (handles [pg]up/down)
ev -> do newitems <- handleEvent ev rsList ev -> do newitems <- handleEvent ev rsList
continue st{aScreen=s{rsList=newitems}} continue ui{aScreen=s{rsList=newitems}}
-- continue =<< handleEventLensed st someLens ev -- continue =<< handleEventLensed ui someLens ev
where where
-- Encourage a more stable scroll position when toggling list items (cf AccountsScreen.hs) -- Encourage a more stable scroll position when toggling list items (cf AccountsScreen.hs)

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

@ -19,7 +19,7 @@ import Data.Monoid
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
-- import qualified Data.Vector as V -- import qualified Data.Vector as V
import Graphics.Vty as Vty import Graphics.Vty
-- import Safe (headDef, lastDef) -- import Safe (headDef, lastDef)
import Brick import Brick
import Brick.Widgets.List (listMoveTo) import Brick.Widgets.List (listMoveTo)
@ -33,6 +33,7 @@ import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.UIOptions import Hledger.UI.UIOptions
-- import Hledger.UI.Theme -- import Hledger.UI.Theme
import Hledger.UI.UITypes import Hledger.UI.UITypes
import Hledger.UI.UIState
import Hledger.UI.UIUtils import Hledger.UI.UIUtils
import Hledger.UI.ErrorScreen import Hledger.UI.ErrorScreen
@ -46,14 +47,14 @@ transactionScreen = TransactionScreen{
,tsAccount = "" ,tsAccount = ""
} }
tsInit :: Day -> Bool -> AppState -> AppState tsInit :: Day -> Bool -> UIState -> UIState
tsInit _d _reset st@AppState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=_ropts}} tsInit _d _reset ui@UIState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=_ropts}}
,ajournal=_j ,ajournal=_j
,aScreen=TransactionScreen{..}} = st ,aScreen=TransactionScreen{..}} = ui
tsInit _ _ _ = error "init function called with wrong screen type, should not happen" tsInit _ _ _ = error "init function called with wrong screen type, should not happen"
tsDraw :: AppState -> [Widget] tsDraw :: UIState -> [Widget]
tsDraw AppState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}} tsDraw UIState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}}
,aScreen=TransactionScreen{ ,aScreen=TransactionScreen{
tsTransaction=(i,t) tsTransaction=(i,t)
,tsTransactions=nts ,tsTransactions=nts
@ -107,8 +108,8 @@ tsDraw AppState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=ropts}}
tsDraw _ = error "draw function called with wrong screen type, should not happen" tsDraw _ = error "draw function called with wrong screen type, should not happen"
tsHandle :: AppState -> Vty.Event -> EventM (Next AppState) tsHandle :: UIState -> Event -> EventM (Next UIState)
tsHandle st@AppState{aScreen=s@TransactionScreen{tsTransaction=(i,t) tsHandle ui@UIState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
,tsTransactions=nts ,tsTransactions=nts
,tsAccount=acct} ,tsAccount=acct}
,aopts=UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} ,aopts=UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
@ -119,8 +120,8 @@ tsHandle st@AppState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
case mode of case mode of
Help -> Help ->
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
_ -> helpHandle st ev _ -> helpHandle ui ev
_ -> do _ -> do
d <- liftIO getCurrentDay d <- liftIO getCurrentDay
@ -128,14 +129,14 @@ tsHandle st@AppState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
(iprev,tprev) = maybe (i,t) ((i-1),) $ lookup (i-1) nts (iprev,tprev) = maybe (i,t) ((i-1),) $ lookup (i-1) nts
(inext,tnext) = maybe (i,t) ((i+1),) $ lookup (i+1) nts (inext,tnext) = maybe (i,t) ((i+1),) $ lookup (i+1) nts
case ev of case ev of
EvKey (KChar 'q') [] -> halt st EvKey (KChar 'q') [] -> halt ui
EvKey KEsc [] -> continue $ resetScreens d st EvKey KEsc [] -> continue $ resetScreens d ui
EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help st EvKey k [] | k `elem` [KChar 'h', KChar '?'] -> continue $ setMode Help ui
EvKey (KChar 'g') [] -> do EvKey (KChar 'g') [] -> do
d <- liftIO getCurrentDay d <- liftIO getCurrentDay
(ej, _) <- liftIO $ journalReloadIfChanged copts d j (ej, _) <- liftIO $ journalReloadIfChanged copts d j
case ej of case ej of
Left err -> continue $ screenEnter d errorScreen{esError=err} st Left err -> continue $ screenEnter d errorScreen{esError=err} ui
Right j' -> do Right j' -> do
-- got to redo the register screen's transactions report, to get the latest transactions list for this screen -- got to redo the register screen's transactions report, to get the latest transactions list for this screen
-- XXX duplicates rsInit -- XXX duplicates rsInit
@ -155,21 +156,21 @@ tsHandle st@AppState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
Nothing | null numberedts -> (0,nulltransaction) Nothing | null numberedts -> (0,nulltransaction)
| i > fst (last numberedts) -> last numberedts | i > fst (last numberedts) -> last numberedts
| otherwise -> head numberedts | otherwise -> head numberedts
st' = st{aScreen=s{tsTransaction=(i',t') ui' = ui{aScreen=s{tsTransaction=(i',t')
,tsTransactions=numberedts ,tsTransactions=numberedts
,tsAccount=acct}} ,tsAccount=acct}}
continue $ regenerateScreens j' d st' continue $ regenerateScreens j' d ui'
-- if allowing toggling here, we should refresh the txn list from the parent register screen -- if allowing toggling here, we should refresh the txn list from the parent register screen
-- EvKey (KChar 'E') [] -> continue $ regenerateScreens j d $ stToggleEmpty st -- EvKey (KChar 'E') [] -> continue $ regenerateScreens j d $ stToggleEmpty ui
-- EvKey (KChar 'C') [] -> continue $ regenerateScreens j d $ stToggleCleared st -- EvKey (KChar 'C') [] -> continue $ regenerateScreens j d $ stToggleCleared ui
-- EvKey (KChar 'R') [] -> continue $ regenerateScreens j d $ stToggleReal st -- EvKey (KChar 'R') [] -> continue $ regenerateScreens j d $ stToggleReal ui
EvKey KUp [] -> continue $ regenerateScreens j d st{aScreen=s{tsTransaction=(iprev,tprev)}} EvKey KUp [] -> continue $ regenerateScreens j d ui{aScreen=s{tsTransaction=(iprev,tprev)}}
EvKey KDown [] -> continue $ regenerateScreens j d st{aScreen=s{tsTransaction=(inext,tnext)}} EvKey KDown [] -> continue $ regenerateScreens j d ui{aScreen=s{tsTransaction=(inext,tnext)}}
EvKey KLeft [] -> continue st'' EvKey KLeft [] -> continue ui''
where where
st'@AppState{aScreen=scr} = popScreen st ui'@UIState{aScreen=scr} = popScreen ui
st'' = st'{aScreen=rsSelect (fromIntegral i) scr} ui'' = ui'{aScreen=rsSelect (fromIntegral i) scr}
_ -> continue st _ -> continue ui
tsHandle _ _ = error "event handler called with wrong screen type, should not happen" tsHandle _ _ = error "event handler called with wrong screen type, should not happen"

172
hledger-ui/Hledger/UI/UIState.hs Normal file
View File

@ -0,0 +1,172 @@
{- | UIState operations. -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Hledger.UI.UIState
where
import Brick
import Brick.Widgets.Edit
import Data.List
import Data.Text.Zipper (gotoEOL)
import Data.Time.Calendar (Day)
import Hledger
import Hledger.Cli.CliOptions
import Hledger.UI.UITypes
import Hledger.UI.UIOptions
-- | Toggle between showing only cleared items or all items.
toggleCleared :: UIState -> UIState
toggleCleared ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=toggleCleared ropts}}}
where
toggleCleared ropts = ropts{cleared_=not $ cleared_ ropts, uncleared_=False, pending_=False}
-- | Toggle between showing only pending items or all items.
togglePending :: UIState -> UIState
togglePending ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=togglePending ropts}}}
where
togglePending ropts = ropts{pending_=not $ pending_ ropts, uncleared_=False, cleared_=False}
-- | Toggle between showing only uncleared items or all items.
toggleUncleared :: UIState -> UIState
toggleUncleared ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=toggleUncleared ropts}}}
where
toggleUncleared ropts = ropts{uncleared_=not $ uncleared_ ropts, cleared_=False, pending_=False}
-- | Toggle between showing all and showing only nonempty (more precisely, nonzero) items.
toggleEmpty :: UIState -> UIState
toggleEmpty ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=toggleEmpty ropts}}}
where
toggleEmpty ropts = ropts{empty_=not $ empty_ ropts}
-- | Toggle between flat and tree mode. If in the third "default" mode, go to flat mode.
toggleFlat :: UIState -> UIState
toggleFlat ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=toggleFlatMode ropts}}}
where
toggleFlatMode ropts@ReportOpts{accountlistmode_=ALFlat} = ropts{accountlistmode_=ALTree}
toggleFlatMode ropts = ropts{accountlistmode_=ALFlat}
-- | Toggle between showing all and showing only real (non-virtual) items.
toggleReal :: UIState -> UIState
toggleReal ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=toggleReal ropts}}}
where
toggleReal ropts = ropts{real_=not $ real_ ropts}
-- | Apply a new filter query.
setFilter :: String -> UIState -> UIState
setFilter s ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{query_=s}}}}
-- | Clear all filter queries/flags.
resetFilter :: UIState -> UIState
resetFilter ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{
empty_=True
,cleared_=False
,pending_=False
,uncleared_=False
,real_=False
,query_=""
}}}}
resetDepth :: UIState -> UIState
resetDepth ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=Nothing}}}}
-- | Get the maximum account depth in the current journal.
maxDepth :: UIState -> Int
maxDepth UIState{ajournal=j} = maximum $ map accountNameLevel $ journalAccountNames j
-- | Decrement the current depth limit towards 0. If there was no depth limit,
-- set it to one less than the maximum account depth.
decDepth :: UIState -> UIState
decDepth ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts@ReportOpts{..}}}}
= ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=dec depth_}}}}
where
dec (Just d) = Just $ max 0 (d-1)
dec Nothing = Just $ maxDepth ui - 1
-- | Increment the current depth limit. If this makes it equal to the
-- the maximum account depth, remove the depth limit.
incDepth :: UIState -> UIState
incDepth ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts@ReportOpts{..}}}}
= ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=inc depth_}}}}
where
inc (Just d) | d < (maxDepth ui - 1) = Just $ d+1
inc _ = Nothing
-- | Set the current depth limit to the specified depth, or remove the depth limit.
-- Also remove the depth limit if the specified depth is greater than the current
-- maximum account depth. If the specified depth is negative, reset the depth limit
-- to whatever was specified at uiartup.
setDepth :: Maybe Int -> UIState -> UIState
setDepth mdepth ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}}
= ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=mdepth'}}}}
where
mdepth' = case mdepth of
Nothing -> Nothing
Just d | d < 0 -> depth_ ropts
| d >= maxDepth ui -> Nothing
| otherwise -> mdepth
-- | Open the minibuffer, setting its content to the current query with the cursor at the end.
showMinibuffer :: UIState -> UIState
showMinibuffer ui = setMode (Minibuffer e) ui
where
e = applyEdit gotoEOL $ editor "minibuffer" (str . unlines) (Just 1) oldq
oldq = query_ $ reportopts_ $ cliopts_ $ aopts ui
-- | Close the minibuffer, discarding any edit in progress.
closeMinibuffer :: UIState -> UIState
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
first:rest = reverse $ s:ss :: [Screen]
ui0 = ui{ajournal=j, aScreen=first, aPrevScreens=[]} :: UIState
ui1 = (sInit first) 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
}
popScreen :: UIState -> UIState
popScreen ui@UIState{aPrevScreens=s:ss} = ui{aScreen=s, aPrevScreens=ss}
popScreen ui = ui
resetScreens :: Day -> UIState -> UIState
resetScreens d ui@UIState{aScreen=s,aPrevScreens=ss} =
(sInit topscreen) d True $ resetDepth $ resetFilter $ closeMinibuffer ui{aScreen=topscreen, aPrevScreens=[]}
where
topscreen = case ss of _:_ -> last ss
[] -> s
-- | 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

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

@ -1,16 +1,16 @@
{- | {- |
Overview: Overview:
hledger-ui's AppState holds the currently active screen and any previously visited hledger-ui's UIState holds the currently active screen and any previously visited
screens (and their states). screens (and their states).
The brick App delegates all event-handling and rendering The brick App delegates all event-handling and rendering
to the AppState's active screen. to the UIState's active screen.
Screens have their own screen state, render function, event handler, and app state Screens have their own screen state, render function, event handler, and app state
update function, so they have full control. update function, so they have full control.
@ @
Brick.defaultMain brickapp st Brick.defaultMain brickapp st
where where
brickapp :: App (AppState) V.Event brickapp :: App (UIState) V.Event
brickapp = App { brickapp = App {
appLiftVtyEvent = id appLiftVtyEvent = id
, appStartEvent = return , appStartEvent = return
@ -19,9 +19,9 @@ Brick.defaultMain brickapp st
, appHandleEvent = \st ev -> sHandle (aScreen st) st ev , appHandleEvent = \st ev -> sHandle (aScreen st) st ev
, appDraw = \st -> sDraw (aScreen st) st , appDraw = \st -> sDraw (aScreen st) st
} }
st :: AppState st :: UIState
st = (sInit s) d st = (sInit s) d
AppState{ UIState{
aopts=uopts' aopts=uopts'
,ajournal=j ,ajournal=j
,aScreen=s ,aScreen=s
@ -40,7 +40,7 @@ module Hledger.UI.UITypes where
import Data.Monoid import Data.Monoid
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import qualified Graphics.Vty as Vty import Graphics.Vty
import Brick import Brick
import Brick.Widgets.List import Brick.Widgets.List
import Brick.Widgets.Edit (Editor) import Brick.Widgets.Edit (Editor)
@ -59,12 +59,12 @@ instance Show Editor where show _ = "<Editor>"
-- As you navigate through screens, the old ones are saved in a stack. -- 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, -- The app can be in one of several modes: normal screen operation,
-- showing a help dialog, entering data in the minibuffer etc. -- showing a help dialog, entering data in the minibuffer etc.
data AppState = AppState { data UIState = UIState {
aopts :: UIOpts -- ^ the command-line options and query arguments currently in effect aopts :: UIOpts -- ^ the command-line options and query arguments currently in effect
,ajournal :: Journal -- ^ the journal being viewed ,ajournal :: Journal -- ^ the journal being viewed
,aPrevScreens :: [Screen] -- ^ previously visited screens, most recent first ,aPrevScreens :: [Screen] -- ^ previously visited screens, most recent first
,aScreen :: Screen -- ^ the currently active screen ,aScreen :: Screen -- ^ the currently active screen
,aMode :: Mode -- ^ the currently active mode ,aMode :: Mode -- ^ the currently active mode
} deriving (Show) } deriving (Show)
-- | The mode modifies the screen's rendering and event handling. -- | The mode modifies the screen's rendering and event handling.
@ -86,34 +86,34 @@ instance Eq Editor where _ == _ = True
-- cases need to be handled, and also that their lenses are traversals, not single-value getters. -- cases need to be handled, and also that their lenses are traversals, not single-value getters.
data Screen = data Screen =
AccountsScreen { AccountsScreen {
sInit :: Day -> Bool -> AppState -> AppState -- ^ function to initialise or update this screen's state sInit :: Day -> Bool -> UIState -> UIState -- ^ function to initialise or update this screen's state
,sDraw :: AppState -> [Widget] -- ^ brick renderer for this screen ,sDraw :: UIState -> [Widget] -- ^ brick renderer for this screen
,sHandle :: AppState -> Vty.Event -> EventM (Next AppState) -- ^ brick event handler for this screen ,sHandle :: UIState -> Event -> EventM (Next UIState) -- ^ brick event handler for this screen
-- state fields.These ones have lenses: -- state fields.These ones have lenses:
,_asList :: List AccountsScreenItem -- ^ list widget showing account names & balances ,_asList :: List AccountsScreenItem -- ^ list widget showing account names & balances
,_asSelectedAccount :: AccountName -- ^ a backup of the account name from the list widget's selected item (or "") ,_asSelectedAccount :: AccountName -- ^ a backup of the account name from the list widget's selected item (or "")
} }
| RegisterScreen { | RegisterScreen {
sInit :: Day -> Bool -> AppState -> AppState sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: AppState -> [Widget] ,sDraw :: UIState -> [Widget]
,sHandle :: AppState -> Vty.Event -> EventM (Next AppState) ,sHandle :: UIState -> Event -> EventM (Next UIState)
-- --
,rsList :: List RegisterScreenItem -- ^ list widget showing transactions affecting this account ,rsList :: List RegisterScreenItem -- ^ list widget showing transactions affecting this account
,rsAccount :: AccountName -- ^ the account this register is for ,rsAccount :: AccountName -- ^ the account this register is for
} }
| TransactionScreen { | TransactionScreen {
sInit :: Day -> Bool -> AppState -> AppState sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: AppState -> [Widget] ,sDraw :: UIState -> [Widget]
,sHandle :: AppState -> Vty.Event -> EventM (Next AppState) ,sHandle :: UIState -> Event -> EventM (Next UIState)
-- --
,tsTransaction :: NumberedTransaction -- ^ the transaction we are currently viewing, and its position in the list ,tsTransaction :: NumberedTransaction -- ^ the transaction we are currently viewing, and its position in the list
,tsTransactions :: [NumberedTransaction] -- ^ list of transactions we can step through ,tsTransactions :: [NumberedTransaction] -- ^ list of transactions we can step through
,tsAccount :: AccountName -- ^ the account whose register we entered this screen from ,tsAccount :: AccountName -- ^ the account whose register we entered this screen from
} }
| ErrorScreen { | ErrorScreen {
sInit :: Day -> Bool -> AppState -> AppState sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: AppState -> [Widget] ,sDraw :: UIState -> [Widget]
,sHandle :: AppState -> Vty.Event -> EventM (Next AppState) ,sHandle :: UIState -> Event -> EventM (Next UIState)
-- --
,esError :: String -- ^ error message to show ,esError :: String -- ^ error message to show
} }
@ -139,7 +139,7 @@ data RegisterScreenItem = RegisterScreenItem {
type NumberedTransaction = (Integer, Transaction) type NumberedTransaction = (Integer, Transaction)
-- dummy monoid instance needed for lenses for now since the List fields are not common across constructors -- dummy monoid instance needed make lenses work with List fields not common across constructors
instance Monoid (List a) instance Monoid (List a)
where where
mempty = list "" V.empty 1 mempty = list "" V.empty 1

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

@ -1,212 +1,26 @@
{- | Rendering & misc. helpers. -}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Hledger.UI.UIUtils module Hledger.UI.UIUtils
-- ( where
-- pushScreen
-- ,popScreen
-- ,resetScreens
-- ,screenEnter
-- ,regenerateScreens
-- ,getViewportSize
-- -- ,margin
-- ,withBorderAttr
-- ,topBottomBorderWithLabel
-- ,topBottomBorderWithLabels
-- ,defaultLayout
-- ,borderQueryStr
-- ,borderDepthStr
-- ,borderKeysStr
-- ,minibuffer
-- --
-- ,stToggleCleared
-- ,stTogglePending
-- ,stToggleUncleared
-- ,stToggleEmpty
-- ,stToggleFlat
-- ,stToggleReal
-- ,stFilter
-- ,stResetFilter
-- ,stShowMinibuffer
-- ,stCloseMinibuffer
-- )
where
import Lens.Micro.Platform ((^.))
-- import Control.Monad
-- import Control.Monad.IO.Class
-- import Data.Default
import Data.List
import Data.Monoid
import Data.Text.Zipper (gotoEOL)
import Data.Time.Calendar (Day)
import Brick import Brick
import Brick.Widgets.Dialog
-- import Brick.Widgets.List
import Brick.Widgets.Edit
import Brick.Widgets.Border import Brick.Widgets.Border
import Brick.Widgets.Border.Style import Brick.Widgets.Border.Style
import Graphics.Vty as Vty import Brick.Widgets.Dialog
import Brick.Widgets.Edit
import Data.List
import Data.Monoid
import Graphics.Vty
import Lens.Micro.Platform
import Hledger import Hledger
import Hledger.Cli.CliOptions
import Hledger.UI.UITypes import Hledger.UI.UITypes
import Hledger.UI.UIOptions import Hledger.UI.UIState
-- | Toggle between showing only cleared items or all items.
stToggleCleared :: AppState -> AppState
stToggleCleared st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=toggleCleared ropts}}}
where
toggleCleared ropts = ropts{cleared_=not $ cleared_ ropts, uncleared_=False, pending_=False}
-- | Toggle between showing only pending items or all items.
stTogglePending :: AppState -> AppState
stTogglePending st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=togglePending ropts}}}
where
togglePending ropts = ropts{pending_=not $ pending_ ropts, uncleared_=False, cleared_=False}
-- | Toggle between showing only uncleared items or all items.
stToggleUncleared :: AppState -> AppState
stToggleUncleared st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=toggleUncleared ropts}}}
where
toggleUncleared ropts = ropts{uncleared_=not $ uncleared_ ropts, cleared_=False, pending_=False}
-- | Toggle between showing all and showing only nonempty (more precisely, nonzero) items.
stToggleEmpty :: AppState -> AppState
stToggleEmpty st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=toggleEmpty ropts}}}
where
toggleEmpty ropts = ropts{empty_=not $ empty_ ropts}
-- | Toggle between flat and tree mode. If in the third "default" mode, go to flat mode.
stToggleFlat :: AppState -> AppState
stToggleFlat st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=toggleFlatMode ropts}}}
where
toggleFlatMode ropts@ReportOpts{accountlistmode_=ALFlat} = ropts{accountlistmode_=ALTree}
toggleFlatMode ropts = ropts{accountlistmode_=ALFlat}
-- | Toggle between showing all and showing only real (non-virtual) items.
stToggleReal :: AppState -> AppState
stToggleReal st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=toggleReal ropts}}}
where
toggleReal ropts = ropts{real_=not $ real_ ropts}
-- | Apply a new filter query.
stFilter :: String -> AppState -> AppState
stFilter s st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=ropts{query_=s}}}}
-- | Clear all filter queries/flags.
stResetFilter :: AppState -> AppState
stResetFilter st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=ropts{
empty_=True
,cleared_=False
,pending_=False
,uncleared_=False
,real_=False
,query_=""
}}}}
resetDepth :: AppState -> AppState
resetDepth st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
st{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=Nothing}}}}
-- | Get the maximum account depth in the current journal.
maxDepth :: AppState -> Int
maxDepth AppState{ajournal=j} = maximum $ map accountNameLevel $ journalAccountNames j
-- | Decrement the current depth limit towards 0. If there was no depth limit,
-- set it to one less than the maximum account depth.
decDepth :: AppState -> AppState
decDepth st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts@ReportOpts{..}}}}
= st{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=dec depth_}}}}
where
dec (Just d) = Just $ max 0 (d-1)
dec Nothing = Just $ maxDepth st - 1
-- | Increment the current depth limit. If this makes it equal to the
-- the maximum account depth, remove the depth limit.
incDepth :: AppState -> AppState
incDepth st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts@ReportOpts{..}}}}
= st{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=inc depth_}}}}
where
inc (Just d) | d < (maxDepth st - 1) = Just $ d+1
inc _ = Nothing
-- | Set the current depth limit to the specified depth, or remove the depth limit.
-- Also remove the depth limit if the specified depth is greater than the current
-- maximum account depth. If the specified depth is negative, reset the depth limit
-- to whatever was specified at startup.
setDepth :: Maybe Int -> AppState -> AppState
setDepth mdepth st@AppState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}}
= st{aopts=uopts{cliopts_=copts{reportopts_=ropts{depth_=mdepth'}}}}
where
mdepth' = case mdepth of
Nothing -> Nothing
Just d | d < 0 -> depth_ ropts
| d >= maxDepth st -> Nothing
| otherwise -> mdepth
-- | Open the minibuffer, setting its content to the current query with the cursor at the end.
stShowMinibuffer st = setMode (Minibuffer e) st
where
e = applyEdit gotoEOL $ editor "minibuffer" (str . unlines) (Just 1) oldq
oldq = query_ $ reportopts_ $ cliopts_ $ aopts st
-- | Close the minibuffer, discarding any edit in progress.
stCloseMinibuffer = setMode Normal
setMode :: Mode -> AppState -> AppState
setMode m st = st{aMode=m}
-- | Regenerate the content for the current and previous screens, from a new journal and current date.
regenerateScreens :: Journal -> Day -> AppState -> AppState
regenerateScreens j d st@AppState{aScreen=s,aPrevScreens=ss} =
-- XXX clumsy due to entanglement of AppState 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
first:rest = reverse $ s:ss :: [Screen]
st0 = st{ajournal=j, aScreen=first, aPrevScreens=[]} :: AppState
st1 = (sInit first) d False st0 :: AppState
st2 = foldl' (\st s -> (sInit s) d False $ pushScreen s st) st1 rest :: AppState
in
st2
pushScreen :: Screen -> AppState -> AppState
pushScreen scr st = st{aPrevScreens=(aScreen st:aPrevScreens st)
,aScreen=scr
}
popScreen :: AppState -> AppState
popScreen st@AppState{aPrevScreens=s:ss} = st{aScreen=s, aPrevScreens=ss}
popScreen st = st
resetScreens :: Day -> AppState -> AppState
resetScreens d st@AppState{aScreen=s,aPrevScreens=ss} =
(sInit topscreen) d True $ resetDepth $ stResetFilter $ stCloseMinibuffer st{aScreen=topscreen, aPrevScreens=[]}
where
topscreen = case ss of _:_ -> last ss
[] -> s
-- clearScreens :: AppState -> AppState
-- clearScreens st = st{aPrevScreens=[]}
-- | Enter a new screen, saving the old screen & state in the
-- navigation history and initialising the new screen's state.
screenEnter :: Day -> Screen -> AppState -> AppState
screenEnter d scr st = (sInit scr) d True $
pushScreen scr
st
-- | Draw the help dialog, called when help mode is active. -- | Draw the help dialog, called when help mode is active.
helpDialog :: Widget
helpDialog = helpDialog =
Widget Fixed Fixed $ do Widget Fixed Fixed $ do
c <- getContext c <- getContext
@ -251,22 +65,21 @@ helpDialog =
renderKey (key,desc) = withAttr (borderAttr <> "keys") (str key) <+> str " " <+> str desc renderKey (key,desc) = withAttr (borderAttr <> "keys") (str key) <+> str " " <+> str desc
-- | Event handler used when help mode is active. -- | Event handler used when help mode is active.
helpHandle st ev = helpHandle :: UIState -> Event -> EventM (Next UIState)
helpHandle ui ev =
case ev of case ev of
EvKey k [] | k `elem` [KEsc, KChar 'h'] -> continue $ setMode Normal st EvKey k [] | k `elem` [KEsc, KChar 'h'] -> continue $ setMode Normal ui
_ -> continue st _ -> continue ui
-- | In the EventM monad, get the named current viewport's width and height, -- | Draw the minibuffer.
-- or (0,0) if the named viewport is not found. minibuffer :: Editor -> Widget
getViewportSize :: Name -> EventM (Int,Int) minibuffer ed =
getViewportSize name = do forceAttr (borderAttr <> "minibuffer") $
mvp <- lookupViewport name hBox $
let (w,h) = case mvp of [txt "filter: ", renderEditor ed]
Just vp -> vp ^. vpSize
Nothing -> (0,0)
-- liftIO $ putStrLn $ show (w,h)
return (w,h)
-- | Wrap a widget in the default hledger-ui screen layout.
defaultLayout :: Widget -> Widget -> Widget -> Widget
defaultLayout toplabel bottomlabel = defaultLayout toplabel bottomlabel =
topBottomBorderWithLabels (str " "<+>toplabel<+>str " ") (str " "<+>bottomlabel<+>str " ") . topBottomBorderWithLabels (str " "<+>toplabel<+>str " ") (str " "<+>bottomlabel<+>str " ") .
margin 1 0 Nothing margin 1 0 Nothing
@ -274,6 +87,26 @@ defaultLayout toplabel bottomlabel =
-- padLeftRight 1 -- XXX should reduce inner widget's width by 2, but doesn't -- padLeftRight 1 -- XXX should reduce inner widget's width by 2, but doesn't
-- "the layout adjusts... if you use the core combinators" -- "the layout adjusts... if you use the core combinators"
borderQueryStr :: String -> Widget
borderQueryStr "" = str ""
borderQueryStr qry = str " matching " <+> withAttr (borderAttr <> "query") (str qry)
borderDepthStr :: Maybe Int -> Widget
borderDepthStr Nothing = str ""
borderDepthStr (Just d) = str " to " <+> withAttr (borderAttr <> "depth") (str $ "depth "++show d)
borderKeysStr :: [(String,String)] -> Widget
borderKeysStr keydescs =
hBox $
intersperse sep $
[withAttr (borderAttr <> "keys") (str keys) <+> str ":" <+> str desc | (keys, desc) <- keydescs]
where
-- sep = str " | "
sep = str " "
-- generic
topBottomBorderWithLabel :: Widget -> Widget -> Widget
topBottomBorderWithLabel label = \wrapped -> topBottomBorderWithLabel label = \wrapped ->
Widget Greedy Greedy $ do Widget Greedy Greedy $ do
c <- getContext c <- getContext
@ -290,6 +123,7 @@ topBottomBorderWithLabel label = \wrapped ->
<=> <=>
hBorder hBorder
topBottomBorderWithLabels :: Widget -> Widget -> Widget -> Widget
topBottomBorderWithLabels toplabel bottomlabel = \wrapped -> topBottomBorderWithLabels toplabel bottomlabel = \wrapped ->
Widget Greedy Greedy $ do Widget Greedy Greedy $ do
c <- getContext c <- getContext
@ -307,6 +141,7 @@ topBottomBorderWithLabels toplabel bottomlabel = \wrapped ->
hBorderWithLabel bottomlabel hBorderWithLabel bottomlabel
-- XXX should be equivalent to the above, but isn't (page down goes offscreen) -- XXX should be equivalent to the above, but isn't (page down goes offscreen)
_topBottomBorderWithLabel2 :: Widget -> Widget -> Widget
_topBottomBorderWithLabel2 label = \wrapped -> _topBottomBorderWithLabel2 label = \wrapped ->
let debugmsg = "" let debugmsg = ""
in hBorderWithLabel (label <+> str debugmsg) in hBorderWithLabel (label <+> str debugmsg)
@ -340,33 +175,6 @@ margin h v mcolour = \w ->
-- withBorderStyle (borderStyleFromChar ' ') . -- withBorderStyle (borderStyleFromChar ' ') .
-- applyN n border -- applyN n border
withBorderAttr :: Attr -> Widget -> Widget
withBorderAttr attr = updateAttrMap (applyAttrMappings [(borderAttr, attr)]) withBorderAttr attr = updateAttrMap (applyAttrMappings [(borderAttr, attr)])
-- _ui = vCenter $ vBox [ hCenter box
-- , str " "
-- , hCenter $ str "Press Esc to exit."
-- ]
borderQueryStr :: String -> Widget
borderQueryStr "" = str ""
borderQueryStr qry = str " matching " <+> withAttr (borderAttr <> "query") (str qry)
borderDepthStr :: Maybe Int -> Widget
borderDepthStr Nothing = str ""
borderDepthStr (Just d) = str " to " <+> withAttr (borderAttr <> "depth") (str $ "depth "++show d)
borderKeysStr :: [(String,String)] -> Widget
borderKeysStr keydescs =
hBox $
intersperse sep $
[withAttr (borderAttr <> "keys") (str keys) <+> str ":" <+> str desc | (keys, desc) <- keydescs]
where
-- sep = str " | "
sep = str " "
minibuffer :: Editor -> Widget
minibuffer ed =
forceAttr (borderAttr <> "minibuffer") $
hBox $
[txt "filter: ", renderEditor ed]

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

@ -92,6 +92,7 @@ executable hledger-ui
Hledger.UI.Main Hledger.UI.Main
Hledger.UI.UIOptions Hledger.UI.UIOptions
Hledger.UI.Theme Hledger.UI.Theme
Hledger.UI.UIState
Hledger.UI.UITypes Hledger.UI.UITypes
Hledger.UI.UIUtils Hledger.UI.UIUtils
Hledger.UI.AccountsScreen Hledger.UI.AccountsScreen