simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-09-19 02:08:01 +03:00
Code Issues Projects Releases Wiki Activity

pkg: ui: use/require brick 1.0+ (#1889)

Browse Source
This commit is contained in:
Simon Michael 2022-08-17 11:04:50 +01:00
parent b636eb78a9
commit 2a594b7fb7
11 changed files with 262 additions and 274 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -152,7 +152,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
ishistorical = balanceaccum_ ropts == Historical ishistorical = balanceaccum_ ropts == Historical
toplabel = toplabel =
withAttr ("border" <> "filename") files withAttr (attrName "border" <> attrName "filename") files
<+> toggles <+> toggles
<+> str (" account " ++ if ishistorical then "balances" else "changes") <+> str (" account " ++ if ishistorical then "balances" else "changes")
<+> borderPeriodStr (if ishistorical then "at end of" else "in") (period_ ropts) <+> borderPeriodStr (if ishistorical then "at end of" else "in") (period_ ropts)
@ -160,7 +160,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
<+> borderDepthStr mdepth <+> borderDepthStr mdepth
<+> str (" ("++curidx++"/"++totidx++")") <+> str (" ("++curidx++"/"++totidx++")")
<+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts <+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts
then withAttr ("border" <> "query") (str " ignoring balance assertions") then withAttr (attrName "border" <> attrName "query") (str " ignoring balance assertions")
else str "") else str "")
where where
files = case journalFilePaths j of files = case journalFilePaths j of
@ -168,7 +168,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
f:_ -> str $ takeFileName f f:_ -> str $ takeFileName f
-- [f,_:[]] -> (withAttr ("border" <> "bold") $ str $ takeFileName f) <+> str " (& 1 included file)" -- [f,_:[]] -> (withAttr ("border" <> "bold") $ str $ takeFileName f) <+> str " (& 1 included file)"
-- f:fs -> (withAttr ("border" <> "bold") $ str $ takeFileName f) <+> str (" (& " ++ show (length fs) ++ " included files)") -- f:fs -> (withAttr ("border" <> "bold") $ str $ takeFileName f) <+> str (" (& " ++ show (length fs) ++ " included files)")
toggles = withAttr ("border" <> "query") $ str $ unwords $ concat [ toggles = withAttr (attrName "border" <> attrName "query") $ str $ unwords $ concat [
[""] [""]
,if empty_ ropts then [] else ["nonzero"] ,if empty_ ropts then [] else ["nonzero"]
,uiShowStatus copts $ statuses_ ropts ,uiShowStatus copts $ statuses_ ropts
@ -220,22 +220,24 @@ asDrawItem (acctwidth, balwidth) selected AccountsScreenItem{..} =
balspace = T.replicate (2 + balwidth - wbWidth balBuilder) " " balspace = T.replicate (2 + balwidth - wbWidth balBuilder) " "
splitAmounts = foldr1 (<+>) . intersperse (str ", ") . map renderamt . T.splitOn ", " . wbToText splitAmounts = foldr1 (<+>) . intersperse (str ", ") . map renderamt . T.splitOn ", " . wbToText
renderamt :: T.Text -> Widget Name renderamt :: T.Text -> Widget Name
renderamt a | T.any (=='-') a = withAttr (sel $ "list" <> "balance" <> "negative") $ txt a renderamt a | T.any (=='-') a = withAttr (sel $ attrName "list" <> attrName "balance" <> attrName "negative") $ txt a
| otherwise = withAttr (sel $ "list" <> "balance" <> "positive") $ txt a | otherwise = withAttr (sel $ attrName "list" <> attrName "balance" <> attrName "positive") $ txt a
sel | selected = (<> "selected") sel | selected = (<> attrName "selected")
| otherwise = id | otherwise = id
asHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) asHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
asHandle ui0@UIState{ asHandle ev = do
ui0@UIState{
aScreen=scr@AccountsScreen{..} aScreen=scr@AccountsScreen{..}
,aopts=UIOpts{uoCliOpts=copts} ,aopts=UIOpts{uoCliOpts=copts}
,ajournal=j ,ajournal=j
,aMode=mode ,aMode=mode
} ev = do } <- get -- PARTIAL: should not fail
let let
d = copts^.rsDay d = copts^.rsDay
nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ _asList^.listElementsL nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ _asList^.listElementsL
lastnonblankidx = max 0 (length nonblanks - 1) lastnonblankidx = max 0 (length nonblanks - 1)
journalspan = journalDateSpan False j
-- save the currently selected account, in case we leave this screen and lose the selection -- save the currently selected account, in case we leave this screen and lose the selection
let let
@ -247,87 +249,81 @@ asHandle ui0@UIState{
case mode of case mode of
Minibuffer _ ed -> Minibuffer _ ed ->
case ev of case ev of
VtyEvent (EvKey KEsc []) -> continue $ closeMinibuffer ui VtyEvent (EvKey KEsc []) -> put $ closeMinibuffer ui
VtyEvent (EvKey KEnter []) -> continue $ regenerateScreens j d $ VtyEvent (EvKey KEnter []) -> put $ regenerateScreens j d $
case setFilter s $ closeMinibuffer ui of case setFilter s $ closeMinibuffer ui of
Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui
Right ui' -> ui' Right ui' -> ui'
where s = chomp $ unlines $ map strip $ getEditContents ed where s = chomp $ unlines $ map strip $ getEditContents ed
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
VtyEvent ev -> do VtyEvent ev -> do
ed' <- handleEditorEvent ed' <- nestEventM' ed $ handleEditorEvent (VtyEvent ev)
#if MIN_VERSION_brick(0,72,0) put ui{aMode=Minibuffer "filter" ed'}
(VtyEvent ev) AppEvent _ -> return ()
#else MouseDown{} -> return ()
ev MouseUp{} -> return ()
#endif
ed
continue $ ui{aMode=Minibuffer "filter" ed'}
AppEvent _ -> continue ui
MouseDown{} -> continue ui
MouseUp{} -> continue ui
Help -> Help ->
case ev of case ev of
-- VtyEvent (EvKey (KChar 'q') []) -> halt ui -- VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> helpHandle ui ev _ -> helpHandle ev
Normal -> Normal ->
case ev of case ev of
VtyEvent (EvKey (KChar 'q') []) -> halt ui VtyEvent (EvKey (KChar 'q') []) -> halt
-- EvKey (KChar 'l') [MCtrl] -> do -- EvKey (KChar 'l') [MCtrl] -> do
VtyEvent (EvKey KEsc []) -> continue $ resetScreens d ui VtyEvent (EvKey KEsc []) -> put $ resetScreens d ui
VtyEvent (EvKey (KChar c) []) | c == '?' -> continue $ setMode Help ui VtyEvent (EvKey (KChar c) []) | c == '?' -> put $ setMode Help ui
-- XXX AppEvents currently handled only in Normal mode -- XXX AppEvents currently handled only in Normal mode
-- XXX be sure we don't leave unconsumed events piling up -- XXX be sure we don't leave unconsumed events piling up
AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old -> AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old ->
continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui put $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
where where
p = reportPeriod ui p = reportPeriod ui
e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] ->
liftIO (uiReloadJournal copts d ui) >>= continue liftIO (uiReloadJournal copts d ui) >>= put
VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) VtyEvent (EvKey (KChar 'I') []) -> put $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui)
VtyEvent (EvKey (KChar 'a') []) -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui VtyEvent (EvKey (KChar 'a') []) -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui
VtyEvent (EvKey (KChar 'A') []) -> suspendAndResume $ void (runIadd (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui VtyEvent (EvKey (KChar 'A') []) -> suspendAndResume $ void (runIadd (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui
VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor endPosition (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor endPosition (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui
VtyEvent (EvKey (KChar 'B') []) -> continue $ regenerateScreens j d $ toggleConversionOp ui VtyEvent (EvKey (KChar 'B') []) -> put $ regenerateScreens j d $ toggleConversionOp ui
VtyEvent (EvKey (KChar 'V') []) -> continue $ regenerateScreens j d $ toggleValue ui VtyEvent (EvKey (KChar 'V') []) -> put $ regenerateScreens j d $ toggleValue ui
VtyEvent (EvKey (KChar '0') []) -> continue $ regenerateScreens j d $ setDepth (Just 0) ui VtyEvent (EvKey (KChar '0') []) -> put $ regenerateScreens j d $ setDepth (Just 0) ui
VtyEvent (EvKey (KChar '1') []) -> continue $ regenerateScreens j d $ setDepth (Just 1) ui VtyEvent (EvKey (KChar '1') []) -> put $ regenerateScreens j d $ setDepth (Just 1) ui
VtyEvent (EvKey (KChar '2') []) -> continue $ regenerateScreens j d $ setDepth (Just 2) ui VtyEvent (EvKey (KChar '2') []) -> put $ regenerateScreens j d $ setDepth (Just 2) ui
VtyEvent (EvKey (KChar '3') []) -> continue $ regenerateScreens j d $ setDepth (Just 3) ui VtyEvent (EvKey (KChar '3') []) -> put $ regenerateScreens j d $ setDepth (Just 3) ui
VtyEvent (EvKey (KChar '4') []) -> continue $ regenerateScreens j d $ setDepth (Just 4) ui VtyEvent (EvKey (KChar '4') []) -> put $ regenerateScreens j d $ setDepth (Just 4) ui
VtyEvent (EvKey (KChar '5') []) -> continue $ regenerateScreens j d $ setDepth (Just 5) ui VtyEvent (EvKey (KChar '5') []) -> put $ regenerateScreens j d $ setDepth (Just 5) ui
VtyEvent (EvKey (KChar '6') []) -> continue $ regenerateScreens j d $ setDepth (Just 6) ui VtyEvent (EvKey (KChar '6') []) -> put $ regenerateScreens j d $ setDepth (Just 6) ui
VtyEvent (EvKey (KChar '7') []) -> continue $ regenerateScreens j d $ setDepth (Just 7) ui VtyEvent (EvKey (KChar '7') []) -> put $ regenerateScreens j d $ setDepth (Just 7) ui
VtyEvent (EvKey (KChar '8') []) -> continue $ regenerateScreens j d $ setDepth (Just 8) ui VtyEvent (EvKey (KChar '8') []) -> put $ regenerateScreens j d $ setDepth (Just 8) ui
VtyEvent (EvKey (KChar '9') []) -> continue $ regenerateScreens j d $ setDepth (Just 9) ui VtyEvent (EvKey (KChar '9') []) -> put $ regenerateScreens j d $ setDepth (Just 9) ui
VtyEvent (EvKey (KChar '-') []) -> continue $ regenerateScreens j d $ decDepth ui VtyEvent (EvKey (KChar '-') []) -> put $ regenerateScreens j d $ decDepth ui
VtyEvent (EvKey (KChar '_') []) -> continue $ regenerateScreens j d $ decDepth ui VtyEvent (EvKey (KChar '_') []) -> put $ regenerateScreens j d $ decDepth ui
VtyEvent (EvKey (KChar c) []) | c `elem` ['+','='] -> continue $ regenerateScreens j d $ incDepth ui VtyEvent (EvKey (KChar c) []) | c `elem` ['+','='] -> put $ regenerateScreens j d $ incDepth ui
VtyEvent (EvKey (KChar 'T') []) -> continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui VtyEvent (EvKey (KChar 'T') []) -> put $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
-- display mode/query toggles -- display mode/query toggles
VtyEvent (EvKey (KChar 'H') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleHistorical ui VtyEvent (EvKey (KChar 'H') []) -> modify (regenerateScreens j d . toggleHistorical) >> asCenterAndContinue
VtyEvent (EvKey (KChar 't') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleTree ui VtyEvent (EvKey (KChar 't') []) -> modify (regenerateScreens j d . toggleTree) >> asCenterAndContinue
VtyEvent (EvKey (KChar c) []) | c `elem` ['z','Z'] -> asCenterAndContinue $ regenerateScreens j d $ toggleEmpty ui VtyEvent (EvKey (KChar c) []) | c `elem` ['z','Z'] -> modify (regenerateScreens j d . toggleEmpty) >> asCenterAndContinue
VtyEvent (EvKey (KChar 'R') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleReal ui VtyEvent (EvKey (KChar 'R') []) -> modify (regenerateScreens j d . toggleReal) >> asCenterAndContinue
VtyEvent (EvKey (KChar 'U') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleUnmarked ui VtyEvent (EvKey (KChar 'U') []) -> modify (regenerateScreens j d . toggleUnmarked) >> asCenterAndContinue
VtyEvent (EvKey (KChar 'P') []) -> asCenterAndContinue $ regenerateScreens j d $ togglePending ui VtyEvent (EvKey (KChar 'P') []) -> modify (regenerateScreens j d . togglePending) >> asCenterAndContinue
VtyEvent (EvKey (KChar 'C') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleCleared ui VtyEvent (EvKey (KChar 'C') []) -> modify (regenerateScreens j d . toggleCleared) >> asCenterAndContinue
VtyEvent (EvKey (KChar 'F') []) -> continue $ regenerateScreens j d $ toggleForecast d ui VtyEvent (EvKey (KChar 'F') []) -> modify (regenerateScreens j d . toggleForecast d)
VtyEvent (EvKey (KDown) [MShift]) -> continue $ regenerateScreens j d $ shrinkReportPeriod d ui VtyEvent (EvKey (KDown) [MShift]) -> put $ regenerateScreens j d $ shrinkReportPeriod d ui
VtyEvent (EvKey (KUp) [MShift]) -> continue $ regenerateScreens j d $ growReportPeriod d ui VtyEvent (EvKey (KUp) [MShift]) -> put $ regenerateScreens j d $ growReportPeriod d ui
VtyEvent (EvKey (KRight) [MShift]) -> continue $ regenerateScreens j d $ nextReportPeriod journalspan ui VtyEvent (EvKey (KRight) [MShift]) -> put $ regenerateScreens j d $ nextReportPeriod journalspan ui
VtyEvent (EvKey (KLeft) [MShift]) -> continue $ regenerateScreens j d $ previousReportPeriod journalspan ui VtyEvent (EvKey (KLeft) [MShift]) -> put $ regenerateScreens j d $ previousReportPeriod journalspan ui
VtyEvent (EvKey (KChar '/') []) -> continue $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui VtyEvent (EvKey (KChar '/') []) -> put $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui
VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ resetFilter ui) VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (put $ regenerateScreens j d $ resetFilter ui)
VtyEvent e | e `elem` moveLeftEvents -> continue $ popScreen ui VtyEvent e | e `elem` moveLeftEvents -> put $ popScreen ui
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
-- enter register screen for selected account (if there is one), -- enter register screen for selected account (if there is one),
@ -338,7 +334,7 @@ asHandle ui0@UIState{
-- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347 -- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347
-- just use it to move the selection -- just use it to move the selection
MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickedacct -> do MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickedacct -> do
continue ui{aScreen=scr{_asList=listMoveTo y _asList}} case scr of AccountsScreen{} -> put ui{aScreen=scr}; _ -> fail "" -- PARTIAL: should not happen
where clickedacct = maybe "" asItemAccountName $ listElements _asList !? y where clickedacct = maybe "" asItemAccountName $ listElements _asList !? y
-- and on MouseUp, enter the subscreen -- and on MouseUp, enter the subscreen
MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickedacct -> do MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickedacct -> do
@ -347,42 +343,35 @@ asHandle ui0@UIState{
-- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled -- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled
VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ _asList^.listNameL) 1 >> continue ui vScrollBy (viewportScroll $ _asList^.listNameL) 1 >> put ui
where mnextelement = listSelectedElement $ listMoveDown _asList where mnextelement = listSelectedElement $ listMoveDown _asList
-- mouse scroll wheel scrolls the viewport up or down to its maximum extent, -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
-- pushing the selection when necessary. -- pushing the selection when necessary.
MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do
let scrollamt = if btn==BScrollUp then -1 else 1 let scrollamt = if btn==BScrollUp then -1 else 1
list' <- listScrollPushingSelection name _asList (asListSize _asList) scrollamt list' <- nestEventM' _asList $ listScrollPushingSelection name (asListSize _asList) scrollamt
continue ui{aScreen=scr{_asList=list'}} case scr of AccountsScreen{} -> put ui{aScreen=scr{_asList=list'}}; _ -> fail "" -- PARTIAL: should not fail
-- if page down or end leads to a blank padding item, stop at last non-blank -- if page down or end leads to a blank padding item, stop at last non-blank
VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do
list <- handleListEvent e _asList list <- nestEventM' _asList $ handleListEvent e
if isBlankElement $ listSelectedElement list if isBlankElement $ listSelectedElement list
then do then do
let list' = listMoveTo lastnonblankidx list let list' = listMoveTo lastnonblankidx list
scrollSelectionToMiddle list' scrollSelectionToMiddle list'
continue ui{aScreen=scr{_asList=list'}} case scr of AccountsScreen{} -> put ui{aScreen=scr{_asList=list'}}; _ -> fail "" -- PARTIAL: should not fail
else else
continue ui{aScreen=scr{_asList=list}} case scr of AccountsScreen{} -> put ui{aScreen=scr{_asList=list}}; _ -> fail "" -- PARTIAL: should not fail
-- fall through to the list's event handler (handles up/down) -- fall through to the list's event handler (handles up/down)
VtyEvent ev -> do VtyEvent ev -> do
newitems <- handleListEvent (normaliseMovementKeys ev) _asList list' <- nestEventM' _asList $ handleListEvent (normaliseMovementKeys ev)
continue $ ui{aScreen=scr & asList .~ newitems put $ ui{aScreen=scr & asList .~ list' & asSelectedAccount .~ selacct }
& asSelectedAccount .~ selacct
}
MouseDown{} -> continue ui MouseDown{} -> put ui
MouseUp{} -> continue ui MouseUp{} -> put ui
AppEvent _ -> continue ui AppEvent _ -> put ui
where
journalspan = journalDateSpan False j
asHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
asEnterRegister d selacct ui = do asEnterRegister d selacct ui = do
rsCenterAndContinue $ rsCenterAndContinue $
@ -399,8 +388,9 @@ asSetSelectedAccount _ s = s
isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just "" isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just ""
asCenterAndContinue ui = do asCenterAndContinue :: EventM Name UIState ()
scrollSelectionToMiddle $ _asList $ aScreen ui asCenterAndContinue = do
continue ui ui <- get
scrollSelectionToMiddle (_asList $ aScreen ui)
asListSize = V.length . V.takeWhile ((/="").asItemAccountName) . listElements asListSize = V.length . V.takeWhile ((/="").asItemAccountName) . listElements

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

@ -54,10 +54,10 @@ esDraw UIState{aopts=UIOpts{uoCliOpts=copts}
_ -> [maincontent] _ -> [maincontent]
where where
maincontent = Widget Greedy Greedy $ do maincontent = Widget Greedy Greedy $ do
render $ defaultLayout toplabel bottomlabel $ withAttr "error" $ str $ esError render $ defaultLayout toplabel bottomlabel $ withAttr (attrName "error") $ str $ esError
where where
toplabel = toplabel =
withAttr ("border" <> "bold") (str "Oops. Please fix this problem then press g to reload") withAttr (attrName "border" <> attrName "bold") (str "Oops. Please fix this problem then press g to reload")
-- <+> (if ignore_assertions_ copts then withAttr ("border" <> "query") (str " ignoring") else str " not ignoring") -- <+> (if ignore_assertions_ copts then withAttr ("border" <> "query") (str " ignoring") else str " not ignoring")
bottomlabel = quickhelp bottomlabel = quickhelp
@ -75,44 +75,42 @@ esDraw UIState{aopts=UIOpts{uoCliOpts=copts}
esDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL: esDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL:
esHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) esHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
esHandle ui@UIState{aScreen=ErrorScreen{..} esHandle ev = do
ui@UIState{aScreen=ErrorScreen{..}
,aopts=UIOpts{uoCliOpts=copts} ,aopts=UIOpts{uoCliOpts=copts}
,ajournal=j ,ajournal=j
,aMode=mode ,aMode=mode
} } <- get
ev =
case mode of case mode of
Help -> Help ->
case ev of case ev of
VtyEvent (EvKey (KChar 'q') []) -> halt ui VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> helpHandle ui ev _ -> helpHandle ev
_ -> do _ -> do
let d = copts^.rsDay let d = copts^.rsDay
case ev of case ev of
VtyEvent (EvKey (KChar 'q') []) -> halt ui VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey KEsc []) -> continue $ uiCheckBalanceAssertions d $ resetScreens d ui VtyEvent (EvKey KEsc []) -> put $ uiCheckBalanceAssertions d $ resetScreens d ui
VtyEvent (EvKey (KChar c) []) | c `elem` ['h','?'] -> continue $ setMode Help ui 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) VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
where where
(pos,f) = case parsewithString hledgerparseerrorpositionp esError of (pos,f) = case parsewithString hledgerparseerrorpositionp esError of
Right (f,l,c) -> (Just (l, Just c),f) Right (f,l,c) -> (Just (l, Just c),f)
Left _ -> (endPosition, journalFilePath j) Left _ -> (endPosition, journalFilePath j)
e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] ->
liftIO (uiReloadJournal copts d (popScreen ui)) >>= continue . uiCheckBalanceAssertions d liftIO (uiReloadJournal copts d (popScreen ui)) >>= put . uiCheckBalanceAssertions d
-- (ej, _) <- liftIO $ journalReloadIfChanged copts d j -- (ej, _) <- liftIO $ journalReloadIfChanged copts d j
-- case ej of -- case ej of
-- Left err -> continue ui{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 ui -- return to previous screen, and reload it -- Right j' -> continue $ regenerateScreens j' d $ popScreen ui -- return to previous screen, and reload it
VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (popScreen $ toggleIgnoreBalanceAssertions ui) VtyEvent (EvKey (KChar 'I') []) -> put $ uiCheckBalanceAssertions d (popScreen $ toggleIgnoreBalanceAssertions ui)
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> continue ui _ -> return ()
esHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
-- | Parse the file name, line and column number from a hledger parse error message, if possible. -- | Parse the file name, line and column number from a hledger parse error message, if possible.
-- Temporary, we should keep the original parse error location. XXX -- Temporary, we should keep the original parse error location. XXX

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

@ -1,3 +1,5 @@
-- TODO: brick 1 support
-- https://hackage.haskell.org/package/brick-1.0/changelog
{-| {-|
hledger-ui - a hledger add-on providing a curses-style interface. hledger-ui - a hledger add-on providing a curses-style interface.
Copyright (c) 2007-2015 Simon Michael <simon@joyful.com> Copyright (c) 2007-2015 Simon Michael <simon@joyful.com>
@ -159,11 +161,11 @@ runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rs
brickapp :: App UIState AppEvent Name brickapp :: App UIState AppEvent Name
brickapp = App { brickapp = App {
appStartEvent = return appStartEvent = return ()
, appAttrMap = const $ fromMaybe defaultTheme $ getTheme =<< uoTheme uopts' , appAttrMap = const $ fromMaybe defaultTheme $ getTheme =<< uoTheme uopts'
, appChooseCursor = showFirstCursor , appChooseCursor = showFirstCursor
, appHandleEvent = \ui ev -> sHandle (aScreen ui) ui ev , appHandleEvent = sHandle (aScreen ui)
, appDraw = \ui -> sDraw (aScreen ui) ui , appDraw = sDraw (aScreen ui)
} }
-- print (length (show ui)) >> exitSuccess -- show any debug output to this point & quit -- print (length (show ui)) >> exitSuccess -- show any debug output to this point & quit

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

@ -4,7 +4,6 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Hledger.UI.RegisterScreen module Hledger.UI.RegisterScreen
@ -199,7 +198,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
-- inclusive = tree_ ropts || rsForceInclusive -- inclusive = tree_ ropts || rsForceInclusive
toplabel = toplabel =
withAttr ("border" <> "bold") (str $ T.unpack $ replaceHiddenAccountsNameWith "All" rsAccount) withAttr (attrName "border" <> attrName "bold") (str $ T.unpack $ replaceHiddenAccountsNameWith "All" rsAccount)
-- <+> withAttr ("border" <> "query") (str $ if inclusive then "" else " exclusive") -- <+> withAttr ("border" <> "query") (str $ if inclusive then "" else " exclusive")
<+> togglefilters <+> togglefilters
<+> str " transactions" <+> str " transactions"
@ -212,7 +211,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
<+> str "/" <+> str "/"
<+> total <+> total
<+> str ")" <+> str ")"
<+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts then withAttr ("border" <> "query") (str " ignoring balance assertions") else str "") <+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts then withAttr (attrName "border" <> attrName "query") (str " ignoring balance assertions") else str "")
where where
togglefilters = togglefilters =
case concat [ case concat [
@ -221,7 +220,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}}
,if empty_ ropts then [] else ["nonzero"] ,if empty_ ropts then [] else ["nonzero"]
] of ] of
[] -> str "" [] -> str ""
fs -> withAttr ("border" <> "query") (str $ " " ++ intercalate ", " fs) fs -> withAttr (attrName "border" <> attrName "query") (str $ " " ++ intercalate ", " fs)
cur = str $ case rsList ^. listSelectedL of cur = str $ case rsList ^. listSelectedL of
Nothing -> "-" Nothing -> "-"
Just i -> show (i + 1) Just i -> show (i + 1)
@ -271,20 +270,21 @@ rsDrawItem (datewidth,descwidth,acctswidth,changewidth,balwidth) selected Regist
where where
changeAmt = wbToText rsItemChangeAmount changeAmt = wbToText rsItemChangeAmount
balanceAmt = wbToText rsItemBalanceAmount balanceAmt = wbToText rsItemBalanceAmount
changeattr | T.any (=='-') changeAmt = sel $ "list" <> "amount" <> "decrease" changeattr | T.any (=='-') changeAmt = sel $ attrName "list" <> attrName "amount" <> attrName "decrease"
| otherwise = sel $ "list" <> "amount" <> "increase" | otherwise = sel $ attrName "list" <> attrName "amount" <> attrName "increase"
balattr | T.any (=='-') balanceAmt = sel $ "list" <> "balance" <> "negative" balattr | T.any (=='-') balanceAmt = sel $ attrName "list" <> attrName "balance" <> attrName "negative"
| otherwise = sel $ "list" <> "balance" <> "positive" | otherwise = sel $ attrName "list" <> attrName "balance" <> attrName "positive"
sel | selected = (<> "selected") sel | selected = (<> attrName "selected")
| otherwise = id | otherwise = id
rsHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) rsHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
rsHandle ui@UIState{ rsHandle ev = do
ui@UIState{
aScreen=s@RegisterScreen{..} aScreen=s@RegisterScreen{..}
,aopts=UIOpts{uoCliOpts=copts} ,aopts=UIOpts{uoCliOpts=copts}
,ajournal=j ,ajournal=j
,aMode=mode ,aMode=mode
} ev = do } <- get
let let
d = copts^.rsDay d = copts^.rsDay
journalspan = journalDateSpan False j journalspan = journalDateSpan False j
@ -294,50 +294,44 @@ rsHandle ui@UIState{
case mode of case mode of
Minibuffer _ ed -> Minibuffer _ ed ->
case ev of case ev of
VtyEvent (EvKey KEsc []) -> continue $ closeMinibuffer ui VtyEvent (EvKey KEsc []) -> modify closeMinibuffer
VtyEvent (EvKey KEnter []) -> continue $ regenerateScreens j d $ VtyEvent (EvKey KEnter []) -> put $ regenerateScreens j d $
case setFilter s $ closeMinibuffer ui of case setFilter s $ closeMinibuffer ui of
Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui
Right ui' -> ui' Right ui' -> ui'
where s = chomp . unlines . map strip $ getEditContents ed where s = chomp . unlines . map strip $ getEditContents ed
-- VtyEvent (EvKey (KChar '/') []) -> continue $ regenerateScreens j d $ showMinibuffer ui -- VtyEvent (EvKey (KChar '/') []) -> put $ regenerateScreens j d $ showMinibuffer ui
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
VtyEvent ev -> do VtyEvent ev -> do
ed' <- handleEditorEvent ed' <- nestEventM' ed $ handleEditorEvent (VtyEvent ev)
#if MIN_VERSION_brick(0,72,0) put ui{aMode=Minibuffer "filter" ed'}
(VtyEvent ev) AppEvent _ -> return ()
#else MouseDown{} -> return ()
ev MouseUp{} -> return ()
#endif
ed
continue $ ui{aMode=Minibuffer "filter" ed'}
AppEvent _ -> continue ui
MouseDown{} -> continue ui
MouseUp{} -> continue ui
Help -> Help ->
case ev of case ev of
-- VtyEvent (EvKey (KChar 'q') []) -> halt ui -- VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> helpHandle ui ev _ -> helpHandle ev
Normal -> Normal ->
case ev of case ev of
VtyEvent (EvKey (KChar 'q') []) -> halt ui VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey KEsc []) -> continue $ resetScreens d ui VtyEvent (EvKey KEsc []) -> put $ resetScreens d ui
VtyEvent (EvKey (KChar c) []) | c == '?' -> continue $ setMode Help ui VtyEvent (EvKey (KChar c) []) | c == '?' -> put $ setMode Help ui
AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old -> AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old ->
continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui put $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
where where
p = reportPeriod ui p = reportPeriod ui
e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] ->
liftIO (uiReloadJournal copts d ui) >>= continue liftIO (uiReloadJournal copts d ui) >>= put
VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) VtyEvent (EvKey (KChar 'I') []) -> put $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui)
VtyEvent (EvKey (KChar 'a') []) -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui VtyEvent (EvKey (KChar 'a') []) -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui
VtyEvent (EvKey (KChar 'A') []) -> suspendAndResume $ void (runIadd (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui VtyEvent (EvKey (KChar 'A') []) -> suspendAndResume $ void (runIadd (journalFilePath j)) >> uiReloadJournalIfChanged copts d j ui
VtyEvent (EvKey (KChar 'T') []) -> continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui 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 VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui
where where
(pos,f) = case listSelectedElement rsList of (pos,f) = case listSelectedElement rsList of
@ -357,78 +351,76 @@ rsHandle ui@UIState{
VtyEvent (EvKey (KChar 'C') []) -> rsCenterAndContinue $ regenerateScreens j d $ toggleCleared ui VtyEvent (EvKey (KChar 'C') []) -> rsCenterAndContinue $ regenerateScreens j d $ toggleCleared ui
VtyEvent (EvKey (KChar 'F') []) -> rsCenterAndContinue $ regenerateScreens j d $ toggleForecast d ui VtyEvent (EvKey (KChar 'F') []) -> rsCenterAndContinue $ regenerateScreens j d $ toggleForecast d ui
VtyEvent (EvKey (KChar '/') []) -> continue $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui VtyEvent (EvKey (KChar '/') []) -> put $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui
VtyEvent (EvKey (KDown) [MShift]) -> continue $ regenerateScreens j d $ shrinkReportPeriod d ui VtyEvent (EvKey (KDown) [MShift]) -> put $ regenerateScreens j d $ shrinkReportPeriod d ui
VtyEvent (EvKey (KUp) [MShift]) -> continue $ regenerateScreens j d $ growReportPeriod d ui VtyEvent (EvKey (KUp) [MShift]) -> put $ regenerateScreens j d $ growReportPeriod d ui
VtyEvent (EvKey (KRight) [MShift]) -> continue $ regenerateScreens j d $ nextReportPeriod journalspan ui VtyEvent (EvKey (KRight) [MShift]) -> put $ regenerateScreens j d $ nextReportPeriod journalspan ui
VtyEvent (EvKey (KLeft) [MShift]) -> continue $ regenerateScreens j d $ previousReportPeriod journalspan ui VtyEvent (EvKey (KLeft) [MShift]) -> put $ regenerateScreens j d $ previousReportPeriod journalspan ui
VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ resetFilter ui) VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (put $ regenerateScreens j d $ resetFilter ui)
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle rsList >> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle rsList >> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
-- exit screen on LEFT -- exit screen on LEFT
VtyEvent e | e `elem` moveLeftEvents -> continue $ popScreen ui VtyEvent e | e `elem` moveLeftEvents -> put $ popScreen ui
-- or on a click in the app's left margin. This is a VtyEvent since not in a clickable widget. -- or on a click in the app's left margin. This is a VtyEvent since not in a clickable widget.
VtyEvent (EvMouseUp x _y (Just BLeft)) | x==0 -> continue $ popScreen ui VtyEvent (EvMouseUp x _y (Just BLeft)) | x==0 -> put $ popScreen ui
-- or on clicking a blank list item. -- or on clicking a blank list item.
MouseUp _ (Just BLeft) Location{loc=(_,y)} | clickeddate == "" -> continue $ popScreen ui MouseUp _ (Just BLeft) Location{loc=(_,y)} | clickeddate == "" -> put $ popScreen ui
where clickeddate = maybe "" rsItemDate $ listElements rsList !? y where clickeddate = maybe "" rsItemDate $ listElements rsList !? y
-- enter transaction screen on RIGHT -- enter transaction screen on RIGHT
VtyEvent e | e `elem` moveRightEvents -> VtyEvent e | e `elem` moveRightEvents ->
case listSelectedElement rsList of case listSelectedElement rsList of
Just _ -> continue $ screenEnter d transactionScreen{tsAccount=rsAccount} ui Just _ -> put $ screenEnter d transactionScreen{tsAccount=rsAccount} ui
Nothing -> continue ui Nothing -> put ui
-- or on transaction click -- or on transaction click
-- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347 -- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347
-- just use it to move the selection -- just use it to move the selection
MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickeddate -> do MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickeddate -> do
continue $ ui{aScreen=s{rsList=listMoveTo y rsList}} put $ ui{aScreen=s{rsList=listMoveTo y rsList}}
where clickeddate = maybe "" rsItemDate $ listElements rsList !? y where clickeddate = maybe "" rsItemDate $ listElements rsList !? y
-- and on MouseUp, enter the subscreen -- and on MouseUp, enter the subscreen
MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickeddate -> do MouseUp _n (Just BLeft) Location{loc=(_x,y)} | not $ (=="") clickeddate -> do
continue $ screenEnter d transactionScreen{tsAccount=rsAccount} ui put $ screenEnter d transactionScreen{tsAccount=rsAccount} ui
where clickeddate = maybe "" rsItemDate $ listElements rsList !? y where clickeddate = maybe "" rsItemDate $ listElements rsList !? y
-- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled -- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled
VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do
vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> continue ui vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> put ui
where mnextelement = listSelectedElement $ listMoveDown rsList where mnextelement = listSelectedElement $ listMoveDown rsList
-- mouse scroll wheel scrolls the viewport up or down to its maximum extent, -- mouse scroll wheel scrolls the viewport up or down to its maximum extent,
-- pushing the selection when necessary. -- pushing the selection when necessary.
MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do
let scrollamt = if btn==BScrollUp then -1 else 1 let scrollamt = if btn==BScrollUp then -1 else 1
list' <- listScrollPushingSelection name rsList (rsListSize rsList) scrollamt list' <- nestEventM' rsList $ listScrollPushingSelection name (rsListSize rsList) scrollamt
continue ui{aScreen=s{rsList=list'}} put ui{aScreen=s{rsList=list'}}
-- if page down or end leads to a blank padding item, stop at last non-blank -- if page down or end leads to a blank padding item, stop at last non-blank
VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do
list <- handleListEvent e rsList list <- nestEventM' rsList $ handleListEvent e
if isBlankElement $ listSelectedElement list if isBlankElement $ listSelectedElement list
then do then do
let list' = listMoveTo lastnonblankidx list let list' = listMoveTo lastnonblankidx list
scrollSelectionToMiddle list' scrollSelectionToMiddle list'
continue ui{aScreen=s{rsList=list'}} put ui{aScreen=s{rsList=list'}}
else else
continue ui{aScreen=s{rsList=list}} put ui{aScreen=s{rsList=list}}
-- fall through to the list's event handler (handles other [pg]up/down events) -- fall through to the list's event handler (handles other [pg]up/down events)
VtyEvent ev -> do VtyEvent ev -> do
let ev' = normaliseMovementKeys ev let ev' = normaliseMovementKeys ev
newitems <- handleListEvent ev' rsList newitems <- nestEventM' rsList $ handleListEvent ev'
continue ui{aScreen=s{rsList=newitems}} put ui{aScreen=s{rsList=newitems}}
MouseDown{} -> continue ui MouseDown{} -> put ui
MouseUp{} -> continue ui MouseUp{} -> put ui
AppEvent _ -> continue ui AppEvent _ -> put ui
rsHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just "" isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""
rsCenterAndContinue ui = do rsCenterAndContinue ui = do
scrollSelectionToMiddle $ rsList $ aScreen ui scrollSelectionToMiddle $ rsList $ aScreen ui
continue ui put ui
rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements

60
hledger-ui/Hledger/UI/Theme.hs
View File

@ -65,42 +65,42 @@ select = black `on` selectbg
themesList :: [(String, AttrMap)] themesList :: [(String, AttrMap)]
themesList = [ themesList = [
("default", attrMap (black `on` white) [ ("default", attrMap (black `on` white) [
("border" , white `on` black & dim) (attrName "border" , white `on` black & dim)
,("border" <> "bold" , currentAttr & bold) ,(attrName "border" <> attrName "bold" , currentAttr & bold)
,("border" <> "depth" , active) ,(attrName "border" <> attrName "depth" , active)
,("border" <> "filename" , currentAttr) ,(attrName "border" <> attrName "filename" , currentAttr)
,("border" <> "key" , active) ,(attrName "border" <> attrName "key" , active)
,("border" <> "minibuffer" , white `on` black & bold) ,(attrName "border" <> attrName "minibuffer" , white `on` black & bold)
,("border" <> "query" , active) ,(attrName "border" <> attrName "query" , active)
,("border" <> "selected" , active) ,(attrName "border" <> attrName "selected" , active)
,("error" , fg red) ,(attrName "error" , fg red)
,("help" , white `on` black & dim) ,(attrName "help" , white `on` black & dim)
,("help" <> "heading" , fg yellow) ,(attrName "help" <> attrName "heading" , fg yellow)
,("help" <> "key" , active) ,(attrName "help" <> attrName "key" , active)
-- ,("list" , black `on` white) -- ,(attrName "list" , black `on` white)
-- ,("list" <> "amount" , currentAttr) -- ,(attrName "list" <> attrName "amount" , currentAttr)
,("list" <> "amount" <> "decrease" , fg red) ,(attrName "list" <> attrName "amount" <> attrName "decrease" , fg red)
-- ,("list" <> "amount" <> "increase" , fg green) -- ,(attrName "list" <> attrName "amount" <> attrName "increase" , fg green)
,("list" <> "amount" <> "decrease" <> "selected" , red `on` selectbg & bold) ,(attrName "list" <> attrName "amount" <> attrName "decrease" <> attrName "selected" , red `on` selectbg & bold)
-- ,("list" <> "amount" <> "increase" <> "selected" , green `on` selectbg & bold) -- ,(attrName "list" <> attrName "amount" <> attrName "increase" <> attrName "selected" , green `on` selectbg & bold)
,("list" <> "balance" , currentAttr & bold) ,(attrName "list" <> attrName "balance" , currentAttr & bold)
,("list" <> "balance" <> "negative" , fg red) ,(attrName "list" <> attrName "balance" <> attrName "negative" , fg red)
,("list" <> "balance" <> "positive" , fg black) ,(attrName "list" <> attrName "balance" <> attrName "positive" , fg black)
,("list" <> "balance" <> "negative" <> "selected" , red `on` selectbg & bold) ,(attrName "list" <> attrName "balance" <> attrName "negative" <> attrName "selected" , red `on` selectbg & bold)
,("list" <> "balance" <> "positive" <> "selected" , select & bold) ,(attrName "list" <> attrName "balance" <> attrName "positive" <> attrName "selected" , select & bold)
,("list" <> "selected" , select) ,(attrName "list" <> attrName "selected" , select)
-- ,("list" <> "accounts" , white `on` brightGreen) -- ,(attrName "list" <> attrName "accounts" , white `on` brightGreen)
-- ,("list" <> "selected" , black `on` brightYellow) -- ,(attrName "list" <> attrName "selected" , black `on` brightYellow)
]) ])
,("greenterm", attrMap (green `on` black) [ ,("greenterm", attrMap (green `on` black) [
("list" <> "selected" , black `on` green) (attrName "list" <> attrName "selected" , black `on` green)
]) ])
,("terminal", attrMap defAttr [ ,("terminal", attrMap defAttr [
("border" , white `on` black), (attrName "border" , white `on` black),
("list" , defAttr), (attrName "list" , defAttr),
("list" <> "selected" , defAttr & reverseVideo) (attrName "list" <> attrName "selected" , defAttr & reverseVideo)
]) ])
] ]

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

@ -107,12 +107,12 @@ tsDraw UIState{aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec
-- <+> str (" ("++show i++" of "++show (length nts)++" in "++acct++")") -- <+> str (" ("++show i++" of "++show (length nts)++" in "++acct++")")
<+> (str $ "#" ++ show (tindex t)) <+> (str $ "#" ++ show (tindex t))
<+> str " (" <+> str " ("
<+> withAttr ("border" <> "bold") (str $ show i) <+> withAttr (attrName "border" <> attrName "bold") (str $ show i)
<+> str (" of "++show (length nts)) <+> str (" of "++show (length nts))
<+> togglefilters <+> togglefilters
<+> borderQueryStr (unwords . map (quoteIfNeeded . T.unpack) $ querystring_ ropts) <+> borderQueryStr (unwords . map (quoteIfNeeded . T.unpack) $ querystring_ ropts)
<+> str (" in "++T.unpack (replaceHiddenAccountsNameWith "All" acct)++")") <+> str (" in "++T.unpack (replaceHiddenAccountsNameWith "All" acct)++")")
<+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts then withAttr ("border" <> "query") (str " ignoring balance assertions") else str "") <+> (if ignore_assertions_ . balancingopts_ $ inputopts_ copts then withAttr (attrName "border" <> attrName "query") (str " ignoring balance assertions") else str "")
where where
togglefilters = togglefilters =
case concat [ case concat [
@ -121,7 +121,7 @@ tsDraw UIState{aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec
,if empty_ ropts then [] else ["nonzero"] ,if empty_ ropts then [] else ["nonzero"]
] of ] of
[] -> str "" [] -> str ""
fs -> withAttr ("border" <> "query") (str $ " " ++ intercalate ", " fs) fs -> withAttr (attrName "border" <> attrName "query") (str $ " " ++ intercalate ", " fs)
bottomlabel = quickhelp bottomlabel = quickhelp
-- case mode of -- case mode of
@ -141,20 +141,20 @@ tsDraw UIState{aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec
tsDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL: tsDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL:
tsHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) tsHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
tsHandle ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransactions=nts} tsHandle ev = do
ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransactions=nts}
,aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} ,aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}}
,ajournal=j ,ajournal=j
,aMode=mode ,aMode=mode
} } <- get
ev =
case mode of case mode of
Help -> Help ->
case ev of case ev of
-- VtyEvent (EvKey (KChar 'q') []) -> halt ui -- VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> helpHandle ui ev _ -> helpHandle ev
_ -> do _ -> do
let let
@ -162,49 +162,47 @@ tsHandle ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransaction
(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
VtyEvent (EvKey (KChar 'q') []) -> halt ui VtyEvent (EvKey (KChar 'q') []) -> halt
VtyEvent (EvKey KEsc []) -> continue $ resetScreens d ui VtyEvent (EvKey KEsc []) -> put $ resetScreens d ui
VtyEvent (EvKey (KChar c) []) | c == '?' -> continue $ setMode Help ui VtyEvent (EvKey (KChar c) []) | c == '?' -> put $ setMode Help ui
VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui
where where
(pos,f) = case tsourcepos t of (pos,f) = case tsourcepos t of
(SourcePos f l1 c1,_) -> (Just (unPos l1, Just $ unPos c1),f) (SourcePos f l1 c1,_) -> (Just (unPos l1, Just $ unPos c1),f)
AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old -> AppEvent (DateChange old _) | isStandardPeriod p && p `periodContainsDate` old ->
continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui put $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
where where
p = reportPeriod ui p = reportPeriod ui
e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> do e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> do
-- plog (if e == AppEvent FileChange then "file change" else "manual reload") "" `seq` return () -- plog (if e == AppEvent FileChange then "file change" else "manual reload") "" `seq` return ()
ej <- liftIO . runExceptT $ journalReload copts ej <- liftIO . runExceptT $ journalReload copts
case ej of case ej of
Left err -> continue $ screenEnter d errorScreen{esError=err} ui Left err -> put $ screenEnter d errorScreen{esError=err} ui
Right j' -> continue $ regenerateScreens j' d ui Right j' -> put $ regenerateScreens j' d ui
VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) VtyEvent (EvKey (KChar 'I') []) -> put $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui)
-- for toggles that may change the current/prev/next transactions, -- for toggles that may change the current/prev/next transactions,
-- we must regenerate the transaction list, like the g handler above ? with regenerateTransactions ? TODO WIP -- we must regenerate the transaction list, like the g handler above ? with regenerateTransactions ? TODO WIP
-- EvKey (KChar 'E') [] -> continue $ regenerateScreens j d $ stToggleEmpty ui -- EvKey (KChar 'E') [] -> put $ regenerateScreens j d $ stToggleEmpty ui
-- EvKey (KChar 'C') [] -> continue $ regenerateScreens j d $ stToggleCleared ui -- EvKey (KChar 'C') [] -> put $ regenerateScreens j d $ stToggleCleared ui
-- EvKey (KChar 'R') [] -> continue $ regenerateScreens j d $ stToggleReal ui -- EvKey (KChar 'R') [] -> put $ regenerateScreens j d $ stToggleReal ui
VtyEvent (EvKey (KChar 'B') []) -> continue . regenerateScreens j d $ toggleConversionOp ui VtyEvent (EvKey (KChar 'B') []) -> put . regenerateScreens j d $ toggleConversionOp ui
VtyEvent (EvKey (KChar 'V') []) -> continue . regenerateScreens j d $ toggleValue ui VtyEvent (EvKey (KChar 'V') []) -> put . regenerateScreens j d $ toggleValue ui
VtyEvent e | e `elem` moveUpEvents -> continue $ tsSelect iprev tprev ui VtyEvent e | e `elem` moveUpEvents -> put $ tsSelect iprev tprev ui
VtyEvent e | e `elem` moveDownEvents -> continue $ tsSelect inext tnext ui VtyEvent e | e `elem` moveDownEvents -> put $ tsSelect inext tnext ui
-- exit screen on LEFT -- exit screen on LEFT
VtyEvent e | e `elem` moveLeftEvents -> continue . popScreen $ tsSelect i t ui -- Probably not necessary to tsSelect here, but it's safe. VtyEvent e | e `elem` moveLeftEvents -> put . popScreen $ tsSelect i t ui -- Probably not necessary to tsSelect here, but it's safe.
-- or on a click in the app's left margin. -- or on a click in the app's left margin.
VtyEvent (EvMouseUp x _y (Just BLeft)) | x==0 -> continue . popScreen $ tsSelect i t ui VtyEvent (EvMouseUp x _y (Just BLeft)) | x==0 -> put . popScreen $ tsSelect i t ui
-- or on clicking the blank area below the transaction. -- or on clicking the blank area below the transaction.
MouseUp _ (Just BLeft) Location{loc=(_,y)} | y+1 > numentrylines -> continue . popScreen $ tsSelect i t ui MouseUp _ (Just BLeft) Location{loc=(_,y)} | y+1 > numentrylines -> put . popScreen $ tsSelect i t ui
where numentrylines = length (T.lines $ showTxn ropts rspec j t) - 1 where numentrylines = length (T.lines $ showTxn ropts rspec j t) - 1
VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> continue ui _ -> return ()
tsHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
-- | Select a new transaction and update the previous register screen -- | Select a new transaction and update the previous register screen
tsSelect i t ui@UIState{aScreen=s@TransactionScreen{}} = case aPrevScreens ui of tsSelect i t ui@UIState{aScreen=s@TransactionScreen{}} = case aPrevScreens ui of

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

@ -33,6 +33,7 @@ Brick.defaultMain brickapp st
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -100,7 +101,7 @@ data Screen =
AccountsScreen { AccountsScreen {
sInit :: Day -> Bool -> UIState -> UIState -- ^ function to initialise or update this screen's state sInit :: Day -> Bool -> UIState -> UIState -- ^ function to initialise or update this screen's state
,sDraw :: UIState -> [Widget Name] -- ^ brick renderer for this screen ,sDraw :: UIState -> [Widget Name] -- ^ brick renderer for this screen
,sHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) -- ^ brick event handler for this screen ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState () -- ^ brick event handler for this screen
-- state fields.These ones have lenses: -- state fields.These ones have lenses:
,_asList :: List Name AccountsScreenItem -- ^ list widget showing account names & balances ,_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 "") ,_asSelectedAccount :: AccountName -- ^ a backup of the account name from the list widget's selected item (or "")
@ -108,7 +109,7 @@ data Screen =
| RegisterScreen { | RegisterScreen {
sInit :: Day -> Bool -> UIState -> UIState sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: UIState -> [Widget Name] ,sDraw :: UIState -> [Widget Name]
,sHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
-- --
,rsList :: List Name RegisterScreenItem -- ^ list widget showing transactions affecting this account ,rsList :: List Name RegisterScreenItem -- ^ list widget showing transactions affecting this account
,rsAccount :: AccountName -- ^ the account this register is for ,rsAccount :: AccountName -- ^ the account this register is for
@ -119,7 +120,7 @@ data Screen =
| TransactionScreen { | TransactionScreen {
sInit :: Day -> Bool -> UIState -> UIState sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: UIState -> [Widget Name] ,sDraw :: UIState -> [Widget Name]
,sHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) ,sHandle :: BrickEvent Name AppEvent -> EventM Name 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
@ -128,7 +129,7 @@ data Screen =
| ErrorScreen { | ErrorScreen {
sInit :: Day -> Bool -> UIState -> UIState sInit :: Day -> Bool -> UIState -> UIState
,sDraw :: UIState -> [Widget Name] ,sDraw :: UIState -> [Widget Name]
,sHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) ,sHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
-- --
,esError :: String -- ^ error message to show ,esError :: String -- ^ error message to show
} }
@ -154,6 +155,10 @@ data RegisterScreenItem = RegisterScreenItem {
} }
deriving (Show) deriving (Show)
instance MonadFail (EventM Name UIState) where fail _ = wrongScreenTypeError
wrongScreenTypeError = error' "handler called with wrong screen type, should not happen"
type NumberedTransaction = (Integer, Transaction) type NumberedTransaction = (Integer, Transaction)
-- dummy monoid instance needed make lenses work with List fields not common across constructors -- dummy monoid instance needed make lenses work with List fields not common across constructors

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

@ -35,7 +35,7 @@ import Brick.Widgets.Border
import Brick.Widgets.Border.Style import Brick.Widgets.Border.Style
import Brick.Widgets.Dialog import Brick.Widgets.Dialog
import Brick.Widgets.Edit import Brick.Widgets.Edit
import Brick.Widgets.List (List, listSelectedL, listNameL, listItemHeightL, listSelected, listMoveDown, listMoveUp, GenericList, Splittable) import Brick.Widgets.List (List, listSelectedL, listNameL, listItemHeightL, listSelected, listMoveDown, listMoveUp, GenericList)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.List import Data.List
@ -60,6 +60,7 @@ suspendSignal :: IO ()
suspendSignal = return () suspendSignal = return ()
#else #else
import System.Posix.Signals import System.Posix.Signals
import Data.Vector (Vector)
suspendSignal :: IO () suspendSignal :: IO ()
suspendSignal = raiseSignal sigSTOP suspendSignal = raiseSignal sigSTOP
#endif #endif
@ -68,12 +69,12 @@ suspendSignal = raiseSignal sigSTOP
-- like control-z in bash, returning to the original shell prompt, -- like control-z in bash, returning to the original shell prompt,
-- and when resumed, continue where we left off. -- and when resumed, continue where we left off.
-- On windows, does nothing. -- On windows, does nothing.
suspend :: s -> EventM a (Next s) suspend :: Ord a => s -> EventM a s ()
suspend st = suspendAndResume $ suspendSignal >> return st suspend st = suspendAndResume $ suspendSignal >> return st
-- | Tell vty to redraw the whole screen, and continue. -- | Tell vty to redraw the whole screen.
redraw :: s -> EventM a (Next s) redraw :: EventM a s ()
redraw st = getVtyHandle >>= liftIO . refresh >> continue st redraw = getVtyHandle >>= liftIO . refresh
-- | Wrap a widget in the default hledger-ui screen layout. -- | Wrap a widget in the default hledger-ui screen layout.
defaultLayout :: Widget Name -> Widget Name -> Widget Name -> Widget Name defaultLayout :: Widget Name -> Widget Name -> Widget Name -> Widget Name
@ -90,14 +91,14 @@ helpDialog _copts =
Widget Fixed Fixed $ do Widget Fixed Fixed $ do
c <- getContext c <- getContext
render $ render $
withDefAttr "help" $ withDefAttr (attrName "help") $
renderDialog (dialog (Just "Help (LEFT/ESC/?/q to close help)") Nothing (c^.availWidthL)) $ -- (Just (0,[("ok",())])) renderDialog (dialog (Just "Help (LEFT/ESC/?/q to close help)") Nothing (c^.availWidthL)) $ -- (Just (0,[("ok",())]))
padTop (Pad 0) $ padLeft (Pad 1) $ padRight (Pad 1) $ padTop (Pad 0) $ padLeft (Pad 1) $ padRight (Pad 1) $
vBox [ vBox [
hBox [ hBox [
padRight (Pad 1) $ padRight (Pad 1) $
vBox [ vBox [
withAttr ("help" <> "heading") $ str "Navigation" withAttr (attrName "help" <> attrName "heading") $ str "Navigation"
,renderKey ("UP/DOWN/PUP/PDN/HOME/END/k/j/C-p/C-n", "") ,renderKey ("UP/DOWN/PUP/PDN/HOME/END/k/j/C-p/C-n", "")
,str " move selection up/down" ,str " move selection up/down"
,renderKey ("RIGHT/l/C-f", "show txns, or txn detail") ,renderKey ("RIGHT/l/C-f", "show txns, or txn detail")
@ -105,23 +106,23 @@ helpDialog _copts =
,renderKey ("ESC ", "cancel, or reset app state") ,renderKey ("ESC ", "cancel, or reset app state")
,str " " ,str " "
,withAttr ("help" <> "heading") $ str "Accounts screen" ,withAttr (attrName "help" <> attrName "heading") $ str "Accounts screen"
,renderKey ("1234567890-+ ", "set/adjust depth limit") ,renderKey ("1234567890-+ ", "set/adjust depth limit")
,renderKey ("t ", "toggle accounts tree/list mode") ,renderKey ("t ", "toggle accounts tree/list mode")
,renderKey ("H ", "toggle historical balance/change") ,renderKey ("H ", "toggle historical balance/change")
,str " " ,str " "
,withAttr ("help" <> "heading") $ str "Register screen" ,withAttr (attrName "help" <> attrName "heading") $ str "Register screen"
,renderKey ("t ", "toggle subaccount txns\n(and accounts tree/list mode)") ,renderKey ("t ", "toggle subaccount txns\n(and accounts tree/list mode)")
,renderKey ("H ", "toggle historical/period total") ,renderKey ("H ", "toggle historical/period total")
,str " " ,str " "
,withAttr ("help" <> "heading") $ str "Help" ,withAttr (attrName "help" <> attrName "heading") $ str "Help"
,renderKey ("? ", "toggle this help") ,renderKey ("? ", "toggle this help")
,renderKey ("p/m/i", "while help is open:\nshow manual in pager/man/info") ,renderKey ("p/m/i", "while help is open:\nshow manual in pager/man/info")
,str " " ,str " "
] ]
,padLeft (Pad 1) $ padRight (Pad 0) $ ,padLeft (Pad 1) $ padRight (Pad 0) $
vBox [ vBox [
withAttr ("help" <> "heading") $ str "Filtering" withAttr (attrName "help" <> attrName "heading") $ str "Filtering"
,renderKey ("/ ", "set a filter query") ,renderKey ("/ ", "set a filter query")
,renderKey ("F ", "show future & periodic txns") ,renderKey ("F ", "show future & periodic txns")
,renderKey ("R ", "show real/all postings") ,renderKey ("R ", "show real/all postings")
@ -132,7 +133,7 @@ helpDialog _copts =
,renderKey ("T ", "set period to today") ,renderKey ("T ", "set period to today")
,renderKey ("DEL ", "reset filters") ,renderKey ("DEL ", "reset filters")
,str " " ,str " "
,withAttr ("help" <> "heading") $ str "Other" ,withAttr (attrName "help" <> attrName "heading") $ str "Other"
,renderKey ("a ", "add transaction (hledger add)") ,renderKey ("a ", "add transaction (hledger add)")
,renderKey ("A ", "add transaction (hledger-iadd)") ,renderKey ("A ", "add transaction (hledger-iadd)")
,renderKey ("B ", "show amounts/costs") ,renderKey ("B ", "show amounts/costs")
@ -160,39 +161,40 @@ helpDialog _copts =
-- ] -- ]
] ]
where where
renderKey (key,desc) = withAttr ("help" <> "key") (str key) <+> str " " <+> str desc renderKey (key,desc) = withAttr (attrName "help" <> attrName "key") (str key) <+> str " " <+> str desc
-- | Event handler used when help mode is active. -- | Event handler used when help mode is active.
-- May invoke $PAGER, less, man or info, which is likely to fail on MS Windows, TODO. -- May invoke $PAGER, less, man or info, which is likely to fail on MS Windows, TODO.
helpHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) helpHandle :: BrickEvent Name AppEvent -> EventM Name UIState ()
helpHandle ui ev = do helpHandle ev = do
ui <- get
let ui' = setMode Normal ui
case ev of case ev of
VtyEvent e | e `elem` closeHelpEvents -> continue $ setMode Normal ui VtyEvent e | e `elem` closeHelpEvents -> put ui'
VtyEvent (EvKey (KChar 'p') []) -> suspendAndResume $ runPagerForTopic "hledger-ui" Nothing >> return ui' VtyEvent (EvKey (KChar 'p') []) -> suspendAndResume $ runPagerForTopic "hledger-ui" Nothing >> return ui'
VtyEvent (EvKey (KChar 'm') []) -> suspendAndResume $ runManForTopic "hledger-ui" Nothing >> return ui' VtyEvent (EvKey (KChar 'm') []) -> suspendAndResume $ runManForTopic "hledger-ui" Nothing >> return ui'
VtyEvent (EvKey (KChar 'i') []) -> suspendAndResume $ runInfoForTopic "hledger-ui" Nothing >> return ui' VtyEvent (EvKey (KChar 'i') []) -> suspendAndResume $ runInfoForTopic "hledger-ui" Nothing >> return ui'
_ -> continue ui _ -> return ()
where where
ui' = setMode Normal ui
closeHelpEvents = moveLeftEvents ++ [EvKey KEsc [], EvKey (KChar '?') [], EvKey (KChar 'q') []] closeHelpEvents = moveLeftEvents ++ [EvKey KEsc [], EvKey (KChar '?') [], EvKey (KChar 'q') []]
-- | Draw the minibuffer with the given label. -- | Draw the minibuffer with the given label.
minibuffer :: T.Text -> Editor String Name -> Widget Name minibuffer :: T.Text -> Editor String Name -> Widget Name
minibuffer string ed = minibuffer string ed =
forceAttr ("border" <> "minibuffer") $ forceAttr (attrName "border" <> attrName "minibuffer") $
hBox [txt $ string <> ": ", renderEditor (str . unlines) True ed] hBox [txt $ string <> ": ", renderEditor (str . unlines) True ed]
borderQueryStr :: String -> Widget Name borderQueryStr :: String -> Widget Name
borderQueryStr "" = str "" borderQueryStr "" = str ""
borderQueryStr qry = str " matching " <+> withAttr ("border" <> "query") (str qry) borderQueryStr qry = str " matching " <+> withAttr (attrName "border" <> attrName "query") (str qry)
borderDepthStr :: Maybe Int -> Widget Name borderDepthStr :: Maybe Int -> Widget Name
borderDepthStr Nothing = str "" borderDepthStr Nothing = str ""
borderDepthStr (Just d) = str " to depth " <+> withAttr ("border" <> "query") (str $ show d) borderDepthStr (Just d) = str " to depth " <+> withAttr (attrName "border" <> attrName "query") (str $ show d)
borderPeriodStr :: String -> Period -> Widget Name borderPeriodStr :: String -> Period -> Widget Name
borderPeriodStr _ PeriodAll = str "" borderPeriodStr _ PeriodAll = str ""
borderPeriodStr preposition p = str (" "++preposition++" ") <+> withAttr ("border" <> "query") (str . T.unpack $ showPeriod p) borderPeriodStr preposition p = str (" "++preposition++" ") <+> withAttr (attrName "border" <> attrName "query") (str . T.unpack $ showPeriod p)
borderKeysStr :: [(String,String)] -> Widget Name borderKeysStr :: [(String,String)] -> Widget Name
borderKeysStr = borderKeysStr' . map (second str) borderKeysStr = borderKeysStr' . map (second str)
@ -201,7 +203,7 @@ borderKeysStr' :: [(String,Widget Name)] -> Widget Name
borderKeysStr' keydescs = borderKeysStr' keydescs =
hBox $ hBox $
intersperse sep $ intersperse sep $
[withAttr ("border" <> "key") (str keys) <+> str ":" <+> desc | (keys, desc) <- keydescs] [withAttr (attrName "border" <> attrName "key") (str keys) <+> str ":" <+> desc | (keys, desc) <- keydescs]
where where
-- sep = str " | " -- sep = str " | "
sep = str " " sep = str " "
@ -209,7 +211,7 @@ borderKeysStr' keydescs =
-- | Show both states of a toggle ("aaa/bbb"), highlighting the active one. -- | Show both states of a toggle ("aaa/bbb"), highlighting the active one.
renderToggle :: Bool -> String -> String -> Widget Name renderToggle :: Bool -> String -> String -> Widget Name
renderToggle isright l r = renderToggle isright l r =
let bold = withAttr ("border" <> "selected") in let bold = withAttr (attrName "border" <> attrName "selected") in
if isright if isright
then str (l++"/") <+> bold (str r) then str (l++"/") <+> bold (str r)
else bold (str l) <+> str ("/"++r) else bold (str l) <+> str ("/"++r)
@ -217,7 +219,7 @@ renderToggle isright l r =
-- | Show a toggle's label, highlighted (bold) when the toggle is active. -- | Show a toggle's label, highlighted (bold) when the toggle is active.
renderToggle1 :: Bool -> String -> Widget Name renderToggle1 :: Bool -> String -> Widget Name
renderToggle1 isactive l = renderToggle1 isactive l =
let bold = withAttr ("border" <> "selected") in let bold = withAttr (attrName "border" <> attrName "selected") in
if isactive if isactive
then bold (str l) then bold (str l)
else str l else str l
@ -262,11 +264,11 @@ topBottomBorderWithLabels toplabel bottomlabel body =
"" ""
-- " debug: "++show (_w,h') -- " debug: "++show (_w,h')
render $ render $
hBorderWithLabel (withAttr "border" $ toplabel <+> str debugmsg) hBorderWithLabel (withAttr (attrName "border") $ toplabel <+> str debugmsg)
<=> <=>
body' body'
<=> <=>
hBorderWithLabel (withAttr "border" bottomlabel) hBorderWithLabel (withAttr (attrName "border") 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 Name -> Widget Name -> Widget Name --_topBottomBorderWithLabel2 :: Widget Name -> Widget Name -> Widget Name
@ -303,7 +305,7 @@ margin h v mcolour w = Widget Greedy Greedy $ do
-- applyN n border -- applyN n border
withBorderAttr :: Attr -> Widget Name -> Widget Name withBorderAttr :: Attr -> Widget Name -> Widget Name
withBorderAttr attr = updateAttrMap (applyAttrMappings [("border", attr)]) withBorderAttr attr = updateAttrMap (applyAttrMappings [(attrName "border", attr)])
---- | Like brick's continue, but first run some action to modify brick's state. ---- | Like brick's continue, but first run some action to modify brick's state.
---- This action does not affect the app state, but might eg adjust a widget's scroll position. ---- This action does not affect the app state, but might eg adjust a widget's scroll position.
@ -319,7 +321,7 @@ withBorderAttr attr = updateAttrMap (applyAttrMappings [("border", attr)])
-- | Scroll a list's viewport so that the selected item is centered in the -- | Scroll a list's viewport so that the selected item is centered in the
-- middle of the display area. -- middle of the display area.
scrollSelectionToMiddle :: List Name e -> EventM Name () scrollSelectionToMiddle :: List Name item -> EventM Name UIState ()
scrollSelectionToMiddle list = do scrollSelectionToMiddle list = do
case list^.listSelectedL of case list^.listSelectedL of
Nothing -> return () Nothing -> return ()
@ -364,9 +366,9 @@ reportSpecSetFutureAndForecast d forecast rspec =
-- Vertically scroll the named list's viewport with the given number of non-empty items -- Vertically scroll the named list's viewport with the given number of non-empty items
-- by the given positive or negative number of items (usually 1 or -1). -- by the given positive or negative number of items (usually 1 or -1).
-- The selection will be moved when necessary to keep it visible and allow the scroll. -- The selection will be moved when necessary to keep it visible and allow the scroll.
listScrollPushingSelection :: (Ord n, Foldable t, Splittable t) => listScrollPushingSelection :: Name -> Int -> Int -> EventM Name (List Name item) (GenericList Name Vector item)
n -> GenericList n t e -> Int -> Int -> EventM n (GenericList n t e) listScrollPushingSelection name listheight scrollamt = do
listScrollPushingSelection name list listheight scrollamt = do list <- get
viewportScroll name `vScrollBy` scrollamt viewportScroll name `vScrollBy` scrollamt
mvp <- lookupViewport name mvp <- lookupViewport name
case mvp of case mvp of

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

@ -68,7 +68,7 @@ executable hledger-ui
ansi-terminal >=0.9 ansi-terminal >=0.9
, async , async
, base >=4.11 && <4.17 , base >=4.11 && <4.17
, brick >=0.23 , brick >=1.0
, cmdargs >=0.8 , cmdargs >=0.8
, containers >=0.5.9 , containers >=0.5.9
, data-default , data-default

2
hledger-ui/package.yaml
View File

@ -76,7 +76,7 @@ dependencies:
- transformers - transformers
- vector - vector
# not installable on windows, cf buildable flag below # not installable on windows, cf buildable flag below
- brick >=0.23 && <1 - brick >=1.0
- vty >=5.15 - vty >=5.15
- unix - unix

5
stack.yaml
View File

@ -1,6 +1,6 @@
# stack build plan using GHC 9.2.4 # stack build plan using GHC 9.2.4
resolver: nightly-2022-08-04 resolver: nightly-2022-08-14
packages: packages:
- hledger-lib - hledger-lib
@ -8,10 +8,11 @@ packages:
- hledger-ui - hledger-ui
- hledger-web - hledger-web
# extra-deps: extra-deps:
# for hledger-lib: # for hledger-lib:
# for hledger: # for hledger:
# for hledger-ui: # for hledger-ui:
- brick-1.0
# for hledger-web: # for hledger-web:
# for Shake.hs: # for Shake.hs: