diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +# 1.3.18 [2023-04-05] + + - dependencies: Update to hledger-lib 1.29 + - dependencies: Update to brick 1.5 + # 1.3.17 [2022-03-15] - dependencies: Support brick 0.68 diff --git a/hledger-iadd.cabal b/hledger-iadd.cabal --- a/hledger-iadd.cabal +++ b/hledger-iadd.cabal @@ -1,5 +1,5 @@ name: hledger-iadd -version: 1.3.17 +version: 1.3.18 synopsis: A terminal UI as drop-in replacement for hledger add description: This is a terminal UI as drop-in replacement for hledger add. . @@ -60,12 +60,13 @@ , Data.Time.Ext default-language: Haskell2010 build-depends: base >= 4.12 && < 5 - , hledger-lib >= 1.23 && < 1.26 - , brick >= 0.27 + , hledger-lib >= 1.29 && < 1.30 + , brick >= 1.5 , vty >= 5.4 , text , microlens , microlens-th + , microlens-mtl , text-zipper >= 0.10 , transformers >= 0.3 , time >= 1.5 @@ -86,11 +87,13 @@ default-language: Haskell2010 build-depends: base >= 4.12 && < 5 , hledger-iadd - , hledger-lib >= 1.23 && < 1.26 - , brick >= 0.27 + , hledger-lib >= 1.29 && <1.30 + , brick >= 1.5 , vty >= 5.4 , text , microlens + , microlens-th + , microlens-mtl , text-zipper >= 0.10 , transformers >= 0.3 , time >= 1.5 @@ -114,7 +117,7 @@ default-language: Haskell2010 build-depends: base >= 4.12 && < 5 , hledger-iadd - , hledger-lib >= 1.23 && < 1.26 + , hledger-lib >= 1.29 && <1.30 , text , transformers >= 0.3 , time >= 1.5 diff --git a/src/Brick/Widgets/CommentDialog.hs b/src/Brick/Widgets/CommentDialog.hs --- a/src/Brick/Widgets/CommentDialog.hs +++ b/src/Brick/Widgets/CommentDialog.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Brick.Widgets.CommentDialog ( CommentWidget @@ -9,8 +10,6 @@ , handleCommentEvent ) where -import Data.Semigroup ((<>)) - import Brick import Brick.Widgets.Dialog import Brick.Widgets.Center @@ -19,55 +18,60 @@ import qualified Data.Text as T import Data.Text (Text) +import Lens.Micro +import Lens.Micro.TH +import Lens.Micro.Mtl + import Brick.Widgets.Edit.EmacsBindings data CommentWidget n = CommentWidget - { origComment :: Text - , textArea :: Editor n - , dialogWidget :: Dialog () - , promptPrefix :: Text + { _origComment :: Text + , _textArea :: Editor n + , _dialogWidget :: Dialog () n + , _promptPrefix :: Text } -commentWidget :: n -> Text -> Text -> CommentWidget n +makeLenses ''CommentWidget + +commentWidget :: Eq n => n -> Text -> Text -> CommentWidget n commentWidget name prompt comment = let - title = "ESC: cancel, RET: accept, Alt-RET: New line" + title = txt "ESC: cancel, RET: accept, Alt-RET: New line" maxWidth = 80 diag = dialog (Just title) Nothing maxWidth edit = editorText name (txt . T.unlines) Nothing comment in CommentWidget - { origComment = comment - , textArea = applyEdit gotoEnd edit - , dialogWidget = diag - , promptPrefix = prompt + { _origComment = comment + , _textArea = applyEdit gotoEnd edit + , _dialogWidget = diag + , _promptPrefix = prompt } -data CommentAction n = CommentContinue (CommentWidget n) - | CommentFinished Text +data CommentAction = CommentContinue | CommentFinished Text -handleCommentEvent :: Event -> CommentWidget n -> EventM n (CommentAction n) -handleCommentEvent ev widget = case ev of - EvKey KEsc [] -> return $ CommentFinished (origComment widget) - EvKey KEnter [] -> return $ CommentFinished (commentDialogComment widget) - EvKey KEnter [MMeta] -> return $ CommentContinue $ - widget { textArea = applyEdit breakLine (textArea widget) } +handleCommentEvent :: Eq n => Event -> EventM n (CommentWidget n) CommentAction +handleCommentEvent ev = case ev of + EvKey KEsc [] -> CommentFinished <$> use origComment + EvKey KEnter [] -> CommentFinished <$> gets commentDialogComment + EvKey KEnter [MMeta] -> do + zoom textArea $ applyEditM breakLine + return CommentContinue _ -> do - textArea' <- handleEditorEvent ev (textArea widget) - return $ CommentContinue $ - CommentWidget (origComment widget) textArea' (dialogWidget widget) (promptPrefix widget) + zoom textArea $ handleEditorEvent ev + return CommentContinue renderCommentWidget :: (Ord n, Show n) => CommentWidget n -> Widget n renderCommentWidget widget = let - height = min (length (getEditContents (textArea widget)) + 4) 24 + height = min (length (getEditContents (widget^.textArea)) + 4) 24 textArea' = padTop (Pad 1) $ - txt (promptPrefix widget <> ": ") <+> renderEditor True (textArea widget) + txt (widget^.promptPrefix <> ": ") <+> renderEditor True (widget^.textArea) in - vCenterLayer $ vLimit height $ renderDialog (dialogWidget widget) textArea' + vCenterLayer $ vLimit height $ renderDialog (widget^.dialogWidget) textArea' commentDialogComment :: CommentWidget n -> Text -commentDialogComment = T.intercalate "\n" . getEditContents . textArea +commentDialogComment = T.intercalate "\n" . getEditContents . _textArea gotoEnd :: Monoid a => TextZipper a -> TextZipper a gotoEnd zipper = diff --git a/src/Brick/Widgets/Edit/EmacsBindings.hs b/src/Brick/Widgets/Edit/EmacsBindings.hs --- a/src/Brick/Widgets/Edit/EmacsBindings.hs +++ b/src/Brick/Widgets/Edit/EmacsBindings.hs @@ -10,6 +10,7 @@ ( Editor , editorText , getEditContents + , applyEditM , applyEdit , editContentsL , handleEditorEvent @@ -23,6 +24,7 @@ import Data.Text (Text) import Lens.Micro.TH import Lens.Micro +import Lens.Micro.Mtl import Data.Text.Zipper.Generic.Words @@ -49,8 +51,11 @@ -- | Wrapper for 'E.applyEdit' specialized to 'Text' applyEdit :: (TextZipper Text -> TextZipper Text) -> Editor n -> Editor n -applyEdit f = over origEditor (E.applyEdit f) +applyEdit f edit = edit & origEditor %~ E.applyEdit f +applyEditM :: (TextZipper Text -> TextZipper Text) -> EventM n (Editor n) () +applyEditM f = origEditor %= E.applyEdit f + -- | Wrapper for 'E.editContentsL' specialized to 'Text' editContentsL :: Lens (Editor n) (Editor n) (TextZipper Text) (TextZipper Text) editContentsL = origEditor . E.editContentsL @@ -67,24 +72,22 @@ -- - Alt-Backspace: Delete the previous word -- - Ctrl-w: Delete the previous word -- - Alt-d: Delete the next word -handleEditorEvent :: Event -> Editor n -> EventM n (Editor n) -handleEditorEvent event edit = case event of - EvKey (KChar 'f') [MCtrl] -> return $ applyEdit moveRight edit - EvKey (KChar 'b') [MCtrl] -> return $ applyEdit moveLeft edit +handleEditorEvent :: Eq n => Event -> EventM n (Editor n) () +handleEditorEvent event = case event of + EvKey (KChar 'f') [MCtrl] -> applyEditM moveRight + EvKey (KChar 'b') [MCtrl] -> applyEditM moveLeft - EvKey (KChar 'f') [MMeta] -> return $ applyEdit moveWordRight edit - EvKey (KChar 'b') [MMeta] -> return $ applyEdit moveWordLeft edit + EvKey (KChar 'f') [MMeta] -> applyEditM moveWordRight + EvKey (KChar 'b') [MMeta] -> applyEditM moveWordLeft - EvKey KBS [MMeta] -> return $ applyEdit deletePrevWord edit - EvKey (KChar 'w') [MCtrl] -> return $ applyEdit deletePrevWord edit - EvKey (KChar 'd') [MMeta] -> return $ applyEdit deleteWord edit + EvKey KBS [MMeta] -> applyEditM deletePrevWord + EvKey (KChar 'w') [MCtrl] -> applyEditM deletePrevWord + EvKey (KChar 'd') [MMeta] -> applyEditM deleteWord - EvKey KHome [] -> return $ applyEdit gotoBOL edit - EvKey KEnd [] -> return $ applyEdit gotoEOL edit + EvKey KHome [] -> applyEditM gotoBOL + EvKey KEnd [] -> applyEditM gotoEOL - _ -> do - newOrig <- E.handleEditorEvent event (edit^.origEditor) - return $ edit & origEditor .~ newOrig + _ -> zoom origEditor $ E.handleEditorEvent (VtyEvent event) -- | Wrapper for 'E.renderEditor' specialized to 'Text' diff --git a/src/Brick/Widgets/HelpMessage.hs b/src/Brick/Widgets/HelpMessage.hs --- a/src/Brick/Widgets/HelpMessage.hs +++ b/src/Brick/Widgets/HelpMessage.hs @@ -14,7 +14,6 @@ import Brick.Widgets.Border import Graphics.Vty import Data.Text (Text) -import Data.Monoid ((<>)) import Data.List import Lens.Micro @@ -63,32 +62,32 @@ scroller :: HelpWidget n -> ViewportScroll n scroller HelpWidget{name} = viewportScroll name -handleHelpEvent :: HelpWidget n -> Event -> EventM n (HelpWidget n) -handleHelpEvent help (EvKey k _) = case k of - KChar 'j' -> vScrollBy (scroller help) 1 >> return help - KDown -> vScrollBy (scroller help) 1 >> return help - KChar 'k' -> vScrollBy (scroller help) (-1) >> return help - KUp -> vScrollBy (scroller help) (-1) >> return help - KChar 'g' -> vScrollToBeginning (scroller help) >> return help - KHome -> vScrollToBeginning (scroller help) >> return help - KChar 'G' -> vScrollToEnd (scroller help) >> return help - KEnd -> vScrollToEnd (scroller help) >> return help - KPageUp -> vScrollPage (scroller help) Up >> return help - KPageDown -> vScrollPage (scroller help) Down >> return help - _ -> return help -handleHelpEvent help _ = return help +handleHelpEvent :: Event -> EventM n (HelpWidget n) () +handleHelpEvent (EvKey k _) = case k of + KChar 'j' -> gets scroller >>= \s -> vScrollBy s 1 + KDown -> gets scroller >>= \s -> vScrollBy s 1 + KChar 'k' -> gets scroller >>= \s -> vScrollBy s (-1) + KUp -> gets scroller >>= \s -> vScrollBy s (-1) + KChar 'g' -> gets scroller >>= \s -> vScrollToBeginning s + KHome -> gets scroller >>= \s -> vScrollToBeginning s + KChar 'G' -> gets scroller >>= \s -> vScrollToEnd s + KEnd -> gets scroller >>= \s -> vScrollToEnd s + KPageUp -> gets scroller >>= \s -> vScrollPage s Up + KPageDown -> gets scroller >>= \s -> vScrollPage s Down + _ -> return () +handleHelpEvent _ = return () -resetHelpWidget :: HelpWidget n -> EventM n () +resetHelpWidget :: HelpWidget n -> EventM n s () resetHelpWidget = vScrollToBeginning . scroller key :: Text -> Text -> Widget n -key k h = withAttr (helpAttr <> "key") (txt (" " <> k)) - <+> padLeft Max (withAttr (helpAttr <> "description") (txt h)) +key k h = withAttr (helpAttr <> attrName "key") (txt (" " <> k)) + <+> padLeft Max (withAttr (helpAttr <> attrName "description") (txt h)) helpAttr :: AttrName -helpAttr = "help" +helpAttr = attrName "help" section :: Title -> [(Text, Text)] -> Widget n -section title keys = withAttr (helpAttr <> "title") (txt (title <> ":")) +section title keys = withAttr (helpAttr <> attrName "title") (txt (title <> ":")) <=> vBox (map (uncurry key) keys) diff --git a/src/ConfigParser.hs b/src/ConfigParser.hs --- a/src/ConfigParser.hs +++ b/src/ConfigParser.hs @@ -49,7 +49,6 @@ import Control.Applicative.Free import Control.Monad import Data.Functor.Identity -import Data.Semigroup ((<>)) import qualified Data.List.NonEmpty as NE import qualified Data.Set as S diff --git a/src/DateParser.hs b/src/DateParser.hs --- a/src/DateParser.hs +++ b/src/DateParser.hs @@ -32,9 +32,10 @@ import Data.Text.Lazy.Builder (Builder, toLazyText) import qualified Data.Text.Lazy.Builder as Build import qualified Data.Text.Lazy.Builder.Int as Build -import Data.Time.Ext hiding (parseTime) +import Data.Time.Ext import Data.Time.Calendar.WeekDate import qualified Hledger.Data.Dates as HL +import qualified Hledger.Data.Types as HL import Text.Megaparsec import Text.Megaparsec.Char import Text.Printf (printf, PrintfArg) @@ -55,7 +56,9 @@ parseHLDate :: Day -> Text -> Either Text Day parseHLDate current text = case parse HL.smartdate "date" text of - Right res -> Right $ HL.fixSmartDate current res + Right res -> case HL.fixSmartDate current res of + HL.Exact day -> Right day + HL.Flex day -> Left $ "Date " <> T.pack (show day) <> " not specified exactly." Left err -> Left $ T.pack $ errorBundlePretty err parseHLDateWithToday :: Text -> IO (Either Text Day) diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -28,7 +28,7 @@ import Data.Ord (Down(..)) import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Ext hiding (parseTime) +import Data.Time.Ext import qualified Hledger as HL import Data.Foldable import Control.Applicative @@ -232,7 +232,7 @@ let unusedPostings = filter (`notContainedIn` curPostings) refPostings in listToMaybe unusedPostings - where [refPostings, curPostings] = map HL.tpostings [reference, current] + where (refPostings, curPostings) = (HL.tpostings reference, HL.tpostings current) notContainedIn p = not . any (((==) `on` HL.paccount) p) -- | Given the last transaction entered, suggest the likely most comparable posting @@ -249,7 +249,7 @@ Just (refPostings !! postingsEntered) else suggestNextPosting current reference - where [refPostings, curPostings] = map HL.tpostings [reference, current] + where (refPostings, curPostings) = (HL.tpostings reference, HL.tpostings current) findLastSimilar :: HL.Journal -> HL.Transaction -> Maybe HL.Transaction findLastSimilar journal desc = diff --git a/src/View.hs b/src/View.hs --- a/src/View.hs +++ b/src/View.hs @@ -12,7 +12,6 @@ import Brick import Brick.Widgets.List import Brick.Widgets.WrappedText -import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Hledger as HL diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -2,14 +2,15 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import Brick - ( Widget, App(..), AttrMap, BrickEvent(..), Next, EventM - , (<=>), (<+>), txt, continue, halt, attrMap, on, fg + ( Widget, App(..), AttrMap, BrickEvent(..), EventM + , (<=>), (<+>), txt, halt, attrMap, on, fg , defaultMain, showFirstCursor, padBottom, Padding(Max,Pad) - , padAll, padLeft + , padAll, padLeft, nestEventM', nestEventM, modify, gets, get, attrName ) import Brick.Widgets.BetterDialog (dialog) import Brick.Widgets.Border (hBorder) @@ -31,7 +32,7 @@ import Control.Monad.Trans.Except (runExceptT) import Data.Functor.Identity (Identity(..), runIdentity) import Data.Maybe (fromMaybe, fromJust) -import Data.Monoid ((<>), First(..), getFirst) +import Data.Monoid (First(..), getFirst) import qualified Data.Semigroup as Sem import Data.Text (Text) import qualified Data.Text as T @@ -40,7 +41,8 @@ import qualified Data.Vector as V import qualified Hledger as HL import qualified Hledger.Read.JournalReader as HL -import Lens.Micro ((&), (.~)) +import Lens.Micro ((&), (.~), (^.), (%~)) +import Lens.Micro.Mtl import qualified Options.Applicative as OA import Options.Applicative ( ReadM, Parser, value, help, long, metavar, switch, helper, fullDesc, info @@ -62,22 +64,11 @@ import Model import View +import Lens.Micro.TH + import Data.Version (showVersion) import qualified Paths_hledger_iadd as Paths -data AppState = AppState - { asEditor :: Editor Name - , asStep :: Step - , asJournal :: HL.Journal - , asContext :: List Name Text - , asSuggestion :: Maybe Text - , asMessage :: Text - , asFilename :: FilePath - , asDateFormat :: DateFormat - , asMatchAlgo :: MatchAlgo - , asDialog :: DialogShown - , asInputHistory :: [Text] - } data Name = HelpName | ListName | EditorName | CommentName deriving (Ord, Show, Eq) @@ -94,6 +85,25 @@ | AbortDialog | CommentDialog CommentType (CommentWidget Name) + + +data AppState = AppState + { _asEditor :: Editor Name + , _asStep :: Step + , _asJournal :: HL.Journal + , _asContext :: List Name Text + , _asSuggestion :: Maybe Text + , _asMessage :: Text + , _asFilename :: FilePath + , _asDateFormat :: DateFormat + , _asMatchAlgo :: MatchAlgo + , _asDialog :: DialogShown + , _asInputHistory :: [Text] + } + +makeLenses ''AppState + + myHelpDialog :: DialogShown myHelpDialog = HelpDialog (helpWidget HelpName bindings) @@ -123,7 +133,7 @@ ])] draw :: AppState -> [Widget Name] -draw as = case asDialog as of +draw as = case as^.asDialog of HelpDialog h -> [renderHelpWidget h, ui] QuitDialog -> [quitDialog, ui] AbortDialog -> [abortDialog, ui] @@ -131,16 +141,16 @@ NoDialog -> [ui] where ui = txt "New Transaction:" - <=> padAll 1 (borderLeft $ padLeft (Pad 1) $ viewState (asStep as)) + <=> padAll 1 (borderLeft $ padLeft (Pad 1) $ viewState (as^.asStep)) <=> hBorder - <=> (viewQuestion (asStep as) - <+> viewSuggestion (asSuggestion as) + <=> (viewQuestion (as^.asStep) + <+> viewSuggestion (as^.asSuggestion) <+> txt ": " - <+> renderEditor True (asEditor as)) + <+> renderEditor True (as^.asEditor)) <=> hBorder - <=> expand (viewContext (asContext as)) + <=> expand (viewContext (as^.asContext)) <=> hBorder - <=> viewMessage (asMessage as) + <=> viewMessage (as^.asMessage) quitDialog = dialog "Quit" "Really quit without saving the current transaction? (Y/n)" abortDialog = dialog "Abort" "Really abort this transaction (Y/n)" @@ -150,99 +160,96 @@ setComment CurrentComment = setCurrentComment -- TODO Refactor to remove code duplication in individual case statements -event :: AppState -> BrickEvent Name Event -> EventM Name (Next AppState) -event as (VtyEvent ev) = case asDialog as of +event :: BrickEvent Name Event -> EventM Name AppState () +event (VtyEvent ev) = use asDialog >>= \case HelpDialog helpDia -> case ev of EvKey key [] - | key `elem` [KChar 'q', KEsc] -> continue as { asDialog = NoDialog } + | key `elem` [KChar 'q', KEsc] -> asDialog .= NoDialog | otherwise -> do - helpDia' <- handleHelpEvent helpDia ev - continue as { asDialog = HelpDialog helpDia' } - _ -> continue as + nestEventM' helpDia (handleHelpEvent ev) >>= assign asDialog . HelpDialog + _ -> return () QuitDialog -> case ev of EvKey key [] - | key `elem` [KChar 'y', KEnter] -> halt as - | otherwise -> continue as { asDialog = NoDialog } - _ -> continue as + | key `elem` [KChar 'y', KEnter] -> halt + | otherwise -> asDialog .= NoDialog + _ -> return () AbortDialog -> case ev of EvKey key [] - | key `elem` [KChar 'y', KEnter] -> - liftIO (reset as { asDialog = NoDialog }) >>= continue - | otherwise -> continue as { asDialog = NoDialog } - _ -> continue as - CommentDialog typ dia -> handleCommentEvent ev dia >>= \case - CommentContinue dia' -> - continue as { asDialog = CommentDialog typ dia' - , asStep = setComment typ (commentDialogComment dia') (asStep as) - } - CommentFinished comment -> - continue as { asDialog = NoDialog - , asStep = setComment typ comment (asStep as) - } + | key `elem` [KChar 'y', KEnter] -> do + asDialog .= NoDialog + reset + | otherwise -> asDialog .= NoDialog + _ -> return () + CommentDialog typ dia -> nestEventM dia (handleCommentEvent ev) >>= \case + (dia', CommentContinue) -> do + asDialog .= CommentDialog typ dia' + asStep %= setComment typ (commentDialogComment dia') + (_, CommentFinished comment) -> do + asDialog .= NoDialog + asStep %= setComment typ comment NoDialog -> case ev of - EvKey (KChar 'c') [MCtrl] -> case asStep as of - DateQuestion _ -> halt as - _ -> continue as { asDialog = QuitDialog } - EvKey (KChar 'd') [MCtrl] -> case asStep as of - DateQuestion _ -> halt as - _ -> continue as { asDialog = QuitDialog } - EvKey (KChar 'n') [MCtrl] -> continue as { asContext = listMoveDown $ asContext as - , asMessage = ""} - EvKey KDown [] -> continue as { asContext = listMoveDown $ asContext as - , asMessage = ""} - EvKey (KChar 'p') [MCtrl] -> continue as { asContext = listMoveUp $ asContext as - , asMessage = ""} - EvKey KUp [] -> continue as { asContext = listMoveUp $ asContext as - , asMessage = ""} - EvKey (KChar '\t') [] -> continue (insertSelected as) - EvKey (KChar ';') [] -> - continue as { asDialog = myCommentDialog CurrentComment (getCurrentComment (asStep as)) } - EvKey (KChar ';') [MMeta] -> - continue as { asDialog = myCommentDialog TransactionComment (getTransactionComment (asStep as)) } - EvKey KEsc [] -> case asStep as of - DateQuestion _ - | T.null (editText as) -> halt as - | otherwise -> liftIO (reset as) >>= continue - _ -> continue as { asDialog = AbortDialog } - EvKey (KChar 'z') [MCtrl] -> liftIO (doUndo as) >>= continue - EvKey KEnter [MMeta] -> liftIO (doNextStep False as) >>= continue - EvKey KEnter [] -> liftIO (doNextStep True as) >>= continue - EvKey (KFun 1) [] -> continue as { asDialog = myHelpDialog } - EvKey (KChar '?') [MMeta] -> continue as { asDialog = myHelpDialog, asMessage = "Help" } - _ -> (AppState <$> handleEditorEvent ev (asEditor as) - <*> return (asStep as) - <*> return (asJournal as) - <*> return (asContext as) - <*> return (asSuggestion as) - <*> return "" - <*> return (asFilename as)) - <*> return (asDateFormat as) - <*> return (asMatchAlgo as) - <*> return NoDialog - <*> return (asInputHistory as) - >>= liftIO . setContext >>= continue -event as _ = continue as + EvKey (KChar 'c') [MCtrl] -> use asStep >>= \case + DateQuestion _ -> halt + _ -> asDialog .= QuitDialog + EvKey (KChar 'd') [MCtrl] -> use asStep >>= \case + DateQuestion _ -> halt + _ -> asDialog .= QuitDialog + EvKey (KChar 'n') [MCtrl] -> do + asContext %= listMoveDown + asMessage .= "" + EvKey KDown [] -> do + asContext %= listMoveDown + asMessage .= "" + EvKey (KChar 'p') [MCtrl] -> do + asContext %= listMoveUp + asMessage .= "" + EvKey KUp [] -> do + asContext %= listMoveUp + asMessage .= "" + EvKey (KChar '\t') [] -> modify insertSelected + EvKey (KChar ';') [] -> do + step <- use asStep + asDialog .= myCommentDialog CurrentComment (getCurrentComment step) + EvKey (KChar ';') [MMeta] -> do + step <- use asStep + asDialog .= myCommentDialog TransactionComment (getTransactionComment step) + EvKey KEsc [] -> use asStep >>= \case + DateQuestion _ -> do + t <- gets editText + if T.null t then halt else reset + _ -> asDialog .= AbortDialog + EvKey (KChar 'z') [MCtrl] -> doUndo + EvKey KEnter [MMeta] -> doNextStep False + EvKey KEnter [] -> doNextStep True + EvKey (KFun 1) [] -> asDialog .= myHelpDialog + EvKey (KChar '?') [MMeta] -> asDialog .= myHelpDialog >> asMessage .= "Help" + _ -> do + zoom asEditor $ handleEditorEvent ev + setContext +event _ = return () -reset :: AppState -> IO AppState -reset as = do - sugg <- suggest (asJournal as) (asDateFormat as) (DateQuestion "") - return as - { asStep = DateQuestion "" - , asEditor = clearEdit (asEditor as) - , asContext = ctxList V.empty - , asSuggestion = sugg - , asMessage = "Transaction aborted" - } +reset :: EventM n AppState () +reset = do + as <- get + sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) (DateQuestion "") + + asStep .= DateQuestion "" + asEditor %= clearEdit + asContext .= ctxList V.empty + asSuggestion .= sugg + asMessage .= "Transaction aborted" -setContext :: AppState -> IO AppState -setContext as = do - ctx <- flip listSimpleReplace (asContext as) . V.fromList <$> - context (asJournal as) (asMatchAlgo as) (asDateFormat as) (editText as) (asStep as) - return as { asContext = ctx } +setContext :: EventM n AppState () +setContext = do + as <- get + newCtx <- liftIO $ context (as^.asJournal) (as^.asMatchAlgo) (as^.asDateFormat) (editText as) (as^.asStep) + asContext %= listSimpleReplace (V.fromList newCtx) + + editText :: AppState -> Text -editText = T.concat . getEditContents . asEditor +editText = T.concat . getEditContents . _asEditor -- | Add a tranaction at the end of a journal -- @@ -251,74 +258,71 @@ addTransactionEnd :: HL.Transaction -> HL.Journal -> HL.Journal addTransactionEnd t j = j { HL.jtxns = HL.jtxns j ++ [t] } -doNextStep :: Bool -> AppState -> IO AppState -doNextStep useSelected as = do +doNextStep :: Bool -> EventM n AppState () +doNextStep useSelected = do + as <- get let inputText = editText as name = fromMaybe (Left inputText) $ - msum [ Right <$> if useSelected then snd <$> listSelectedElement (asContext as) else Nothing + msum [ Right <$> if useSelected then snd <$> listSelectedElement (as^.asContext) else Nothing , Left <$> asMaybe (editText as) - , Left <$> asSuggestion as + , Left <$> as^.asSuggestion ] - s <- nextStep (asJournal as) (asDateFormat as) name (asStep as) + s <- liftIO $ nextStep (as^.asJournal) (as^.asDateFormat) name (as^.asStep) case s of - Left err -> return as { asMessage = err } + Left err -> asMessage .= err Right (Finished trans) -> do - liftIO $ addToJournal trans (asFilename as) - sugg <- suggest (asJournal as) (asDateFormat as) (DateQuestion "") - return AppState - { asStep = DateQuestion "" - , asJournal = addTransactionEnd trans (asJournal as) - , asEditor = clearEdit (asEditor as) - , asContext = ctxList V.empty - , asSuggestion = sugg - , asMessage = "Transaction written to journal file" - , asFilename = asFilename as - , asDateFormat = asDateFormat as - , asMatchAlgo = asMatchAlgo as - , asDialog = NoDialog - , asInputHistory = [] - } + liftIO $ addToJournal trans (as^.asFilename) + sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) (DateQuestion "") + asStep .= DateQuestion "" + asJournal %= addTransactionEnd trans + asEditor %= clearEdit + asContext .= ctxList V.empty + asSuggestion .= sugg + asMessage .= "Transaction written to journal file" + asDialog .= NoDialog + asInputHistory .= [] Right (Step s') -> do - sugg <- suggest (asJournal as) (asDateFormat as) s' - ctx' <- ctxList . V.fromList <$> context (asJournal as) (asMatchAlgo as) (asDateFormat as) "" s' - return as { asStep = s' - , asEditor = clearEdit (asEditor as) - , asContext = ctx' - , asSuggestion = sugg - , asMessage = "" - -- Adhere to the 'undo' behaviour: when in the final - -- confirmation question, 'undo' jumps back to the last amount - -- question instead of to the last account question. So do not - -- save the last empty account answer which indicates the end - -- of the transaction. - -- Furthermore, don't save the input if the FinalQuestion is - -- answered by 'n' (for no). - , asInputHistory = case (asStep as,s') of - (FinalQuestion _ _, _) -> asInputHistory as - (_, FinalQuestion _ _) -> asInputHistory as - _ -> inputText : asInputHistory as - } + sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) s' + ctx' <- ctxList . V.fromList <$> liftIO (context (as^.asJournal) (as^.asMatchAlgo) (as^.asDateFormat) "" s') + asStep .= s' + asEditor %= clearEdit + asContext .= ctx' + asSuggestion .= sugg + asMessage .= "" + -- Adhere to the 'undo' behaviour: when in the final + -- confirmation question, 'undo' jumps back to the last amount + -- question instead of to the last account question. So do not + -- save the last empty account answer which indicates the end + -- of the transaction. + -- Furthermore, don't save the input if the FinalQuestion is + -- answered by 'n' (for no). + case (as^.asStep, s') of + (FinalQuestion _ _, _) -> return () + (_, FinalQuestion _ _) -> return () + _ -> asInputHistory %= (inputText :) -doUndo :: AppState -> IO AppState -doUndo as = case undo (asStep as) of - Left msg -> return as { asMessage = "Undo failed: " <> msg } +doUndo :: EventM n AppState () +doUndo = use asStep >>= \s -> case undo s of + Left msg -> asMessage .= "Undo failed: " <> msg Right step -> do - sugg <- suggest (asJournal as) (asDateFormat as) step - setContext $ as { asStep = step - , asEditor = setEdit lastInput (asEditor as) - , asSuggestion = sugg - , asMessage = "Undo." - , asInputHistory = historyTail - } - where (lastInput,historyTail) = - case asInputHistory as of - x:t -> (x,t) - [] -> ("",[]) + as <- get + let (lastInput,historyTail) = + case as^.asInputHistory of + x:t -> (x,t) + [] -> ("",[]) + sugg <- liftIO $ suggest (as^.asJournal) (as^.asDateFormat) step + asStep .= step + asEditor %= setEdit lastInput + asSuggestion .= sugg + asMessage .= "Undo." + asInputHistory .= historyTail + setContext + insertSelected :: AppState -> AppState -insertSelected as = case listSelectedElement (asContext as) of +insertSelected as = case listSelectedElement (as^.asContext) of Nothing -> as - Just (_, line) -> as { asEditor = setEdit line (asEditor as) } + Just (_, line) -> as & asEditor %~ setEdit line asMaybe :: Text -> Maybe Text @@ -329,7 +333,7 @@ attrs :: AttrMap attrs = attrMap defAttr [ (listSelectedAttr, black `on` white) - , (helpAttr <> "title", fg green) + , (helpAttr <> attrName "title", fg green) ] clearEdit :: Editor n -> Editor n @@ -541,7 +545,7 @@ , appChooseCursor = showFirstCursor , appHandleEvent = event , appAttrMap = const attrs - , appStartEvent = return + , appStartEvent = return () } :: App AppState Event Name expand :: Widget n -> Widget n diff --git a/tests/AmountParserSpec.hs b/tests/AmountParserSpec.hs --- a/tests/AmountParserSpec.hs +++ b/tests/AmountParserSpec.hs @@ -5,7 +5,7 @@ import Test.Hspec import Control.Monad.Trans.State.Strict -import Data.Either (either, isLeft) +import Data.Either (isLeft) import Data.Functor.Identity import Data.Text (Text) import qualified Hledger as HL diff --git a/tests/ModelSpec.hs b/tests/ModelSpec.hs --- a/tests/ModelSpec.hs +++ b/tests/ModelSpec.hs @@ -1,13 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} module ModelSpec (spec) where import Test.Hspec import Control.Monad import Data.List -import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T