diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +# 1.1.3 + + - Add more emacs/readline like keybindings in entry field (`C-f`/`C-b`, + `M-f`/`M-b`, `M-Del`/`C-w`, `M-d`) + - Fix account suggestion order to be more like `hledger add` + # 1.1.2 - Respect ${LEDGER_FILE} environment variable 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.2 +version: 1.1.3 synopsis: A terminal UI as drop-in replacement for hledger add description: This is a terminal UI as drop-in replacement for hledger add. . @@ -52,10 +52,12 @@ , Brick.Widgets.HelpMessage , 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 - , brick >= 0.15.2 && < 0.16 + , brick >= 0.15.2 && < 0.17 , vty >= 5.4 , text , microlens @@ -80,7 +82,7 @@ build-depends: base >= 4.8 && < 5 , hledger-iadd , hledger-lib >= 1.0 && < 1.2 - , brick >= 0.15.2 && < 0.16 + , brick >= 0.15.2 && < 0.17 , vty >= 5.4 , text , microlens @@ -104,6 +106,8 @@ other-modules: DateParserSpec , ConfigParserSpec , AmountParserSpec + , ModelSpec + , Data.Text.Zipper.Generic.WordsSpec default-language: Haskell2010 build-depends: base >= 4.8 && < 5 , hledger-iadd @@ -117,4 +121,5 @@ , text-format , free >= 4.12.4 , megaparsec >= 5.0 && <5.2 + , text-zipper ghc-options: -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing diff --git a/src/Brick/Widgets/Edit/EmacsBindings.hs b/src/Brick/Widgets/Edit/EmacsBindings.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Edit/EmacsBindings.hs @@ -0,0 +1,41 @@ +-- | Widget like "Brick.Widgets.Edit", but with more emacs style keybindings. +-- +-- See 'handleEditorEvent' for a list of added keybindings. +module Brick.Widgets.Edit.EmacsBindings + ( handleEditorEvent + , module Brick.Widgets.Edit + ) where + +import Brick +import Graphics.Vty +import qualified Brick.Widgets.Edit as E +import Brick.Widgets.Edit hiding (handleEditorEvent) +import Data.Text.Zipper +import Data.Text.Zipper.Generic (GenericTextZipper) + +import Data.Text.Zipper.Generic.Words + +-- | Same as 'E.handleEditorEvent', but with more emacs-style keybindings +-- +-- Specifically: +-- +-- - Ctrl-f: Move forward one character +-- - Ctrl-b: Move backward one character +-- - Alt-f: Move forward one word +-- - Alt-b: Move backward one word +-- - Alt-Backspace: Delete the previous word +-- - Ctrl-w: Delete the previous word +-- - Alt-d: Delete the next word +handleEditorEvent :: (Eq t, GenericTextZipper t) => Event -> Editor t n -> EventM n (Editor t n) +handleEditorEvent event edit = case event of + EvKey (KChar 'f') [MCtrl] -> return $ applyEdit moveRight edit + EvKey (KChar 'b') [MCtrl] -> return $ applyEdit moveLeft edit + + EvKey (KChar 'f') [MMeta] -> return $ applyEdit moveWordRight edit + EvKey (KChar 'b') [MMeta] -> return $ applyEdit moveWordLeft edit + + EvKey KBS [MMeta] -> return $ applyEdit deletePrevWord edit + EvKey (KChar 'w') [MCtrl] -> return $ applyEdit deletePrevWord edit + EvKey (KChar 'd') [MMeta] -> return $ applyEdit deleteWord edit + + _ -> E.handleEditorEvent event edit diff --git a/src/Data/Text/Zipper/Generic/Words.hs b/src/Data/Text/Zipper/Generic/Words.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Zipper/Generic/Words.hs @@ -0,0 +1,97 @@ +-- | 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 @@ -104,10 +104,18 @@ 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) $ - if transactionBalanced trans - then HL.pamount <$> (findPostingByAcc account =<< findLastSimilar journal trans) - else Just $ negativeAmountSum trans +suggest journal _ (AmountQuestion account trans) = return $ fmap (T.pack . HL.showMixedAmount) $ do + case findLastSimilar journal trans of + Nothing + | null (HL.tpostings trans) + -> Nothing -- Don't suggest an amount for first account + | otherwise + -> Just $ negativeAmountSum trans + Just last + | transactionBalanced trans || (trans `isSubsetTransaction` last) + -> HL.pamount <$> (findPostingByAcc account last) + | otherwise + -> Just $ negativeAmountSum trans suggest _ _ (FinalQuestion _) = return $ Just "y" -- | Returns true if the pattern is not empty and all of its words occur in the string @@ -155,12 +163,10 @@ suggestNextPosting current reference = -- Postings that aren't already used in the new posting let unusedPostings = filter (`notContainedIn` curPostings) refPostings - in listToMaybe $ sortBy cmpPosting unusedPostings + in listToMaybe unusedPostings where [refPostings, curPostings] = map HL.tpostings [reference, current] notContainedIn p = not . any (((==) `on` HL.paccount) p) - -- Sort descending by amount. This way, negative amounts rank last - cmpPosting = compare `on` (Down . HL.pamount) -- | Given the last transaction entered, suggest the likely most comparable posting -- @@ -192,6 +198,22 @@ -- | Return the first Posting that matches the given account name in the transaction findPostingByAcc :: HL.AccountName -> HL.Transaction -> Maybe HL.Posting findPostingByAcc account = find ((==account) . HL.paccount) . HL.tpostings + +-- | Returns True if the first transaction is a subset of the second one. +-- +-- That means, all postings from the first transaction are present in the +-- second one. +isSubsetTransaction :: HL.Transaction -> HL.Transaction -> Bool +isSubsetTransaction current origin = + let + origPostings = HL.tpostings origin + currPostings = HL.tpostings current + in + null (deleteFirstsBy cmpPosting currPostings origPostings) + where + cmpPosting a b = HL.paccount a == HL.paccount b + && HL.pamount a == HL.pamount b + listToMaybe' :: [a] -> Maybe [a] listToMaybe' [] = Nothing diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -8,7 +8,7 @@ import Brick import Brick.Widgets.Border import Brick.Widgets.BetterDialog -import Brick.Widgets.Edit +import Brick.Widgets.Edit.EmacsBindings import Brick.Widgets.List import Brick.Widgets.List.Utils import Graphics.Vty hiding (parseConfigFile, (<|>)) diff --git a/tests/Data/Text/Zipper/Generic/WordsSpec.hs b/tests/Data/Text/Zipper/Generic/WordsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Text/Zipper/Generic/WordsSpec.hs @@ -0,0 +1,153 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/ModelSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ModelSpec (spec) where + +import Test.Hspec + +import Control.Monad +import Data.List +import Data.Monoid + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar +import qualified Hledger as HL + +import DateParser +import Model hiding (context) + +spec :: Spec +spec = do + describe "suggest" suggestSpec + + +suggestSpec :: Spec +suggestSpec = do + context "at the account prompt" $ do + + it "suggests nothing for an empty journal" $ + suggest HL.nulljournal german (AccountQuestion HL.nulltransaction) + `shouldReturn` Nothing + + it "suggests the accounts in order" $ do + let postings = [("x", 1), ("y", 2), ("z", 3)] + j = mkJournal [ ((2017, 1, 1), "Foo", postings) ] + + 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)) + + + context "at the amount prompt" $ do + + it "suggests amounts from the similar transaction" $ do + let postings = [("x", 1), ("y", 2), ("z", 3)] + j = mkJournal [ ((2017, 1, 1), "Foo", postings) ] + + forM_ (zip (inits postings) postings) $ \(posts, next) -> do + let t = mkTransaction ((2016, 1, 1), "Foo", posts) + 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 + let postings = [("x", 1), ("y", 2), ("z", 3)] + 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") + + 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 + + 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") + + +-- Helpers + +type Date = (Integer,Int,Int) -- y, d, m + +-- | Creates a mock-journal from a list of transactions +-- +-- Transactions consists of the date, a description and a list of postings in +-- for form of (account, amount) +mkJournal :: [(Date, Text, [(Text, Int)])] -> HL.Journal +mkJournal transactions = + foldl (\j t -> HL.addTransaction (mkTransaction t) j) HL.nulljournal transactions + +mkTransaction :: (Date, Text, [(Text, Int)]) -> HL.Transaction +mkTransaction ((year,month,day), desc, postings) = HL.Transaction + { HL.tindex = 0 + , HL.tsourcepos = undefined + , HL.tdate = fromGregorian year month day + , HL.tdate2 = Nothing + , HL.tstatus = HL.Uncleared + , HL.tcode = "" + , HL.tdescription = desc + , HL.tcomment = "" + , HL.ttags = [] + , HL.tpostings = map mkPosting postings + , HL.tpreceding_comment_lines = "" + } + + where + mkPosting :: (Text, Int) -> HL.Posting + mkPosting (account, amount) = HL.Posting + { HL.pdate = Nothing + , HL.pdate2 = Nothing + , HL.pstatus = HL.Uncleared + , HL.paccount = account + , HL.pamount = HL.mixed [HL.eur (fromIntegral amount)] + , HL.pcomment = "" + , HL.ptype = HL.RegularPosting + , HL.ptags = [] + , HL.pbalanceassertion = Nothing + , HL.ptransaction = Nothing + }