hledger-iadd 1.3.17 → 1.3.18

raw patch · 12 files changed

+258/−241 lines, 12 filesdep +microlens-mtldep ~brickdep ~hledger-libdep ~megaparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: microlens-mtl

Dependency ranges changed: brick, hledger-lib, megaparsec

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• hledger-iadd.cabal +9/−6
• src/Brick/Widgets/CommentDialog.hs +31/−27
• src/Brick/Widgets/Edit/EmacsBindings.hs +18/−15
• src/Brick/Widgets/HelpMessage.hs +19/−20
• src/ConfigParser.hs +0/−1
• src/DateParser.hs +5/−2
• src/Model.hs +3/−3
• src/View.hs +0/−1
• src/main/Main.hs +167/−163
• tests/AmountParserSpec.hs +1/−1
• tests/ModelSpec.hs +0/−2

@@ -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

@@ -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

@@ -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 =

@@ -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'

@@ -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)

@@ -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

@@ -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)

@@ -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 =

@@ -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

@@ -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

@@ -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

@@ -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