hledger-iadd 1.1.4 → 1.2

raw patch · 10 files changed

+332/−331 lines, 10 filesdep ~hledger-libdep ~text-zipperPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hledger-lib, text-zipper

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• README.md +2/−0
• hledger-iadd.cabal +8/−9
• src/Brick/Widgets/CommentDialog.hs +79/−0
• src/Data/Text/Zipper/Generic/Words.hs +0/−97
• src/Model.hs +78/−34
• src/View.hs +27/−12
• src/main/Main.hs +77/−20
• tests/Data/Text/Zipper/Generic/WordsSpec.hs +0/−153
• tests/ModelSpec.hs +55/−6

@@ -1,3 +1,9 @@+# 1.2++  - Add support for comments (bound to `;`)+  - Restore previous text input on undo+  - Bump text-zipper dependency to 0.10+ # 1.1.4    - Sort account names by frequency for completion

@@ -152,6 +152,8 @@ | <kbd>Tab</kbd>                  | Insert the currently selected answer into the text area                       | | <kbd>C-n</kbd>,<kbd>↓</kbd>     | Select the next context item                                                  | | <kbd>C-p</kbd>,<kbd>↑</kbd>     | Select the previous context item                                              |+| <kbd>;</kbd>                    | Edit comment for current prompt                                               |+| <kbd>Alt-;</kbd>                | Edit transaction comment                                                      | | <kbd>F1</kbd>,<kbd>Alt-?</kbd>  | Show help dialog                                                              |  ## Default Currency

@@ -1,5 +1,5 @@ name:                hledger-iadd-version:             1.1.4+version:             1.2 synopsis:            A terminal UI as drop-in replacement for hledger add description:         This is a terminal UI as drop-in replacement for hledger add.                      .@@ -50,10 +50,10 @@                      , ConfigParser                      , Brick.Widgets.List.Utils                      , Brick.Widgets.HelpMessage+                     , Brick.Widgets.CommentDialog                      , Brick.Widgets.BetterDialog                      , Brick.Widgets.WrappedText                      , Brick.Widgets.Edit.EmacsBindings-                     , Data.Text.Zipper.Generic.Words   default-language:    Haskell2010   build-depends:       base >= 4.8 && < 5                      , hledger-lib >= 1.0 && < 1.2@@ -61,11 +61,11 @@                      , vty >= 5.4                      , text                      , microlens-                     , text-zipper+                     , text-zipper >= 0.10                      , transformers >= 0.3                      , time >= 1.5                      , vector-                     , megaparsec >= 5.0 && <5.2+                     , megaparsec >= 5.0 && <5.3                      , containers                      , optparse-applicative                      , directory@@ -86,7 +86,7 @@                      , vty >= 5.4                      , text                      , microlens-                     , text-zipper+                     , text-zipper >= 0.10                      , transformers >= 0.3                      , time >= 1.5                      , vector@@ -96,7 +96,7 @@                      , xdg-basedir                      , unordered-containers                      , free >= 4.12.4-                     , megaparsec >= 5.0 && <5.2+                     , megaparsec >= 5.0 && <5.3   ghc-options:         -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing  test-suite spec@@ -107,7 +107,6 @@                     , ConfigParserSpec                     , AmountParserSpec                     , ModelSpec-                    , Data.Text.Zipper.Generic.WordsSpec   default-language:   Haskell2010   build-depends:      base >= 4.8 && < 5                     , hledger-iadd@@ -120,6 +119,6 @@                     , QuickCheck                     , text-format                     , free >= 4.12.4-                    , megaparsec >= 5.0 && <5.2-                    , text-zipper+                    , megaparsec >= 5.0 && <5.3+                    , text-zipper >= 0.10   ghc-options:        -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module Brick.Widgets.CommentDialog+  ( CommentWidget+  , commentWidget+  , renderCommentWidget+  , commentDialogComment+  , CommentAction(..)+  , handleCommentEvent+  ) where++import           Data.Monoid++import           Brick+import           Brick.Widgets.Edit hiding (handleEditorEvent)+import           Brick.Widgets.Dialog+import           Brick.Widgets.Center+import           Data.Text.Zipper+import           Graphics.Vty.Input+import qualified Data.Text as T+import           Data.Text (Text)++import           Brick.Widgets.Edit.EmacsBindings++data CommentWidget n = CommentWidget+  { origComment :: Text+  , textArea :: Editor Text n+  , dialogWidget :: Dialog ()+  , promptPrefix :: Text+  }++commentWidget :: n -> Text -> Text -> CommentWidget n+commentWidget name prompt comment =+  let+    title = "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+      }++data CommentAction n = CommentContinue (CommentWidget n)+                     | 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) }+  _ -> do+    textArea' <- handleEditorEvent ev (textArea widget)+    return $ CommentContinue $+      CommentWidget (origComment widget) textArea' (dialogWidget widget) (promptPrefix widget)++renderCommentWidget :: (Ord n, Show n) => CommentWidget n -> Widget n+renderCommentWidget widget =+  let+    height = min (length (getEditContents (textArea widget)) + 4) 24+    textArea' =  padTop (Pad 1) $+      txt (promptPrefix widget <> ": ") <+> renderEditor True (textArea widget)+  in+    vCenterLayer $ vLimit height $ renderDialog (dialogWidget widget) textArea'++commentDialogComment :: CommentWidget n -> Text+commentDialogComment = T.intercalate "\n" . getEditContents . textArea++gotoEnd :: Monoid a => TextZipper a -> TextZipper a+gotoEnd zipper =+  let+    lengths = lineLengths zipper+    (row, col) = (length lengths, last lengths)+  in+    moveCursor (row-1, col) zipper

@@ -1,97 +0,0 @@--- | Implements word movements for "Data.Text.Zipper"------ Since these rely on character classes, the 'TZ.GenericTextZipper' constraint--- is required.-module Data.Text.Zipper.Generic.Words-  ( moveWordLeft-  , moveWordRight-  , deletePrevWord-  , deleteWord-  ) where--import           Data.Char--import           Data.Text.Zipper-import qualified Data.Text.Zipper.Generic as TZ---- | Move one word to the left------ A word is defined as a consecutive string not satisfying isSpace. This--- function always leaves the cursor at the beginning of a word (except at the--- very start of the text).-moveWordLeft :: TZ.GenericTextZipper a => TextZipper a -> TextZipper a-moveWordLeft = doWordLeft False moveLeft---- | Delete the previous word------ Does the same as 'moveWordLeft' but deletes characters instead of simply--- moving past them.-deletePrevWord :: (Eq a, TZ.GenericTextZipper a) => TextZipper a -> TextZipper a-deletePrevWord = doWordLeft False deletePrevChar--doWordLeft :: TZ.GenericTextZipper a => Bool -> (TextZipper a -> TextZipper a) -> TextZipper a -> TextZipper a-doWordLeft inWord transform zipper = case charToTheLeft zipper of-  Nothing -> zipper  -- start of text-  Just c-    | isSpace c && not inWord-      -> doWordLeft False transform (transform zipper)-    | not (isSpace c) && not inWord-      -> doWordLeft True transform zipper -- switch to skipping letters-    | not (isSpace c) && inWord-      -> doWordLeft True transform (transform zipper)-    | otherwise-      -> zipper -- Done---- | Move one word to the right------ A word is defined as a consecutive string not satisfying isSpace. This--- function always leaves the cursor at the end of a word (except at the very--- end of the text).-moveWordRight :: TZ.GenericTextZipper a => TextZipper a -> TextZipper a-moveWordRight = doWordRight False moveRight---- | Delete the next word------ Does the same as 'moveWordRight' but deletes characters instead of simply--- moving past them.-deleteWord :: TZ.GenericTextZipper a => TextZipper a -> TextZipper a-deleteWord = doWordRight False deleteChar--doWordRight :: TZ.GenericTextZipper a => Bool -> (TextZipper a -> TextZipper a) -> TextZipper a -> TextZipper a-doWordRight inWord transform zipper = case charToTheRight zipper of-  Nothing -> zipper -- end of text-  Just c-    | isSpace c && not inWord-      -> doWordRight False transform (transform zipper)-    | not (isSpace c) && not inWord-      -> doWordRight True transform zipper -- switch to skipping letters-    | not (isSpace c) && inWord-      -> doWordRight True transform (transform zipper)-    | otherwise-      -> zipper -- Done----- Helpers--charToTheLeft :: TZ.GenericTextZipper a => TextZipper a -> Maybe Char-charToTheLeft zipper = case cursorPosition zipper of-  (0, 0) -> Nothing  -- Very start of text, no char left-  (_, 0) -> Just '\n' -- Start of line, simulate newline-  (_, x) -> Just (TZ.toList (currentLine zipper) !! (x-1))--charToTheRight :: TZ.GenericTextZipper a => TextZipper a -> Maybe Char-charToTheRight zipper-  | null (getText zipper) = Nothing-  | otherwise =-    let-      (row, col) = cursorPosition zipper-      content = getText zipper-      curLine = content !! row-      numLines = length content-    in-      if row == numLines - 1 && col == (TZ.length curLine) then-        Nothing -- very end-      else if col == (TZ.length curLine) then-        Just '\n' -- simulate newline-      else-        Just (TZ.toList curLine !! col)

@@ -9,6 +9,10 @@        , undo        , context        , suggest+       , setCurrentComment+       , getCurrentComment+       , setTransactionComment+       , getTransactionComment         -- * Helpers exported for easier testing        , accountsByFrequency@@ -28,10 +32,12 @@ import           AmountParser import           DateParser -data Step = DateQuestion-          | DescriptionQuestion Day-          | AccountQuestion HL.Transaction-          | AmountQuestion HL.AccountName HL.Transaction+type Comment = Text++data Step = DateQuestion Comment+          | DescriptionQuestion Day Comment+          | AccountQuestion HL.Transaction Comment+          | AmountQuestion HL.AccountName HL.Transaction Comment           | FinalQuestion HL.Transaction           deriving (Eq, Show) @@ -45,55 +51,57 @@  nextStep :: HL.Journal -> DateFormat -> Either Text Text -> Step -> IO (Either Text MaybeStep) nextStep journal dateFormat entryText current = case current of-  DateQuestion ->-    fmap (Step . DescriptionQuestion) <$> either (parseDateWithToday dateFormat)-                                                 parseHLDateWithToday-                                                 entryText-  DescriptionQuestion day -> return $ Right $ Step $+  DateQuestion comment ->+    fmap (Step . flip DescriptionQuestion comment)+       <$> either (parseDateWithToday dateFormat) parseHLDateWithToday entryText++  DescriptionQuestion day comment -> return $ Right $ Step $     AccountQuestion HL.nulltransaction { HL.tdate = day                                        , HL.tdescription = (fromEither entryText)+                                       , HL.tcomment = comment                                        }-  AccountQuestion trans+                                       "" -- empty comment+  AccountQuestion trans comment     | T.null (fromEither entryText) && transactionBalanced trans       -> return $ Right $ Step $ FinalQuestion trans     | T.null (fromEither entryText)  -- unbalanced       -> return $ Left $ "Transaction not balanced! Please balance your transaction before adding it to the journal."     | otherwise        -> return $ Right $ Step $-      AmountQuestion (fromEither entryText) trans-  AmountQuestion name trans -> case parseAmount journal (fromEither entryText) of+      AmountQuestion (fromEither entryText) trans comment+  AmountQuestion name trans comment -> case parseAmount journal (fromEither entryText) of     Left err -> return $ Left (T.pack err)     Right amount -> return $ Right $ Step $-      let newPosting = post' name amount-      in AccountQuestion (addPosting newPosting trans)+      let newPosting = post' name amount comment+      in AccountQuestion (addPosting newPosting trans) ""    FinalQuestion trans     | fromEither entryText == "y" -> return $ Right $ Finished trans-    | otherwise -> return $ Right $ Step $ AccountQuestion trans+    | otherwise -> return $ Right $ Step $ AccountQuestion trans ""  -- | Reverses the last step. -- -- Returns (Left errorMessage), if the step can't be reversed undo :: Step -> Either Text Step undo current = case current of-  DateQuestion -> Left "Already at oldest step in current transaction"-  DescriptionQuestion _ -> return DateQuestion-  AccountQuestion trans -> return $ case HL.tpostings trans of-    []     -> DescriptionQuestion (HL.tdate trans)-    ps -> AmountQuestion (HL.paccount (last ps)) trans { HL.tpostings = init ps }-  AmountQuestion _ trans -> Right $ AccountQuestion trans-  FinalQuestion trans -> undo (AccountQuestion trans)+  DateQuestion _ -> Left "Already at oldest step in current transaction"+  DescriptionQuestion _ comment -> return (DateQuestion comment)+  AccountQuestion trans _ -> return $ case HL.tpostings trans of+    []     -> DescriptionQuestion (HL.tdate trans) (HL.tcomment trans)+    ps -> AmountQuestion (HL.paccount (last ps)) trans { HL.tpostings = init ps } (HL.pcomment (last ps))+  AmountQuestion _ trans comment -> Right $ AccountQuestion trans comment+  FinalQuestion trans -> undo (AccountQuestion trans "")  context :: HL.Journal -> MatchAlgo -> DateFormat -> Text -> Step -> IO [Text]-context _ _ dateFormat entryText DateQuestion = parseDateWithToday dateFormat entryText >>= \case+context _ _ dateFormat entryText (DateQuestion _) = parseDateWithToday dateFormat entryText >>= \case   Left _ -> return []   Right date -> return [T.pack $ HL.showDate date]-context j matchAlgo _ entryText (DescriptionQuestion _) = return $+context j matchAlgo _ entryText (DescriptionQuestion _ _) = return $   let descs = HL.journalDescriptions j   in sortBy (descUses j) $ filter (matches matchAlgo entryText) descs-context j matchAlgo _ entryText (AccountQuestion _) = return $+context j matchAlgo _ entryText (AccountQuestion _ _) = return $   let names = accountsByFrequency j   in  filter (matches matchAlgo entryText) names-context journal _ _ entryText (AmountQuestion _ _) = return $+context journal _ _ entryText (AmountQuestion _ _ _) = return $   maybeToList $ T.pack . HL.showMixedAmount <$> trySumAmount journal entryText context _ _ _ _  (FinalQuestion _) = return [] @@ -101,14 +109,14 @@ -- -- For example, it suggests today for the date prompt suggest :: HL.Journal -> DateFormat -> Step -> IO (Maybe Text)-suggest _ dateFormat DateQuestion =+suggest _ dateFormat (DateQuestion _) =   Just . printDate dateFormat . utctDay <$> getCurrentTime-suggest _ _ (DescriptionQuestion _) = return Nothing-suggest journal _ (AccountQuestion trans) = return $+suggest _ _ (DescriptionQuestion _ _) = return Nothing+suggest journal _ (AccountQuestion trans _) = return $   if numPostings trans /= 0 && transactionBalanced trans     then Nothing     else HL.paccount <$> (suggestAccountPosting journal trans)-suggest journal _ (AmountQuestion account trans) = return $ fmap (T.pack . HL.showMixedAmount) $ do+suggest journal _ (AmountQuestion account trans _) = return $ fmap (T.pack . HL.showMixedAmount) $ do   case findLastSimilar journal trans of     Nothing       | null (HL.tpostings trans)@@ -122,6 +130,40 @@         -> Just $ negativeAmountSum trans suggest _ _ (FinalQuestion _) = return $ Just "y" +getCurrentComment :: Step -> Comment+getCurrentComment step = case step of+  DateQuestion c -> c+  DescriptionQuestion _ c -> c+  AccountQuestion _ c -> c+  AmountQuestion _ _ c -> c+  FinalQuestion trans -> HL.tcomment trans++setCurrentComment :: Comment -> Step -> Step+setCurrentComment comment step = case step of+  DateQuestion _ -> DateQuestion comment+  DescriptionQuestion date _ -> DescriptionQuestion date comment+  AccountQuestion trans _ -> AccountQuestion trans comment+  AmountQuestion trans name _ -> AmountQuestion trans name comment+  FinalQuestion trans -> FinalQuestion trans { HL.tcomment = comment }++getTransactionComment :: Step -> Comment+getTransactionComment step = case step of+  DateQuestion c -> c+  DescriptionQuestion _ c -> c+  AccountQuestion trans _ -> HL.tcomment trans+  AmountQuestion _ trans _ -> HL.tcomment trans+  FinalQuestion trans -> HL.tcomment trans++setTransactionComment :: Comment -> Step -> Step+setTransactionComment comment step = case step of+  DateQuestion _ -> DateQuestion comment+  DescriptionQuestion date _ -> DescriptionQuestion date comment+  AccountQuestion trans comment' ->+    AccountQuestion (trans { HL.tcomment = comment }) comment'+  AmountQuestion name trans comment' ->+    AmountQuestion name (trans { HL.tcomment = comment }) comment'+  FinalQuestion trans -> FinalQuestion trans { HL.tcomment = comment }+ -- | Returns true if the pattern is not empty and all of its words occur in the string -- -- If the pattern is empty, we don't want any entries in the list, so nothing is@@ -148,10 +190,12 @@         | c == c2 -> fuzzyMatch queryRest (partRest : partsRest)         | otherwise -> False -post' :: HL.AccountName -> HL.MixedAmount -> HL.Posting-post' account amount = HL.nullposting { HL.paccount = account-                                      , HL.pamount = amount-                                      }+post' :: HL.AccountName -> HL.MixedAmount -> Comment -> HL.Posting+post' account amount comment = HL.nullposting+  { HL.paccount = account+  , HL.pamount = amount+  , HL.pcomment = comment+  }  addPosting :: HL.Posting -> HL.Transaction -> HL.Transaction addPosting p t = t { HL.tpostings = (HL.tpostings t) ++ [p] }

@@ -1,6 +1,12 @@ {-# LANGUAGE LambdaCase, OverloadedStrings #-} -module View where+module View+  ( viewState+  , viewQuestion+  , viewContext+  , viewSuggestion+  , viewMessage+  ) where  import           Brick import           Brick.Widgets.List@@ -14,22 +20,26 @@ import           Model  viewState :: Step -> Widget n-viewState DateQuestion = txt " "-viewState (DescriptionQuestion date) = str $-  formatTime defaultTimeLocale "%Y/%m/%d" date-viewState (AccountQuestion trans) = str $-  HL.showTransaction trans-viewState (AmountQuestion acc trans) = str $-  HL.showTransaction trans ++ "  " ++ T.unpack acc+viewState (DateQuestion comment) = txt $+  if T.null comment then " " else viewComment comment+viewState (DescriptionQuestion date comment) = txt $+  T.pack (formatTime defaultTimeLocale "%Y/%m/%d" date)+  <> viewComment comment+viewState (AccountQuestion trans comment) = txt $+  T.pack (HL.showTransaction trans)+  <> viewComment comment+viewState (AmountQuestion acc trans comment) = txt $+  T.pack (HL.showTransaction trans) <> "  " <> acc+  <> viewComment comment viewState (FinalQuestion trans) = str $   HL.showTransaction trans  viewQuestion :: Step -> Widget n-viewQuestion DateQuestion = txt "Date"-viewQuestion (DescriptionQuestion _) = txt "Description"-viewQuestion (AccountQuestion trans) = str $+viewQuestion (DateQuestion _) = txt "Date"+viewQuestion (DescriptionQuestion _ _) = txt "Description"+viewQuestion (AccountQuestion trans _) = str $   "Account " ++ show (numPostings trans + 1)-viewQuestion (AmountQuestion _ trans) = str $+viewQuestion (AmountQuestion _ trans _) = str $   "Amount " ++ show (numPostings trans + 1) viewQuestion (FinalQuestion _) = txt $   "Add this transaction to the journal? Y/n"@@ -52,3 +62,8 @@ --      => Remove this, once 5.14 becomes lower bound viewMessage :: Text -> Widget n viewMessage msg = wrappedText (if T.null msg then " " else msg)++viewComment :: Text -> Text+viewComment comment+  | T.null comment = ""+  | otherwise      = T.unlines $ map ("  ; " <>) $ T.lines comment

@@ -39,6 +39,7 @@ import qualified Text.Megaparsec.Text as P  import           Brick.Widgets.HelpMessage+import           Brick.Widgets.CommentDialog import           DateParser import           ConfigParser hiding (parseConfigFile) import           Model@@ -58,16 +59,31 @@   , asDateFormat :: DateFormat   , asMatchAlgo :: MatchAlgo   , asDialog :: DialogShown+  , asInputHistory :: [Text]   } -data Name = HelpName | ListName | EditorName+data Name = HelpName | ListName | EditorName | CommentName   deriving (Ord, Show, Eq) -data DialogShown = NoDialog | HelpDialog (HelpWidget Name) | QuitDialog | AbortDialog+data CommentType = TransactionComment | CurrentComment +instance Show CommentType where+  show TransactionComment = "Transaction comment"+  show CurrentComment = "Comment"++data DialogShown = NoDialog+                 | HelpDialog (HelpWidget Name)+                 | QuitDialog+                 | AbortDialog+                 | CommentDialog CommentType (CommentWidget Name)+ myHelpDialog :: DialogShown myHelpDialog = HelpDialog (helpWidget HelpName bindings) +myCommentDialog :: CommentType -> Text -> DialogShown+myCommentDialog typ comment =+  CommentDialog typ (commentWidget CommentName (T.pack $ show typ) comment)+ bindings :: KeyBindings bindings = KeyBindings   [ ("Denial",@@ -81,6 +97,8 @@        , ("C-p", "Select the previous context item")        , ("Tab", "Insert currently selected answer into text area")        , ("C-z", "Undo")+       , (";", "Edit comment for current prompt")+       , ("Alt-;", "Edit transaction comment")        ])   , ("Acceptance",      [ ("Ret", "Accept the currently selected answer")@@ -92,6 +110,7 @@   HelpDialog h -> [renderHelpWidget h, ui]   QuitDialog -> [quitDialog, ui]   AbortDialog -> [abortDialog, ui]+  CommentDialog _ c -> [renderCommentWidget c, ui]   NoDialog -> [ui]    where ui =  viewState (asStep as)@@ -108,6 +127,10 @@         quitDialog = dialog "Quit" "Really quit without saving the current transaction? (Y/n)"         abortDialog = dialog "Abort" "Really abort this transaction (Y/n)" +setComment :: CommentType -> Text -> Step -> Step+setComment TransactionComment = setTransactionComment+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@@ -129,13 +152,23 @@         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)+                  }+   NoDialog -> case ev of-    EvKey (KChar 'c') [MCtrl]-      | asStep as == DateQuestion -> halt as-      | otherwise -> continue as { asDialog = QuitDialog }-    EvKey (KChar 'd') [MCtrl]-      | asStep as == DateQuestion -> halt as-      | otherwise -> continue as { asDialog = QuitDialog }+    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@@ -145,10 +178,15 @@     EvKey KUp [] -> continue as { asContext = listMoveUp $ asContext as                                , asMessage = ""}     EvKey (KChar '\t') [] -> continue (insertSelected as)-    EvKey KEsc []-      | asStep as == DateQuestion && T.null (editText as) -> halt as-      | asStep as == DateQuestion -> liftIO (reset as) >>= continue-      | otherwise -> continue as { asDialog = AbortDialog }+    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@@ -164,14 +202,15 @@                    <*> return (asDateFormat as)                    <*> return (asMatchAlgo as)                    <*> return NoDialog+                   <*> return (asInputHistory as)          >>= liftIO . setContext >>= continue event as _ = continue as  reset :: AppState -> IO AppState reset as = do-  sugg <- suggest (asJournal as) (asDateFormat as) DateQuestion+  sugg <- suggest (asJournal as) (asDateFormat as) (DateQuestion "")   return as-    { asStep = DateQuestion+    { asStep = DateQuestion ""     , asEditor = clearEdit (asEditor as)     , asContext = ctxList V.empty     , asSuggestion = sugg@@ -196,7 +235,8 @@  doNextStep :: Bool -> AppState -> IO AppState doNextStep useSelected as = do-  let name = fromMaybe (Left $ editText as) $+  let inputText = editText as+      name = fromMaybe (Left $ inputText) $                msum [ Right <$> if useSelected then snd <$> listSelectedElement (asContext as) else Nothing                     , Left <$> asMaybe (editText as)                     , Left <$> asSuggestion as@@ -206,9 +246,9 @@     Left err -> return as { asMessage = err }     Right (Finished trans) -> do       liftIO $ addToJournal trans (asFilename as)-      sugg <- suggest (asJournal as) (asDateFormat as) DateQuestion+      sugg <- suggest (asJournal as) (asDateFormat as) (DateQuestion "")       return AppState-        { asStep = DateQuestion+        { asStep = DateQuestion ""         , asJournal = addTransactionEnd trans (asJournal  as)         , asEditor = clearEdit (asEditor as)         , asContext = ctxList V.empty@@ -218,6 +258,7 @@         , asDateFormat = asDateFormat as         , asMatchAlgo = asMatchAlgo as         , asDialog = NoDialog+        , asInputHistory = []         }     Right (Step s') -> do       sugg <- suggest (asJournal as) (asDateFormat as) s'@@ -227,6 +268,17 @@                 , 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                 }  doUndo :: AppState -> IO AppState@@ -235,10 +287,15 @@   Right step -> do     sugg <- suggest (asJournal as) (asDateFormat as) step     setContext $ as { asStep = step-                    , asEditor = clearEdit (asEditor as)+                    , asEditor = setEdit lastInput (asEditor as)                     , asSuggestion = sugg                     , asMessage = "Undo."+                    , asInputHistory = historyTail                     }+    where (lastInput,historyTail) =+            case (asInputHistory as) of+              x:t -> (x,t)+              [] -> ("",[])  insertSelected :: AppState -> AppState insertSelected as = case listSelectedElement (asContext as) of@@ -446,11 +503,11 @@     Right journal -> do       let edit = editor EditorName (txt . T.concat) (Just 1) "" -      sugg <- suggest journal date DateQuestion+      sugg <- suggest journal date (DateQuestion "")        let welcome = "Welcome! Press F1 (or Alt-?) for help. Exit with Ctrl-d."           matchAlgo = runIdentity $ optMatchAlgo opts-          as = AppState edit DateQuestion journal (ctxList V.empty) sugg welcome path date matchAlgo NoDialog+          as = AppState edit (DateQuestion "") journal (ctxList V.empty) sugg welcome path date matchAlgo NoDialog []        void $ defaultMain app as 

@@ -1,153 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.Text.Zipper.Generic.WordsSpec (spec) where--import           Test.Hspec-import           Test.QuickCheck--import           Data.Char--import           Data.Text.Zipper-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Text.Zipper.Generic.Words--spec :: Spec-spec = do-  moveWordLeftSpec-  moveWordRightSpec-  deletePrevWordSpec-  deleteWordSpec--moveWordLeftSpec :: Spec-moveWordLeftSpec = describe "moveWordLeft" $ do-  it "does nothing at the start of the text" $-    moveWordLeft (zipLoc ["foo bar"] (0, 0)) `isAt` (0, 0)--  it "moves from middle of the word to the start" $-    moveWordLeft (zipLoc ["foo barfoo"] (0, 7)) `isAt` (0, 4)--  it "moves from end to beginning" $-    moveWordLeft (zipLoc ["barfoo"] (0, 6)) `isAt` (0, 0)--  it "stops at beginning of line if word boundary" $-    moveWordLeft (zipLoc ["foo", "bar"] (1, 2)) `isAt` (1, 0)--  it "moves across lines from beginning of line" $-    moveWordLeft (zipLoc ["foo", "bar"] (1, 0)) `isAt` (0, 0)--  it "skips multiple space characters" $-    moveWordLeft (zipLoc ["foo   bar"] (0, 6)) `isAt` (0, 0)--  it "skips multiple space characters across lines" $-    moveWordLeft (zipLoc ["foo  ", " bar"] (1, 1)) `isAt` (0, 0)--  it "always lands on the start of a word" $ property $ \(textlist :: [Text]) cursor ->-    isAtWordStart (moveWordLeft (zipLoc textlist cursor))--moveWordRightSpec :: Spec-moveWordRightSpec = describe "moveWordRight" $ do-  it "does nothing at the end of the text" $-    moveWordRight (zipLoc ["foo bar"] (0, 7)) `isAt` (0, 7)--  it "moves from middle of the word to its end" $-    moveWordRight (zipLoc ["barfoo foo"] (0, 2)) `isAt`(0, 6)--  it "moves from beginning to end" $-    moveWordRight (zipLoc ["barfoo"] (0, 0)) `isAt` (0, 6)--  it "stops at end of line if word boundary" $-    moveWordRight (zipLoc ["foo", "bar"] (0, 1)) `isAt` (0, 3)--  it "moves across lines from end of line" $-    moveWordRight (zipLoc ["foo", "bar"] (0, 3)) `isAt` (1, 3)--  it "skips multiple space characters" $-    moveWordRight (zipLoc ["foo    bar"] (0, 4)) `isAt` (0, 10)--  it "skips multiple space characters across lines" $-    moveWordRight (zipLoc ["foo   ", "  bar"] (0, 4)) `isAt` (1, 5)--  it "always lands at the end of a word" $ property $ \(textlist :: [Text]) cursor ->-    isAtWordEnd (moveWordRight (zipLoc textlist cursor))--deletePrevWordSpec :: Spec-deletePrevWordSpec = describe "deletePrevWord" $ do-  it "does the same cursor movement as moveWordLeft" $ property $ \(textlist :: [Text]) cursor ->-    let zip = zipLoc textlist cursor-    in deletePrevWord zip `isAt` (cursorPosition (moveWordLeft zip))--  it "has the same prefix than moveWordLeft" $ property $ \textlist cursor ->-    let zip = zipLoc textlist cursor-    in deleteToEnd (deletePrevWord zip) === deleteToEnd (moveWordLeft zip)--  it "has the same suffix than before" $ property $ \textlist cursor ->-    let zip = zipLoc textlist cursor-    in deleteToBeginning (deletePrevWord zip) === deleteToBeginning zip--deleteWordSpec :: Spec-deleteWordSpec = describe "deleteWord" $ do-  it "does no cursor movement" $ property $ \textlist cursor ->-    let zip = zipLoc textlist cursor-    in deleteWord zip `isAt` cursorPosition zip--  it "has the same prefix than before" $ property $ \textlist cursor ->-    let zip = zipLoc textlist cursor-    in deleteToEnd (deleteWord zip) === deleteToEnd zip--  it "has the same suffix than moveWordRight" $ property $ \textlist cursor ->-    let zip = zipLoc textlist cursor-    in deleteToBeginning (deleteWord zip) === deleteToBeginning (moveWordRight zip)---- Helpers---- | Creates a zipper with initial content and cursor location-zipLoc :: [Text] -> (Int, Int) -> TextZipper Text-zipLoc content location = moveCursor location $ textZipper content Nothing---- | Set the expectation that the given zipper is at the given cursor location-isAt :: TextZipper a -> (Int, Int) -> Expectation-isAt zipper loc = cursorPosition zipper `shouldBe` loc--isAtWordEnd :: TextZipper Text -> Property-isAtWordEnd zipper = counterexample (show zipper) $-  let-    (row, col) = cursorPosition zipper-    numLines = length (getText zipper)-    curLine = currentLine zipper-  in-    (col == T.length curLine && row == numLines)-    || ((col == T.length curLine || isSpace (T.index curLine col)) -- next is space-        && (col == 0 || not (isSpace (T.index curLine (col-1))))) -- previous is word--isAtWordStart :: TextZipper Text -> Property-isAtWordStart zipper = counterexample (show zipper) $-  let-    (row, col) = cursorPosition zipper-    curLine = currentLine zipper-  in-    (row == 0 && col == 0)-    || ((col == 0 || isSpace (T.index curLine (col-1))) -- previous is space-       && (col == T.length curLine || not (isSpace (T.index curLine col)))) -- next is word---- | Delete to the very end of a zipper-deleteToEnd :: TextZipper Text -> TextZipper Text-deleteToEnd zipper =-  let-    (row, _) = cursorPosition zipper-    numLines = length (getText zipper)-  in-    if row == numLines-1 then-      killToEOL zipper-    else-      deleteToEnd (deleteChar (killToEOL zipper))--deleteToBeginning :: TextZipper Text -> TextZipper Text-deleteToBeginning zipper = case cursorPosition zipper of-  (0, _) -> killToBOL zipper-  _      -> deleteToBeginning (deletePrevChar (killToBOL zipper))--instance Arbitrary Text where-  arbitrary = T.pack <$> arbitrary

@@ -20,6 +20,8 @@ spec = do   describe "suggest" suggestSpec   describe "accountsByFrequency" accByFreqSpec+  describe "setCurrentComment" setCurrentCommentSpec+  describe "setTransactionComment" setTransactionCommentSpec   suggestSpec :: Spec@@ -27,7 +29,7 @@   context "at the account prompt" $ do      it "suggests nothing for an empty journal" $-      suggest HL.nulljournal german (AccountQuestion HL.nulltransaction)+      suggest HL.nulljournal german (AccountQuestion HL.nulltransaction "")         `shouldReturn` Nothing      it "suggests the accounts in order" $ do@@ -36,7 +38,7 @@        forM_ (zip (inits postings) postings) $ \(posts, next) -> do         let t = mkTransaction ((2016, 1, 1), "Foo", map (\(x,y) -> (x, y+1)) posts)-        suggest j german (AccountQuestion t) `shouldReturn` (Just (fst next))+        suggest j german (AccountQuestion t "") `shouldReturn` (Just (fst next))     context "at the amount prompt" $ do@@ -47,7 +49,7 @@        forM_ (zip (inits postings) postings) $ \(posts, next) -> do         let t = mkTransaction ((2016, 1, 1), "Foo", posts)-        suggest j german (AmountQuestion (fst next) t)+        suggest j german (AmountQuestion (fst next) t "")           `shouldReturn` (Just ("€" <> (T.pack $ show $ snd next) <> ".00"))      it "suggests the balancing amount if accounts don't match with similar transaction" $ do@@ -55,19 +57,19 @@           j = mkJournal [ ((2017, 1, 1), "Foo", postings) ]           t = mkTransaction ((2016, 1, 1), "Foo", [("foo", 3)]) -      suggest j german (AmountQuestion "y" t) `shouldReturn` (Just "€-3.00")+      suggest j german (AmountQuestion "y" t "") `shouldReturn` (Just "€-3.00")      it "initially doesn't suggest an amount if there is no similar transaction" $ do       let j = mkJournal [ ((2017, 1, 1), "Foo", [("x", 2), ("y", 3)]) ]           t = mkTransaction ((2016, 1, 1), "Bar", []) -      suggest j german (AmountQuestion "y" t) `shouldReturn` Nothing+      suggest j german (AmountQuestion "y" t "") `shouldReturn` Nothing      it "suggests the balancing amount if there is no similar transaction for the second account" $ do       let j = mkJournal [ ((2017, 1, 1), "Foo", [("x", 2), ("y", 3)]) ]           t = mkTransaction ((2016, 1, 1), "Bar", [("foo", 3)]) -      suggest j german (AmountQuestion "y" t) `shouldReturn` (Just "€-3.00")+      suggest j german (AmountQuestion "y" t "") `shouldReturn` (Just "€-3.00")   accByFreqSpec :: Spec@@ -87,6 +89,52 @@     accountsByFrequency j `shouldBe` ["x:y", "x:z", "x"]  +setCurrentCommentSpec :: Spec+setCurrentCommentSpec = do+  it "works at the date prompt" $+    worksOn (DateQuestion "")++  it "works at the description prompt" $+    worksOn (DescriptionQuestion (fromGregorian 2017 2 3) "")++  it "works at the account prompt" $+    worksOn (AccountQuestion HL.nulltransaction "")++  it "works at the amount prompt" $+    worksOn (AmountQuestion "foo" HL.nulltransaction "")++  it "works at the final prompt" $+    worksOn (FinalQuestion HL.nulltransaction)++  where+    worksOn :: Step -> Expectation+    worksOn step =+      let comment = "a fancy comment"+      in getCurrentComment (setCurrentComment comment step) `shouldBe` comment++setTransactionCommentSpec :: Spec+setTransactionCommentSpec = do+  it "works at the date prompt" $+    worksOn (DateQuestion "")++  it "works at the description prompt" $+    worksOn (DescriptionQuestion (fromGregorian 2017 2 3) "")++  it "works at the account prompt" $+    worksOn (AccountQuestion HL.nulltransaction "")++  it "works at the amount prompt" $+    worksOn (AmountQuestion "foo" HL.nulltransaction "")++  it "works at the final prompt" $+    worksOn (FinalQuestion HL.nulltransaction)++  where+    worksOn :: Step -> Expectation+    worksOn step =+      let comment = "a fancy comment"+      in getTransactionComment (setTransactionComment comment step) `shouldBe` comment+ -- Helpers  type Date = (Integer,Int,Int) -- y, d, m@@ -128,3 +176,4 @@       , HL.pbalanceassertion = Nothing       , HL.ptransaction = Nothing       }+