diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -152,6 +152,8 @@
| Tab | Insert the currently selected answer into the text area |
| C-n,↓ | Select the next context item |
| C-p,↑ | Select the previous context item |
+| ; | Edit comment for current prompt |
+| Alt-; | Edit transaction comment |
| F1,Alt-? | Show help dialog |
## Default Currency
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.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
diff --git a/src/Brick/Widgets/CommentDialog.hs b/src/Brick/Widgets/CommentDialog.hs
new file mode 100644
--- /dev/null
+++ b/src/Brick/Widgets/CommentDialog.hs
@@ -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
diff --git a/src/Data/Text/Zipper/Generic/Words.hs b/src/Data/Text/Zipper/Generic/Words.hs
deleted file mode 100644
--- a/src/Data/Text/Zipper/Generic/Words.hs
+++ /dev/null
@@ -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)
diff --git a/src/Model.hs b/src/Model.hs
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -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] }
diff --git a/src/View.hs b/src/View.hs
--- a/src/View.hs
+++ b/src/View.hs
@@ -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
diff --git a/src/main/Main.hs b/src/main/Main.hs
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -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
diff --git a/tests/Data/Text/Zipper/Generic/WordsSpec.hs b/tests/Data/Text/Zipper/Generic/WordsSpec.hs
deleted file mode 100644
--- a/tests/Data/Text/Zipper/Generic/WordsSpec.hs
+++ /dev/null
@@ -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
diff --git a/tests/ModelSpec.hs b/tests/ModelSpec.hs
--- a/tests/ModelSpec.hs
+++ b/tests/ModelSpec.hs
@@ -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
}
+