diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs index e5fcc815f..49841b9fd 100644 --- a/hledger-ui/Hledger/UI/AccountsScreen.hs +++ b/hledger-ui/Hledger/UI/AccountsScreen.hs @@ -152,7 +152,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}} ishistorical = balanceaccum_ ropts == Historical toplabel = - withAttr ("border" <> "filename") files + withAttr (attrName "border" <> attrName "filename") files <+> toggles <+> str (" account " ++ if ishistorical then "balances" else "changes") <+> 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 <+> str (" ("++curidx++"/"++totidx++")") <+> (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 "") where files = case journalFilePaths j of @@ -168,7 +168,7 @@ asDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}} f:_ -> str $ takeFileName f -- [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)") - toggles = withAttr ("border" <> "query") $ str $ unwords $ concat [ + toggles = withAttr (attrName "border" <> attrName "query") $ str $ unwords $ concat [ [""] ,if empty_ ropts then [] else ["nonzero"] ,uiShowStatus copts $ statuses_ ropts @@ -220,22 +220,24 @@ asDrawItem (acctwidth, balwidth) selected AccountsScreenItem{..} = balspace = T.replicate (2 + balwidth - wbWidth balBuilder) " " splitAmounts = foldr1 (<+>) . intersperse (str ", ") . map renderamt . T.splitOn ", " . wbToText renderamt :: T.Text -> Widget Name - renderamt a | T.any (=='-') a = withAttr (sel $ "list" <> "balance" <> "negative") $ txt a - | otherwise = withAttr (sel $ "list" <> "balance" <> "positive") $ txt a - sel | selected = (<> "selected") + renderamt a | T.any (=='-') a = withAttr (sel $ attrName "list" <> attrName "balance" <> attrName "negative") $ txt a + | otherwise = withAttr (sel $ attrName "list" <> attrName "balance" <> attrName "positive") $ txt a + sel | selected = (<> attrName "selected") | otherwise = id -asHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) -asHandle ui0@UIState{ +asHandle :: BrickEvent Name AppEvent -> EventM Name UIState () +asHandle ev = do + ui0@UIState{ aScreen=scr@AccountsScreen{..} ,aopts=UIOpts{uoCliOpts=copts} ,ajournal=j ,aMode=mode - } ev = do + } <- get -- PARTIAL: should not fail let d = copts^.rsDay nonblanks = V.takeWhile (not . T.null . asItemAccountName) $ _asList^.listElementsL 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 let @@ -247,87 +249,81 @@ asHandle ui0@UIState{ case mode of Minibuffer _ ed -> case ev of - VtyEvent (EvKey KEsc []) -> continue $ closeMinibuffer ui - VtyEvent (EvKey KEnter []) -> continue $ regenerateScreens j d $ + VtyEvent (EvKey KEsc []) -> put $ closeMinibuffer ui + VtyEvent (EvKey KEnter []) -> put $ regenerateScreens j d $ case setFilter s $ closeMinibuffer ui of Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui Right ui' -> ui' 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 ev -> do - ed' <- handleEditorEvent -#if MIN_VERSION_brick(0,72,0) - (VtyEvent ev) -#else - ev -#endif - ed - continue $ ui{aMode=Minibuffer "filter" ed'} - AppEvent _ -> continue ui - MouseDown{} -> continue ui - MouseUp{} -> continue ui + VtyEvent ev -> do + ed' <- nestEventM' ed $ handleEditorEvent (VtyEvent ev) + put ui{aMode=Minibuffer "filter" ed'} + AppEvent _ -> return () + MouseDown{} -> return () + MouseUp{} -> return () Help -> case ev of - -- VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + -- VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui - _ -> helpHandle ui ev + _ -> helpHandle ev Normal -> case ev of - VtyEvent (EvKey (KChar 'q') []) -> halt ui + VtyEvent (EvKey (KChar 'q') []) -> halt -- EvKey (KChar 'l') [MCtrl] -> do - VtyEvent (EvKey KEsc []) -> continue $ resetScreens d ui - VtyEvent (EvKey (KChar c) []) | c == '?' -> continue $ setMode Help ui + VtyEvent (EvKey KEsc []) -> put $ resetScreens d ui + VtyEvent (EvKey (KChar c) []) | c == '?' -> put $ setMode Help ui -- XXX AppEvents currently handled only in Normal mode -- XXX be sure we don't leave unconsumed events piling up 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 p = reportPeriod ui e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> - liftIO (uiReloadJournal copts d ui) >>= continue - VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) + liftIO (uiReloadJournal copts d ui) >>= put + 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 $ 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 'B') []) -> continue $ regenerateScreens j d $ toggleConversionOp ui - VtyEvent (EvKey (KChar 'V') []) -> continue $ regenerateScreens j d $ toggleValue ui - VtyEvent (EvKey (KChar '0') []) -> continue $ regenerateScreens j d $ setDepth (Just 0) ui - VtyEvent (EvKey (KChar '1') []) -> continue $ regenerateScreens j d $ setDepth (Just 1) ui - VtyEvent (EvKey (KChar '2') []) -> continue $ regenerateScreens j d $ setDepth (Just 2) ui - VtyEvent (EvKey (KChar '3') []) -> continue $ regenerateScreens j d $ setDepth (Just 3) ui - VtyEvent (EvKey (KChar '4') []) -> continue $ regenerateScreens j d $ setDepth (Just 4) ui - VtyEvent (EvKey (KChar '5') []) -> continue $ regenerateScreens j d $ setDepth (Just 5) ui - VtyEvent (EvKey (KChar '6') []) -> continue $ regenerateScreens j d $ setDepth (Just 6) ui - VtyEvent (EvKey (KChar '7') []) -> continue $ regenerateScreens j d $ setDepth (Just 7) ui - VtyEvent (EvKey (KChar '8') []) -> continue $ regenerateScreens j d $ setDepth (Just 8) ui - VtyEvent (EvKey (KChar '9') []) -> continue $ regenerateScreens j d $ setDepth (Just 9) ui - VtyEvent (EvKey (KChar '-') []) -> continue $ regenerateScreens j d $ decDepth ui - VtyEvent (EvKey (KChar '_') []) -> continue $ regenerateScreens j d $ decDepth ui - VtyEvent (EvKey (KChar c) []) | c `elem` ['+','='] -> continue $ regenerateScreens j d $ incDepth ui - VtyEvent (EvKey (KChar 'T') []) -> continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui + VtyEvent (EvKey (KChar 'B') []) -> put $ regenerateScreens j d $ toggleConversionOp ui + VtyEvent (EvKey (KChar 'V') []) -> put $ regenerateScreens j d $ toggleValue ui + VtyEvent (EvKey (KChar '0') []) -> put $ regenerateScreens j d $ setDepth (Just 0) ui + VtyEvent (EvKey (KChar '1') []) -> put $ regenerateScreens j d $ setDepth (Just 1) ui + VtyEvent (EvKey (KChar '2') []) -> put $ regenerateScreens j d $ setDepth (Just 2) ui + VtyEvent (EvKey (KChar '3') []) -> put $ regenerateScreens j d $ setDepth (Just 3) ui + VtyEvent (EvKey (KChar '4') []) -> put $ regenerateScreens j d $ setDepth (Just 4) ui + VtyEvent (EvKey (KChar '5') []) -> put $ regenerateScreens j d $ setDepth (Just 5) ui + VtyEvent (EvKey (KChar '6') []) -> put $ regenerateScreens j d $ setDepth (Just 6) ui + VtyEvent (EvKey (KChar '7') []) -> put $ regenerateScreens j d $ setDepth (Just 7) ui + VtyEvent (EvKey (KChar '8') []) -> put $ regenerateScreens j d $ setDepth (Just 8) ui + VtyEvent (EvKey (KChar '9') []) -> put $ regenerateScreens j d $ setDepth (Just 9) ui + VtyEvent (EvKey (KChar '-') []) -> put $ regenerateScreens j d $ decDepth ui + VtyEvent (EvKey (KChar '_') []) -> put $ regenerateScreens j d $ decDepth ui + VtyEvent (EvKey (KChar c) []) | c `elem` ['+','='] -> put $ regenerateScreens j d $ incDepth ui + VtyEvent (EvKey (KChar 'T') []) -> put $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui -- display mode/query toggles - VtyEvent (EvKey (KChar 'H') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleHistorical ui - VtyEvent (EvKey (KChar 't') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleTree ui - VtyEvent (EvKey (KChar c) []) | c `elem` ['z','Z'] -> asCenterAndContinue $ regenerateScreens j d $ toggleEmpty ui - VtyEvent (EvKey (KChar 'R') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleReal ui - VtyEvent (EvKey (KChar 'U') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleUnmarked ui - VtyEvent (EvKey (KChar 'P') []) -> asCenterAndContinue $ regenerateScreens j d $ togglePending ui - VtyEvent (EvKey (KChar 'C') []) -> asCenterAndContinue $ regenerateScreens j d $ toggleCleared ui - VtyEvent (EvKey (KChar 'F') []) -> continue $ regenerateScreens j d $ toggleForecast d ui + VtyEvent (EvKey (KChar 'H') []) -> modify (regenerateScreens j d . toggleHistorical) >> asCenterAndContinue + VtyEvent (EvKey (KChar 't') []) -> modify (regenerateScreens j d . toggleTree) >> asCenterAndContinue + VtyEvent (EvKey (KChar c) []) | c `elem` ['z','Z'] -> modify (regenerateScreens j d . toggleEmpty) >> asCenterAndContinue + VtyEvent (EvKey (KChar 'R') []) -> modify (regenerateScreens j d . toggleReal) >> asCenterAndContinue + VtyEvent (EvKey (KChar 'U') []) -> modify (regenerateScreens j d . toggleUnmarked) >> asCenterAndContinue + VtyEvent (EvKey (KChar 'P') []) -> modify (regenerateScreens j d . togglePending) >> asCenterAndContinue + VtyEvent (EvKey (KChar 'C') []) -> modify (regenerateScreens j d . toggleCleared) >> asCenterAndContinue + VtyEvent (EvKey (KChar 'F') []) -> modify (regenerateScreens j d . toggleForecast d) - VtyEvent (EvKey (KDown) [MShift]) -> continue $ regenerateScreens j d $ shrinkReportPeriod d ui - VtyEvent (EvKey (KUp) [MShift]) -> continue $ regenerateScreens j d $ growReportPeriod d ui - VtyEvent (EvKey (KRight) [MShift]) -> continue $ regenerateScreens j d $ nextReportPeriod journalspan ui - VtyEvent (EvKey (KLeft) [MShift]) -> continue $ regenerateScreens j d $ previousReportPeriod journalspan ui - VtyEvent (EvKey (KChar '/') []) -> continue $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui - VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ resetFilter ui) - VtyEvent e | e `elem` moveLeftEvents -> continue $ popScreen ui - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw ui + VtyEvent (EvKey (KDown) [MShift]) -> put $ regenerateScreens j d $ shrinkReportPeriod d ui + VtyEvent (EvKey (KUp) [MShift]) -> put $ regenerateScreens j d $ growReportPeriod d ui + VtyEvent (EvKey (KRight) [MShift]) -> put $ regenerateScreens j d $ nextReportPeriod journalspan ui + VtyEvent (EvKey (KLeft) [MShift]) -> put $ regenerateScreens j d $ previousReportPeriod journalspan ui + VtyEvent (EvKey (KChar '/') []) -> put $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui + VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (put $ regenerateScreens j d $ resetFilter ui) + VtyEvent e | e `elem` moveLeftEvents -> put $ popScreen ui + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle _asList >> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui -- 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 -- just use it to move the selection 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 -- and on MouseUp, enter the subscreen 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 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 -- mouse scroll wheel scrolls the viewport up or down to its maximum extent, -- pushing the selection when necessary. MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do let scrollamt = if btn==BScrollUp then -1 else 1 - list' <- listScrollPushingSelection name _asList (asListSize _asList) scrollamt - continue ui{aScreen=scr{_asList=list'}} + list' <- nestEventM' _asList $ listScrollPushingSelection name (asListSize _asList) scrollamt + 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 VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do - list <- handleListEvent e _asList + list <- nestEventM' _asList $ handleListEvent e if isBlankElement $ listSelectedElement list then do let list' = listMoveTo lastnonblankidx 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 - 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) VtyEvent ev -> do - newitems <- handleListEvent (normaliseMovementKeys ev) _asList - continue $ ui{aScreen=scr & asList .~ newitems - & asSelectedAccount .~ selacct - } + list' <- nestEventM' _asList $ handleListEvent (normaliseMovementKeys ev) + put $ ui{aScreen=scr & asList .~ list' & asSelectedAccount .~ selacct } - MouseDown{} -> continue ui - MouseUp{} -> continue ui - AppEvent _ -> continue ui - - where - journalspan = journalDateSpan False j - -asHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL: + MouseDown{} -> put ui + MouseUp{} -> put ui + AppEvent _ -> put ui asEnterRegister d selacct ui = do rsCenterAndContinue $ @@ -399,8 +388,9 @@ asSetSelectedAccount _ s = s isBlankElement mel = ((asItemAccountName . snd) <$> mel) == Just "" -asCenterAndContinue ui = do - scrollSelectionToMiddle $ _asList $ aScreen ui - continue ui +asCenterAndContinue :: EventM Name UIState () +asCenterAndContinue = do + ui <- get + scrollSelectionToMiddle (_asList $ aScreen ui) asListSize = V.length . V.takeWhile ((/="").asItemAccountName) . listElements diff --git a/hledger-ui/Hledger/UI/ErrorScreen.hs b/hledger-ui/Hledger/UI/ErrorScreen.hs index 2c1e81500..be55bf792 100644 --- a/hledger-ui/Hledger/UI/ErrorScreen.hs +++ b/hledger-ui/Hledger/UI/ErrorScreen.hs @@ -54,10 +54,10 @@ esDraw UIState{aopts=UIOpts{uoCliOpts=copts} _ -> [maincontent] where maincontent = Widget Greedy Greedy $ do - render $ defaultLayout toplabel bottomlabel $ withAttr "error" $ str $ esError + render $ defaultLayout toplabel bottomlabel $ withAttr (attrName "error") $ str $ esError where 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") 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: -esHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) -esHandle ui@UIState{aScreen=ErrorScreen{..} +esHandle :: BrickEvent Name AppEvent -> EventM Name UIState () +esHandle ev = do + ui@UIState{aScreen=ErrorScreen{..} ,aopts=UIOpts{uoCliOpts=copts} ,ajournal=j ,aMode=mode - } - ev = + } <- get case mode of Help -> case ev of - VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui - _ -> helpHandle ui ev + _ -> helpHandle ev _ -> do let d = copts^.rsDay case ev of - VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey KEsc []) -> continue $ uiCheckBalanceAssertions d $ resetScreens d ui - VtyEvent (EvKey (KChar c) []) | c `elem` ['h','?'] -> continue $ setMode Help ui + VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey KEsc []) -> put $ uiCheckBalanceAssertions d $ resetScreens d 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) where (pos,f) = case parsewithString hledgerparseerrorpositionp esError of Right (f,l,c) -> (Just (l, Just c),f) Left _ -> (endPosition, journalFilePath j) 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 -- case ej of -- 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 - VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (popScreen $ toggleIgnoreBalanceAssertions ui) - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + VtyEvent (EvKey (KChar 'I') []) -> put $ uiCheckBalanceAssertions d (popScreen $ toggleIgnoreBalanceAssertions ui) + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui - _ -> continue ui - -esHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL: + _ -> return () -- | 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 diff --git a/hledger-ui/Hledger/UI/Main.hs b/hledger-ui/Hledger/UI/Main.hs index 7c504fb77..35bf8b558 100644 --- a/hledger-ui/Hledger/UI/Main.hs +++ b/hledger-ui/Hledger/UI/Main.hs @@ -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. Copyright (c) 2007-2015 Simon Michael @@ -159,11 +161,11 @@ runBrickUi uopts@UIOpts{uoCliOpts=copts@CliOpts{inputopts_=_iopts,reportspec_=rs brickapp :: App UIState AppEvent Name brickapp = App { - appStartEvent = return + appStartEvent = return () , appAttrMap = const $ fromMaybe defaultTheme $ getTheme =<< uoTheme uopts' , appChooseCursor = showFirstCursor - , appHandleEvent = \ui ev -> sHandle (aScreen ui) ui ev - , appDraw = \ui -> sDraw (aScreen ui) ui + , appHandleEvent = sHandle (aScreen ui) + , appDraw = sDraw (aScreen ui) } -- print (length (show ui)) >> exitSuccess -- show any debug output to this point & quit diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs index 62cf22e15..f3a0a8f5a 100644 --- a/hledger-ui/Hledger/UI/RegisterScreen.hs +++ b/hledger-ui/Hledger/UI/RegisterScreen.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Hledger.UI.RegisterScreen @@ -199,7 +198,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}} -- inclusive = tree_ ropts || rsForceInclusive 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") <+> togglefilters <+> str " transactions" @@ -212,7 +211,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}} <+> str "/" <+> total <+> 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 togglefilters = case concat [ @@ -221,7 +220,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec}} ,if empty_ ropts then [] else ["nonzero"] ] of [] -> str "" - fs -> withAttr ("border" <> "query") (str $ " " ++ intercalate ", " fs) + fs -> withAttr (attrName "border" <> attrName "query") (str $ " " ++ intercalate ", " fs) cur = str $ case rsList ^. listSelectedL of Nothing -> "-" Just i -> show (i + 1) @@ -271,20 +270,21 @@ rsDrawItem (datewidth,descwidth,acctswidth,changewidth,balwidth) selected Regist where changeAmt = wbToText rsItemChangeAmount balanceAmt = wbToText rsItemBalanceAmount - changeattr | T.any (=='-') changeAmt = sel $ "list" <> "amount" <> "decrease" - | otherwise = sel $ "list" <> "amount" <> "increase" - balattr | T.any (=='-') balanceAmt = sel $ "list" <> "balance" <> "negative" - | otherwise = sel $ "list" <> "balance" <> "positive" - sel | selected = (<> "selected") + changeattr | T.any (=='-') changeAmt = sel $ attrName "list" <> attrName "amount" <> attrName "decrease" + | otherwise = sel $ attrName "list" <> attrName "amount" <> attrName "increase" + balattr | T.any (=='-') balanceAmt = sel $ attrName "list" <> attrName "balance" <> attrName "negative" + | otherwise = sel $ attrName "list" <> attrName "balance" <> attrName "positive" + sel | selected = (<> attrName "selected") | otherwise = id -rsHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) -rsHandle ui@UIState{ +rsHandle :: BrickEvent Name AppEvent -> EventM Name UIState () +rsHandle ev = do + ui@UIState{ aScreen=s@RegisterScreen{..} ,aopts=UIOpts{uoCliOpts=copts} ,ajournal=j ,aMode=mode - } ev = do + } <- get let d = copts^.rsDay journalspan = journalDateSpan False j @@ -294,50 +294,44 @@ rsHandle ui@UIState{ case mode of Minibuffer _ ed -> case ev of - VtyEvent (EvKey KEsc []) -> continue $ closeMinibuffer ui - VtyEvent (EvKey KEnter []) -> continue $ regenerateScreens j d $ + VtyEvent (EvKey KEsc []) -> modify closeMinibuffer + VtyEvent (EvKey KEnter []) -> put $ regenerateScreens j d $ case setFilter s $ closeMinibuffer ui of Left bad -> showMinibuffer "Cannot compile regular expression" (Just bad) ui Right ui' -> ui' where s = chomp . unlines . map strip $ getEditContents ed - -- VtyEvent (EvKey (KChar '/') []) -> continue $ regenerateScreens j d $ showMinibuffer ui - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + -- VtyEvent (EvKey (KChar '/') []) -> put $ regenerateScreens j d $ showMinibuffer ui + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent ev -> do - ed' <- handleEditorEvent -#if MIN_VERSION_brick(0,72,0) - (VtyEvent ev) -#else - ev -#endif - ed - continue $ ui{aMode=Minibuffer "filter" ed'} - AppEvent _ -> continue ui - MouseDown{} -> continue ui - MouseUp{} -> continue ui + ed' <- nestEventM' ed $ handleEditorEvent (VtyEvent ev) + put ui{aMode=Minibuffer "filter" ed'} + AppEvent _ -> return () + MouseDown{} -> return () + MouseUp{} -> return () Help -> case ev of - -- VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + -- VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui - _ -> helpHandle ui ev + _ -> helpHandle ev Normal -> case ev of - VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey KEsc []) -> continue $ resetScreens d ui - VtyEvent (EvKey (KChar c) []) | c == '?' -> continue $ setMode Help ui + VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey KEsc []) -> put $ resetScreens d ui + VtyEvent (EvKey (KChar c) []) | c == '?' -> put $ setMode Help ui 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 p = reportPeriod ui e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> - liftIO (uiReloadJournal copts d ui) >>= continue - VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) + liftIO (uiReloadJournal copts d ui) >>= put + 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 $ 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 where (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 'F') []) -> rsCenterAndContinue $ regenerateScreens j d $ toggleForecast d ui - VtyEvent (EvKey (KChar '/') []) -> continue $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui - VtyEvent (EvKey (KDown) [MShift]) -> continue $ regenerateScreens j d $ shrinkReportPeriod d ui - VtyEvent (EvKey (KUp) [MShift]) -> continue $ regenerateScreens j d $ growReportPeriod d ui - VtyEvent (EvKey (KRight) [MShift]) -> continue $ regenerateScreens j d $ nextReportPeriod journalspan ui - VtyEvent (EvKey (KLeft) [MShift]) -> continue $ regenerateScreens j d $ previousReportPeriod journalspan ui - VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (continue $ regenerateScreens j d $ resetFilter ui) - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle rsList >> redraw ui + VtyEvent (EvKey (KChar '/') []) -> put $ regenerateScreens j d $ showMinibuffer "filter" Nothing ui + VtyEvent (EvKey (KDown) [MShift]) -> put $ regenerateScreens j d $ shrinkReportPeriod d ui + VtyEvent (EvKey (KUp) [MShift]) -> put $ regenerateScreens j d $ growReportPeriod d ui + VtyEvent (EvKey (KRight) [MShift]) -> put $ regenerateScreens j d $ nextReportPeriod journalspan ui + VtyEvent (EvKey (KLeft) [MShift]) -> put $ regenerateScreens j d $ previousReportPeriod journalspan ui + VtyEvent (EvKey k []) | k `elem` [KBS, KDel] -> (put $ regenerateScreens j d $ resetFilter ui) + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> scrollSelectionToMiddle rsList >> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui -- 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. - 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. - 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 -- enter transaction screen on RIGHT VtyEvent e | e `elem` moveRightEvents -> case listSelectedElement rsList of - Just _ -> continue $ screenEnter d transactionScreen{tsAccount=rsAccount} ui - Nothing -> continue ui + Just _ -> put $ screenEnter d transactionScreen{tsAccount=rsAccount} ui + Nothing -> put ui -- or on transaction click -- MouseDown is sometimes duplicated, https://github.com/jtdaugherty/brick/issues/347 -- just use it to move the selection MouseDown _n BLeft _mods Location{loc=(_x,y)} | not $ (=="") clickeddate -> do - continue $ ui{aScreen=s{rsList=listMoveTo y rsList}} + put $ ui{aScreen=s{rsList=listMoveTo y rsList}} where clickeddate = maybe "" rsItemDate $ listElements rsList !? y -- and on MouseUp, enter the subscreen 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 -- when selection is at the last item, DOWN scrolls instead of moving, until maximally scrolled VtyEvent e | e `elem` moveDownEvents, isBlankElement mnextelement -> do - vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> continue ui + vScrollBy (viewportScroll $ rsList ^. listNameL) 1 >> put ui where mnextelement = listSelectedElement $ listMoveDown rsList -- mouse scroll wheel scrolls the viewport up or down to its maximum extent, -- pushing the selection when necessary. MouseDown name btn _mods _loc | btn `elem` [BScrollUp, BScrollDown] -> do let scrollamt = if btn==BScrollUp then -1 else 1 - list' <- listScrollPushingSelection name rsList (rsListSize rsList) scrollamt - continue ui{aScreen=s{rsList=list'}} + list' <- nestEventM' rsList $ listScrollPushingSelection name (rsListSize rsList) scrollamt + put ui{aScreen=s{rsList=list'}} -- if page down or end leads to a blank padding item, stop at last non-blank VtyEvent e@(EvKey k []) | k `elem` [KPageDown, KEnd] -> do - list <- handleListEvent e rsList + list <- nestEventM' rsList $ handleListEvent e if isBlankElement $ listSelectedElement list then do let list' = listMoveTo lastnonblankidx list scrollSelectionToMiddle list' - continue ui{aScreen=s{rsList=list'}} + put ui{aScreen=s{rsList=list'}} 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) VtyEvent ev -> do let ev' = normaliseMovementKeys ev - newitems <- handleListEvent ev' rsList - continue ui{aScreen=s{rsList=newitems}} + newitems <- nestEventM' rsList $ handleListEvent ev' + put ui{aScreen=s{rsList=newitems}} - MouseDown{} -> continue ui - MouseUp{} -> continue ui - AppEvent _ -> continue ui - -rsHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL: + MouseDown{} -> put ui + MouseUp{} -> put ui + AppEvent _ -> put ui isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just "" rsCenterAndContinue ui = do scrollSelectionToMiddle $ rsList $ aScreen ui - continue ui + put ui rsListSize = V.length . V.takeWhile ((/="").rsItemDate) . listElements diff --git a/hledger-ui/Hledger/UI/Theme.hs b/hledger-ui/Hledger/UI/Theme.hs index 804c4deb6..88cf5e595 100644 --- a/hledger-ui/Hledger/UI/Theme.hs +++ b/hledger-ui/Hledger/UI/Theme.hs @@ -65,42 +65,42 @@ select = black `on` selectbg themesList :: [(String, AttrMap)] themesList = [ ("default", attrMap (black `on` white) [ - ("border" , white `on` black & dim) - ,("border" <> "bold" , currentAttr & bold) - ,("border" <> "depth" , active) - ,("border" <> "filename" , currentAttr) - ,("border" <> "key" , active) - ,("border" <> "minibuffer" , white `on` black & bold) - ,("border" <> "query" , active) - ,("border" <> "selected" , active) - ,("error" , fg red) - ,("help" , white `on` black & dim) - ,("help" <> "heading" , fg yellow) - ,("help" <> "key" , active) - -- ,("list" , black `on` white) - -- ,("list" <> "amount" , currentAttr) - ,("list" <> "amount" <> "decrease" , fg red) - -- ,("list" <> "amount" <> "increase" , fg green) - ,("list" <> "amount" <> "decrease" <> "selected" , red `on` selectbg & bold) - -- ,("list" <> "amount" <> "increase" <> "selected" , green `on` selectbg & bold) - ,("list" <> "balance" , currentAttr & bold) - ,("list" <> "balance" <> "negative" , fg red) - ,("list" <> "balance" <> "positive" , fg black) - ,("list" <> "balance" <> "negative" <> "selected" , red `on` selectbg & bold) - ,("list" <> "balance" <> "positive" <> "selected" , select & bold) - ,("list" <> "selected" , select) - -- ,("list" <> "accounts" , white `on` brightGreen) - -- ,("list" <> "selected" , black `on` brightYellow) + (attrName "border" , white `on` black & dim) + ,(attrName "border" <> attrName "bold" , currentAttr & bold) + ,(attrName "border" <> attrName "depth" , active) + ,(attrName "border" <> attrName "filename" , currentAttr) + ,(attrName "border" <> attrName "key" , active) + ,(attrName "border" <> attrName "minibuffer" , white `on` black & bold) + ,(attrName "border" <> attrName "query" , active) + ,(attrName "border" <> attrName "selected" , active) + ,(attrName "error" , fg red) + ,(attrName "help" , white `on` black & dim) + ,(attrName "help" <> attrName "heading" , fg yellow) + ,(attrName "help" <> attrName "key" , active) + -- ,(attrName "list" , black `on` white) + -- ,(attrName "list" <> attrName "amount" , currentAttr) + ,(attrName "list" <> attrName "amount" <> attrName "decrease" , fg red) + -- ,(attrName "list" <> attrName "amount" <> attrName "increase" , fg green) + ,(attrName "list" <> attrName "amount" <> attrName "decrease" <> attrName "selected" , red `on` selectbg & bold) + -- ,(attrName "list" <> attrName "amount" <> attrName "increase" <> attrName "selected" , green `on` selectbg & bold) + ,(attrName "list" <> attrName "balance" , currentAttr & bold) + ,(attrName "list" <> attrName "balance" <> attrName "negative" , fg red) + ,(attrName "list" <> attrName "balance" <> attrName "positive" , fg black) + ,(attrName "list" <> attrName "balance" <> attrName "negative" <> attrName "selected" , red `on` selectbg & bold) + ,(attrName "list" <> attrName "balance" <> attrName "positive" <> attrName "selected" , select & bold) + ,(attrName "list" <> attrName "selected" , select) + -- ,(attrName "list" <> attrName "accounts" , white `on` brightGreen) + -- ,(attrName "list" <> attrName "selected" , black `on` brightYellow) ]) ,("greenterm", attrMap (green `on` black) [ - ("list" <> "selected" , black `on` green) + (attrName "list" <> attrName "selected" , black `on` green) ]) ,("terminal", attrMap defAttr [ - ("border" , white `on` black), - ("list" , defAttr), - ("list" <> "selected" , defAttr & reverseVideo) + (attrName "border" , white `on` black), + (attrName "list" , defAttr), + (attrName "list" <> attrName "selected" , defAttr & reverseVideo) ]) ] diff --git a/hledger-ui/Hledger/UI/TransactionScreen.hs b/hledger-ui/Hledger/UI/TransactionScreen.hs index 8fb0d81b4..e0bc1a442 100644 --- a/hledger-ui/Hledger/UI/TransactionScreen.hs +++ b/hledger-ui/Hledger/UI/TransactionScreen.hs @@ -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 (tindex t)) <+> str " (" - <+> withAttr ("border" <> "bold") (str $ show i) + <+> withAttr (attrName "border" <> attrName "bold") (str $ show i) <+> str (" of "++show (length nts)) <+> togglefilters <+> borderQueryStr (unwords . map (quoteIfNeeded . T.unpack) $ querystring_ ropts) <+> 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 togglefilters = case concat [ @@ -121,7 +121,7 @@ tsDraw UIState{aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec ,if empty_ ropts then [] else ["nonzero"] ] of [] -> str "" - fs -> withAttr ("border" <> "query") (str $ " " ++ intercalate ", " fs) + fs -> withAttr (attrName "border" <> attrName "query") (str $ " " ++ intercalate ", " fs) bottomlabel = quickhelp -- 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: -tsHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) -tsHandle ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransactions=nts} +tsHandle :: BrickEvent Name AppEvent -> EventM Name UIState () +tsHandle ev = do + ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransactions=nts} ,aopts=UIOpts{uoCliOpts=copts@CliOpts{reportspec_=rspec@ReportSpec{_rsReportOpts=ropts}}} ,ajournal=j ,aMode=mode - } - ev = + } <- get case mode of Help -> case ev of - -- VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + -- VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui - _ -> helpHandle ui ev + _ -> helpHandle ev _ -> do 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 (inext,tnext) = maybe (i,t) ((i+1),) $ lookup (i+1) nts case ev of - VtyEvent (EvKey (KChar 'q') []) -> halt ui - VtyEvent (EvKey KEsc []) -> continue $ resetScreens d ui - VtyEvent (EvKey (KChar c) []) | c == '?' -> continue $ setMode Help ui + VtyEvent (EvKey (KChar 'q') []) -> halt + VtyEvent (EvKey KEsc []) -> put $ resetScreens d ui + VtyEvent (EvKey (KChar c) []) | c == '?' -> put $ setMode Help ui VtyEvent (EvKey (KChar 'E') []) -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui where (pos,f) = case tsourcepos t of (SourcePos f l1 c1,_) -> (Just (unPos l1, Just $ unPos c1),f) 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 p = reportPeriod ui e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> do -- plog (if e == AppEvent FileChange then "file change" else "manual reload") "" `seq` return () ej <- liftIO . runExceptT $ journalReload copts case ej of - Left err -> continue $ screenEnter d errorScreen{esError=err} ui - Right j' -> continue $ regenerateScreens j' d ui - VtyEvent (EvKey (KChar 'I') []) -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) + Left err -> put $ screenEnter d errorScreen{esError=err} ui + Right j' -> put $ regenerateScreens j' d ui + VtyEvent (EvKey (KChar 'I') []) -> put $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui) -- 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 - -- EvKey (KChar 'E') [] -> continue $ regenerateScreens j d $ stToggleEmpty ui - -- EvKey (KChar 'C') [] -> continue $ regenerateScreens j d $ stToggleCleared ui - -- EvKey (KChar 'R') [] -> continue $ regenerateScreens j d $ stToggleReal ui - VtyEvent (EvKey (KChar 'B') []) -> continue . regenerateScreens j d $ toggleConversionOp ui - VtyEvent (EvKey (KChar 'V') []) -> continue . regenerateScreens j d $ toggleValue ui + -- EvKey (KChar 'E') [] -> put $ regenerateScreens j d $ stToggleEmpty ui + -- EvKey (KChar 'C') [] -> put $ regenerateScreens j d $ stToggleCleared ui + -- EvKey (KChar 'R') [] -> put $ regenerateScreens j d $ stToggleReal ui + VtyEvent (EvKey (KChar 'B') []) -> put . regenerateScreens j d $ toggleConversionOp 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` moveDownEvents -> continue $ tsSelect inext tnext ui + VtyEvent e | e `elem` moveUpEvents -> put $ tsSelect iprev tprev ui + VtyEvent e | e `elem` moveDownEvents -> put $ tsSelect inext tnext ui -- 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. - 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. - 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 - VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw ui + VtyEvent (EvKey (KChar 'l') [MCtrl]) -> redraw VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui - _ -> continue ui - -tsHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL: + _ -> return () -- | Select a new transaction and update the previous register screen tsSelect i t ui@UIState{aScreen=s@TransactionScreen{}} = case aPrevScreens ui of diff --git a/hledger-ui/Hledger/UI/UITypes.hs b/hledger-ui/Hledger/UI/UITypes.hs index 5c0135e71..abf828ebf 100644 --- a/hledger-ui/Hledger/UI/UITypes.hs +++ b/hledger-ui/Hledger/UI/UITypes.hs @@ -33,6 +33,7 @@ Brick.defaultMain brickapp st {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -100,7 +101,7 @@ data Screen = AccountsScreen { sInit :: Day -> Bool -> UIState -> UIState -- ^ function to initialise or update this screen's state ,sDraw :: UIState -> [Widget Name] -- ^ brick renderer for this screen - ,sHandle :: 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: ,_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 "") @@ -108,7 +109,7 @@ data Screen = | RegisterScreen { sInit :: Day -> Bool -> UIState -> UIState ,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 ,rsAccount :: AccountName -- ^ the account this register is for @@ -119,7 +120,7 @@ data Screen = | TransactionScreen { sInit :: Day -> Bool -> UIState -> UIState ,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 ,tsTransactions :: [NumberedTransaction] -- ^ list of transactions we can step through @@ -128,7 +129,7 @@ data Screen = | ErrorScreen { sInit :: Day -> Bool -> UIState -> UIState ,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 } @@ -154,6 +155,10 @@ data RegisterScreenItem = RegisterScreenItem { } 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) -- dummy monoid instance needed make lenses work with List fields not common across constructors diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs index c3079ee83..8ce7b1796 100644 --- a/hledger-ui/Hledger/UI/UIUtils.hs +++ b/hledger-ui/Hledger/UI/UIUtils.hs @@ -35,7 +35,7 @@ import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Dialog 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 Data.Bifunctor (second) import Data.List @@ -60,6 +60,7 @@ suspendSignal :: IO () suspendSignal = return () #else import System.Posix.Signals +import Data.Vector (Vector) suspendSignal :: IO () suspendSignal = raiseSignal sigSTOP #endif @@ -68,12 +69,12 @@ suspendSignal = raiseSignal sigSTOP -- like control-z in bash, returning to the original shell prompt, -- and when resumed, continue where we left off. -- On windows, does nothing. -suspend :: s -> EventM a (Next s) +suspend :: Ord a => s -> EventM a s () suspend st = suspendAndResume $ suspendSignal >> return st --- | Tell vty to redraw the whole screen, and continue. -redraw :: s -> EventM a (Next s) -redraw st = getVtyHandle >>= liftIO . refresh >> continue st +-- | Tell vty to redraw the whole screen. +redraw :: EventM a s () +redraw = getVtyHandle >>= liftIO . refresh -- | Wrap a widget in the default hledger-ui screen layout. defaultLayout :: Widget Name -> Widget Name -> Widget Name -> Widget Name @@ -90,14 +91,14 @@ helpDialog _copts = Widget Fixed Fixed $ do c <- getContext render $ - withDefAttr "help" $ + withDefAttr (attrName "help") $ 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) $ vBox [ hBox [ padRight (Pad 1) $ 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", "") ,str " move selection up/down" ,renderKey ("RIGHT/l/C-f", "show txns, or txn detail") @@ -105,23 +106,23 @@ helpDialog _copts = ,renderKey ("ESC ", "cancel, or reset app state") ,str " " - ,withAttr ("help" <> "heading") $ str "Accounts screen" + ,withAttr (attrName "help" <> attrName "heading") $ str "Accounts screen" ,renderKey ("1234567890-+ ", "set/adjust depth limit") ,renderKey ("t ", "toggle accounts tree/list mode") ,renderKey ("H ", "toggle historical balance/change") ,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 ("H ", "toggle historical/period total") ,str " " - ,withAttr ("help" <> "heading") $ str "Help" + ,withAttr (attrName "help" <> attrName "heading") $ str "Help" ,renderKey ("? ", "toggle this help") ,renderKey ("p/m/i", "while help is open:\nshow manual in pager/man/info") ,str " " ] ,padLeft (Pad 1) $ padRight (Pad 0) $ vBox [ - withAttr ("help" <> "heading") $ str "Filtering" + withAttr (attrName "help" <> attrName "heading") $ str "Filtering" ,renderKey ("/ ", "set a filter query") ,renderKey ("F ", "show future & periodic txns") ,renderKey ("R ", "show real/all postings") @@ -132,7 +133,7 @@ helpDialog _copts = ,renderKey ("T ", "set period to today") ,renderKey ("DEL ", "reset filters") ,str " " - ,withAttr ("help" <> "heading") $ str "Other" + ,withAttr (attrName "help" <> attrName "heading") $ str "Other" ,renderKey ("a ", "add transaction (hledger add)") ,renderKey ("A ", "add transaction (hledger-iadd)") ,renderKey ("B ", "show amounts/costs") @@ -160,39 +161,40 @@ helpDialog _copts = -- ] ] 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. -- 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 ui ev = do +helpHandle :: BrickEvent Name AppEvent -> EventM Name UIState () +helpHandle ev = do + ui <- get + let ui' = setMode Normal ui 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 'm') []) -> suspendAndResume $ runManForTopic "hledger-ui" Nothing >> return ui' VtyEvent (EvKey (KChar 'i') []) -> suspendAndResume $ runInfoForTopic "hledger-ui" Nothing >> return ui' - _ -> continue ui + _ -> return () where - ui' = setMode Normal ui closeHelpEvents = moveLeftEvents ++ [EvKey KEsc [], EvKey (KChar '?') [], EvKey (KChar 'q') []] -- | Draw the minibuffer with the given label. minibuffer :: T.Text -> Editor String Name -> Widget Name minibuffer string ed = - forceAttr ("border" <> "minibuffer") $ + forceAttr (attrName "border" <> attrName "minibuffer") $ hBox [txt $ string <> ": ", renderEditor (str . unlines) True ed] borderQueryStr :: String -> Widget Name 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 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 _ 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 = borderKeysStr' . map (second str) @@ -201,7 +203,7 @@ borderKeysStr' :: [(String,Widget Name)] -> Widget Name borderKeysStr' keydescs = hBox $ 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 -- sep = str " | " sep = str " " @@ -209,7 +211,7 @@ borderKeysStr' keydescs = -- | Show both states of a toggle ("aaa/bbb"), highlighting the active one. renderToggle :: Bool -> String -> String -> Widget Name renderToggle isright l r = - let bold = withAttr ("border" <> "selected") in + let bold = withAttr (attrName "border" <> attrName "selected") in if isright then str (l++"/") <+> bold (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. renderToggle1 :: Bool -> String -> Widget Name renderToggle1 isactive l = - let bold = withAttr ("border" <> "selected") in + let bold = withAttr (attrName "border" <> attrName "selected") in if isactive then bold (str l) else str l @@ -262,11 +264,11 @@ topBottomBorderWithLabels toplabel bottomlabel body = "" -- " debug: "++show (_w,h') render $ - hBorderWithLabel (withAttr "border" $ toplabel <+> str debugmsg) + hBorderWithLabel (withAttr (attrName "border") $ toplabel <+> str debugmsg) <=> body' <=> - hBorderWithLabel (withAttr "border" bottomlabel) + hBorderWithLabel (withAttr (attrName "border") bottomlabel) ---- XXX should be equivalent to the above, but isn't (page down goes offscreen) --_topBottomBorderWithLabel2 :: Widget Name -> Widget Name -> Widget Name @@ -303,7 +305,7 @@ margin h v mcolour w = Widget Greedy Greedy $ do -- applyN n border 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. ---- 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 -- middle of the display area. -scrollSelectionToMiddle :: List Name e -> EventM Name () +scrollSelectionToMiddle :: List Name item -> EventM Name UIState () scrollSelectionToMiddle list = do case list^.listSelectedL of 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 -- 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. -listScrollPushingSelection :: (Ord n, Foldable t, Splittable t) => - n -> GenericList n t e -> Int -> Int -> EventM n (GenericList n t e) -listScrollPushingSelection name list listheight scrollamt = do +listScrollPushingSelection :: Name -> Int -> Int -> EventM Name (List Name item) (GenericList Name Vector item) +listScrollPushingSelection name listheight scrollamt = do + list <- get viewportScroll name `vScrollBy` scrollamt mvp <- lookupViewport name case mvp of diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index 8c341b038..5ef31c665 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -68,7 +68,7 @@ executable hledger-ui ansi-terminal >=0.9 , async , base >=4.11 && <4.17 - , brick >=0.23 + , brick >=1.0 , cmdargs >=0.8 , containers >=0.5.9 , data-default diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index a3285141c..493fda8a3 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -76,7 +76,7 @@ dependencies: - transformers - vector # not installable on windows, cf buildable flag below -- brick >=0.23 && <1 +- brick >=1.0 - vty >=5.15 - unix diff --git a/stack.yaml b/stack.yaml index 0ded64182..595c808ca 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # stack build plan using GHC 9.2.4 -resolver: nightly-2022-08-04 +resolver: nightly-2022-08-14 packages: - hledger-lib @@ -8,10 +8,11 @@ packages: - hledger-ui - hledger-web -# extra-deps: +extra-deps: # for hledger-lib: # for hledger: # for hledger-ui: +- brick-1.0 # for hledger-web: # for Shake.hs: