hledger-iadd 1.1.2 → 1.1.3

raw patch · 8 files changed

+447/−11 lines, 8 filesdep ~brickPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: brick

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• hledger-iadd.cabal +8/−3
• src/Brick/Widgets/Edit/EmacsBindings.hs +41/−0
• src/Data/Text/Zipper/Generic/Words.hs +97/−0
• src/Model.hs +29/−7
• src/main/Main.hs +1/−1
• tests/Data/Text/Zipper/Generic/WordsSpec.hs +153/−0
• tests/ModelSpec.hs +112/−0

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

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

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

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

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

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

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

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