hledger-iadd 1.3.6 → 1.3.7

raw patch · 11 files changed

+160/−177 lines, 11 filesdep ~brickdep ~hledger-libdep ~megaparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: brick, hledger-lib, megaparsec

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• LICENSE +1/−1
• hledger-iadd.cabal +15/−12
• src/AmountParser.hs +4/−3
• src/ConfigParser.hs +47/−9
• src/DateParser.hs +28/−13
• src/Model.hs +9/−4
• src/Text/Megaparsec/Compat.hs +0/−132
• src/main/Main.hs +3/−2
• tests/DateParserSpec.hs +42/−0
• tests/ModelSpec.hs +3/−1

@@ -1,3 +1,11 @@+# 1.3.7++  - feature: Add abbreviated days of the week to date completion (e.g. `mon`,+    `tue`, etc)+  - dependencies: Port to hledger-lib-1.12 and megaparsec-7+  - dependencies: Support GHC-8.6+  - dependencies: Switch stack builds to ghc 8.4 by default+ # 1.3.6    - bugfix: Use local time instead of UTC everywhere

@@ -1,4 +1,4 @@-Copyright Hans-Peter Deifel (c) 2015+Copyright Hans-Peter Deifel (c) 2018  All rights reserved. 

@@ -1,5 +1,5 @@ name:                hledger-iadd-version:             1.3.6+version:             1.3.7 synopsis:            A terminal UI as drop-in replacement for hledger add description:         This is a terminal UI as drop-in replacement for hledger add.                      .@@ -26,11 +26,14 @@ license-file:        LICENSE author:              Hans-Peter Deifel <hpd@hpdeifel.de> maintainer:          Hans-Peter Deifel <hpd@hpdeifel.de>-copyright:           2017 Hans-Peter Deifel+copyright:           2018 Hans-Peter Deifel category:            Finance, Console build-type:          Simple cabal-version:       >=1.10-tested-with:         GHC==8.0, GHC==8.2, GHC==8.4+tested-with:         GHC ==8.0.2+                   , GHC ==8.2.2+                   , GHC ==8.4.4+                   , GHC ==8.6.2                       extra-source-files:   doc/screencast.gif@@ -55,12 +58,11 @@                      , Brick.Widgets.WrappedText                      , Brick.Widgets.Edit.EmacsBindings                      , Brick.Widgets.Border.Utils-                     , Text.Megaparsec.Compat                      , Data.Time.Ext   default-language:    Haskell2010   build-depends:       base >= 4.9 && < 5-                     , hledger-lib >= 1.5 && < 2.0-                     , brick >= 0.17+                     , hledger-lib >= 1.12 && < 1.13+                     , brick >= 0.27                      , vty >= 5.4                      , text                      , microlens@@ -69,7 +71,7 @@                      , transformers >= 0.3                      , time >= 1.5                      , vector-                     , megaparsec >= 5.0 && <6.6+                     , megaparsec >= 7.0 && <7.1                      , containers                      , optparse-applicative                      , directory@@ -86,8 +88,8 @@   default-language:    Haskell2010   build-depends:       base >= 4.9 && < 5                      , hledger-iadd-                     , hledger-lib >= 1.5 && < 2.0-                     , brick >= 0.17+                     , hledger-lib >= 1.12 && < 1.13+                     , brick >= 0.27                      , vty >= 5.4                      , text                      , microlens@@ -100,7 +102,7 @@                      , xdg-basedir                      , unordered-containers                      , free >= 4.12.4-                     , megaparsec >= 5.0 && <6.6+                     , megaparsec >= 7.0 && <7.1   ghc-options:         -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing  test-suite spec@@ -114,7 +116,7 @@   default-language:   Haskell2010   build-depends:      base >= 4.9 && < 5                     , hledger-iadd-                    , hledger-lib >= 1.5 && < 2.0+                    , hledger-lib >= 1.12 && < 1.13                     , text                     , transformers >= 0.3                     , time >= 1.5@@ -122,6 +124,7 @@                     , hspec                     , QuickCheck                     , free >= 4.12.4-                    , megaparsec >= 5.0 && <6.6+                    , megaparsec >= 7.0 && <7.1                     , text-zipper >= 0.10+  build-tool-depends: hspec-discover:hspec-discover ==2.*   ghc-options:        -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing

@@ -6,7 +6,8 @@ import qualified Hledger as HL import           Data.Functor.Identity import           Control.Monad.Trans.State.Strict-import           Text.Megaparsec.Compat hiding (Parser)+import           Text.Megaparsec+import           Text.Megaparsec.Char  #if MIN_VERSION_hledger_lib(1,3,1) type Parser a = HL.JournalParser Identity a@@ -16,7 +17,7 @@  parseAmount :: HL.Journal -> Text -> Either String HL.MixedAmount parseAmount journal t = case runIdentity $ runParserT (evalStateT (mixed <* optional space <* eof) journal) "" t of-  Left err -> Left (parseErrorPretty err)+  Left err -> Left (errorBundlePretty err)   Right res -> Right res  mixed :: Parser HL.MixedAmount@@ -27,7 +28,7 @@  factor :: Parser HL.Amount factor =  (char '+' >> lexeme HL.amountp)-      <|> (char '-' >> flip HL.divideAmount (-1) <$> lexeme HL.amountp)+      <|> (char '-' >> HL.divideAmount (-1) <$> lexeme HL.amountp)       <|> HL.amountp  lexeme :: Parser a -> Parser a

@@ -49,11 +49,15 @@ import           Control.Monad import           Data.Functor.Identity import           Data.Semigroup ((<>))+import qualified Data.List.NonEmpty as NE++import qualified Data.Set as S+-- import           Data.Set (Set) import           Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import qualified Text.Megaparsec as P-import           Text.Megaparsec.Compat hiding (option)+import           Text.Megaparsec hiding (option)+import           Text.Megaparsec.Char import           Data.Maybe -- import           Text.Megaparsec.Text @@ -67,9 +71,9 @@   showErrorComponent (TypeError typ name) =     "in " ++ T.unpack typ ++ " argument for option " ++ T.unpack name -type OParser = Parsec (CustomError ConfParseError) Text+type OParser = Parsec ConfParseError Text -type CustomParseError = ParseError Char (CustomError ConfParseError)+type CustomParseError = ParseErrorBundle Text ConfParseError  -- | Parse a config file from a 'Text'. parseConfig :: FilePath -- ^ File path to use in error messages@@ -140,11 +144,11 @@   printArgument = T.pack . show  instance OptionArgument String where-  mkParser = ("string",  many anyChar)+  mkParser = ("string",  many anySingle)   printArgument = quote . T.pack  instance OptionArgument Text where-  mkParser = ("string",  T.pack <$> many anyChar)+  mkParser = ("string",  T.pack <$> many anySingle)   printArgument = quote  quote :: Text -> Text@@ -189,6 +193,23 @@          Right res -> Right $ fmap ($ res) rest   | otherwise = fmap (Ap opt) $ parseOption rest ass +mkCustomError :: SourcePos -> e -> ParseErrorBundle Text e+mkCustomError pos e = ParseErrorBundle+  { bundleErrors = NE.fromList [FancyError 0 (S.singleton (ErrorCustom e))]+  , bundlePosState = PosState+    { pstateInput = ""+    , pstateOffset = 0+    , pstateSourcePos = pos+    , pstateTabWidth = mkPos 1+    , pstateLinePrefix = ""+    }+  }+addCustomError :: ParseErrorBundle Text e -> e -> ParseErrorBundle Text e+addCustomError e customE =+  e { bundleErrors = NE.cons+                      (FancyError 0 (S.singleton (ErrorCustom customE)))+                      (bundleErrors e)}+ -- Low level assignment parser  data Assignment = Assignment@@ -208,7 +229,7 @@ assignment :: OParser Assignment assignment = do   Assignment-    <$> getPosition <*> key <* whitespaceNoComment+    <$> getSourcePos <*> key <* whitespaceNoComment     <*  char '=' <* whitespaceNoComment     <*> value @@ -216,7 +237,7 @@ key = T.pack <$> some (alphaNumChar <|> char '_' <|> char '-')  value :: OParser AssignmentValue-value = AssignmentValue <$> getPosition <*> content <* whitespaceNoEOL <* (void eol <|> eof)+value = AssignmentValue <$> getSourcePos <*> content <* whitespaceNoEOL <* (void eol <|> eof)  content :: OParser Text content =  escapedString@@ -229,7 +250,7 @@ escapedString :: OParser Text escapedString = (T.pack <$> (char '"' *> many escapedChar <* char '"'))                 <?> "quoted string"-  where escapedChar =  char '\\' *> anyChar+  where escapedChar =  char '\\' *> anySingle                    <|> noneOf ("\"" :: String)  whitespace :: OParser ()@@ -246,3 +267,20 @@  parseNumber :: Read a => OParser a parseNumber = read <$> ((<>) <$> (maybeToList <$> optional (char '-')) <*> some digitChar)+++-- | Like 'parse', but start at a specific source position instead of 0.+parseWithStart :: (Stream s, Ord e)+               => Parsec e s a -> SourcePos -> s -> Either (ParseErrorBundle s e) a+parseWithStart p pos s = snd (runParser' p state)+  where state = State+          { stateInput = s+          , stateOffset = 0+          , statePosState =PosState+            { pstateInput = s+            , pstateOffset = 0+            , pstateSourcePos = pos+            , pstateTabWidth = mkPos 1+            , pstateLinePrefix = ""+            }+          }

@@ -19,9 +19,13 @@        ) where  import           Control.Applicative hiding (many, some)+import           Data.List import           Data.Maybe import           Data.Monoid+import           Data.Ord import qualified Data.Semigroup as Sem+import           Data.Void+ import           Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -31,7 +35,8 @@ import           Data.Time.Ext hiding (parseTime) import           Data.Time.Calendar.WeekDate import qualified Hledger.Data.Dates as HL-import           Text.Megaparsec.Compat+import           Text.Megaparsec+import           Text.Megaparsec.Char import           Text.Printf (printf, PrintfArg)  newtype DateFormat = DateFormat [DateSpec]@@ -51,7 +56,7 @@ parseHLDate :: Day -> Text -> Either Text Day parseHLDate current text = case parse HL.smartdate "date" text of   Right res -> Right $ HL.fixSmartDate current res-  Left err -> Left $ T.pack $ parseErrorPretty err+  Left err -> Left $ T.pack $ errorBundlePretty err  parseHLDateWithToday :: Text -> IO (Either Text Day) parseHLDateWithToday text = flip parseHLDate text <$> getLocalDay@@ -67,9 +72,12 @@  parseDateFormat :: Text -> Either Text DateFormat parseDateFormat text = case parse dateSpec "date-format" text of-  Left err  -> Left $ T.pack $ parseErrorPretty err+  Left err  -> Left $ T.pack $ errorBundlePretty err   Right res -> Right res ++type Parser = Parsec Void Text+ dateSpec :: Parser DateFormat dateSpec = DateFormat <$> (many oneTok <* eof) @@ -107,7 +115,7 @@       num = completeIDate . fmap getFirst <$> parseDate' spec <* eof    in case parse ((try en <|> num) <* eof) "date" text of-    Left err -> Left $ T.pack $ parseErrorPretty err+    Left err -> Left $ T.pack $ errorBundlePretty err     Right Nothing -> Left "Invalid Date"     Right (Just d) -> Right d @@ -178,18 +186,25 @@   [ addDays 1    <$ string "tomorrow"   , id           <$ string "today"   , addDays (-1) <$ string "yesterday"+  , addDays (-1) <$ string "yest"   ]  weekDays :: [Parser (Day -> Day)]-weekDays = zipWith (\i name -> weekDay i <$ try (string name)) [1..]-  [ "monday"-  , "tuesday"-  , "wednesday"-  , "thursday"-  , "friday"-  , "saturday"-  , "sunday"-  ]+weekDays = map (\(i, name) -> weekDay i <$ try (string name)) sortedDays+  where -- sort the days so that the parser finds the longest match+        sortedDays :: [(Int, Text)]+        sortedDays = sortOn (Down . T.length . snd) flattenedDays+        flattenedDays :: [(Int, Text)]+        flattenedDays = concatMap (\(i, xs) -> fmap (i,) xs) days+        days :: [(Int, [Text])]+        days = [ (1, ["monday", "mon"])+               , (2, ["tuesday", "tues", "tue"])+               , (3, ["wednesday", "wed"])+               , (4, ["thursday", "thur"])+               , (5, ["friday", "fri"])+               , (6, ["saturday", "sat"])+               , (7, ["sunday", "sun"])+               ]  -- | Computes a relative date by the given weekday --

@@ -29,6 +29,8 @@ import qualified Data.Text as T import           Data.Time.Ext hiding (parseTime) import qualified Hledger as HL+import           Data.Foldable+import           Control.Applicative  import           AmountParser import           DateParser@@ -282,7 +284,7 @@ negativeAmountSum :: HL.Transaction -> HL.MixedAmount negativeAmountSum trans =   let (rsum, _, _) = HL.transactionPostingBalances trans-  in HL.divideMixedAmount rsum (-1)+  in HL.divideMixedAmount (-1) rsum  -- | Compare two transaction descriptions based on their number of occurences in -- the given journal.@@ -333,7 +335,7 @@     postingAttributes =       [ cmp HL.pdate, cmp HL.pdate2, cmp HL.pstatus, cmp HL.paccount       , cmpMixedAmount `on` HL.pamount, cmpPType `on` HL.ptype-      , cmp HL.pbalanceassertion+      , (fmap fold . liftA2 cmpBalanceAssertion) `on` HL.pbalanceassertion       ]      -- | Ammount attributes that are compared to determine duplicates@@ -344,7 +346,7 @@     cmpTransaction :: HL.Transaction -> HL.Transaction -> Ordering     cmpTransaction = lexical transactionAttributes -    +     -- | Compare two posting lists of postings by sorting them deterministically     -- and then compare correspondings list elements     cmpPostings :: [HL.Posting] -> [HL.Posting] -> Ordering@@ -375,6 +377,9 @@         mconcat $           compare (length as1) (length as2) : zipWith cmpAmount sortedAs1 sortedAs2 +    cmpBalanceAssertion :: HL.BalanceAssertion -> HL.BalanceAssertion -> Ordering+    cmpBalanceAssertion = lexical [cmp HL.baamount, cmp HL.baexact]+     sortPostings :: [HL.Posting] -> [HL.Posting]     sortPostings = sortBy (lexical postingAttributes) @@ -384,7 +389,7 @@      -- | Apply two things with multiple predicats and combine the results lexicographically     lexical :: [a -> b -> Ordering] -> a -> b -> Ordering-    lexical fs x y = mconcat (map (\f -> f x y) fs)+    lexical = fold -- hehe  fromEither :: Either a a -> a fromEither = either id id

@@ -1,132 +0,0 @@-{-# LANGUAGE CPP, GADTs #-}---- | Compatibility module to bridge the gap between megaparsec-5 and megaparsec-6------ Import this instead of Text.Megaparsec, Text.Megaparsec.Char and--- Text.Megaparsec.Text-module Text.Megaparsec.Compat-  (-  -- * Re-exports-    module Text.Megaparsec.Char-  , module Text.Megaparsec-  -- * Compatibility reimplementations-  , Parser-#if MIN_VERSION_megaparsec(6,0,0)-  , Dec-#endif-  , string-  -- * Custom error handling-  , CustomError-  , mkCustomError-  , addCustomError-  -- * Additional helpers-  , parseWithStart-  ) where--import qualified Data.Set as S-import           Data.Text (Text)-import           Text.Megaparsec.Char hiding (string)-import qualified Text.Megaparsec.Char as P-import qualified Data.List.NonEmpty as NE--#if MIN_VERSION_megaparsec(6,0,0)-import           Data.Set (Set)-import           Data.Void-import           Text.Megaparsec-#else-import           Text.Megaparsec.Prim-import           Text.Megaparsec hiding (string)-import qualified Data.Text as T-#endif--#if MIN_VERSION_megaparsec(6,0,0)--- | Custom error type for when no custom errors are needed-type Dec = Void-#endif---- | Same as the type in Text.Megaparsec.Text from megaparsec-5-type Parser = Parsec Dec Text---- | Custom error type that mimics FancyError of megaparsec-6 but retains--- information about unexpected and expected tokens.-#if MIN_VERSION_megaparsec(6,0,0)-data CustomError e = CustomError-  (Maybe (ErrorItem Char))      -- unexpected-  (Set (ErrorItem Char))        -- expected-  e                             -- custom error data-  deriving (Eq, Show, Ord)--instance ShowErrorComponent e => ShowErrorComponent (CustomError e) where-  showErrorComponent (CustomError us es e) =-    parseErrorTextPretty (TrivialError undefined us es :: ParseError Char Void)-    ++ showErrorComponent e-#else-data CustomError e = CustomError e-                   | CustomFail String-                   | CustomIndentation Ordering Pos Pos-  deriving (Eq, Ord, Show)--instance Ord e => ErrorComponent (CustomError e) where-  representFail = CustomFail-  representIndentation = CustomIndentation--instance ShowErrorComponent e => ShowErrorComponent (CustomError e) where-  showErrorComponent (CustomError e) = showErrorComponent e-  showErrorComponent (CustomFail msg) = msg-  showErrorComponent (CustomIndentation ord ref actual) =-    "incorrect indentation (got " ++ show (unPos actual) ++-    ", should be " ++ p ++ show (unPos ref) ++ ")"-    where p = case ord of-                LT -> "less than "-                EQ -> "equal to "-                GT -> "greater than "-#endif---- | Wrap a custom error type into a 'ParseError'.-mkCustomError :: SourcePos -> e -> ParseError t (CustomError e)-#if MIN_VERSION_megaparsec(6,0,0)-mkCustomError pos custom = FancyError (neSingleton pos)-  (S.singleton (ErrorCustom (CustomError Nothing S.empty custom)))-#else-mkCustomError pos custom = ParseError (neSingleton pos) S.empty S.empty-  (S.singleton (CustomError custom))-#endif---- | Add a custom error to an already existing error.------ This retains the original information such as expected and unexpected tokens--- as well as the source position.-addCustomError :: Ord e => ParseError Char (CustomError e) -> e -> ParseError Char (CustomError e)-#if MIN_VERSION_megaparsec(6,0,0)-addCustomError e custom = case e of-  TrivialError source us es ->-    FancyError source (S.singleton (ErrorCustom (CustomError us es custom)))-  FancyError source es ->-    FancyError source (S.insert (ErrorCustom (CustomError Nothing S.empty custom)) es)-#else-addCustomError e custom = e { errorCustom = S.insert (CustomError custom) (errorCustom e) }-#endif----- | Like 'parse', but start at a specific source position instead of 0.-#if MIN_VERSION_megaparsec(6,0,0)-parseWithStart :: (Stream s, Ord e)-#else-parseWithStart :: (Stream s, ErrorComponent e)-#endif-               => Parsec e s a -> SourcePos -> s -> Either (ParseError (Token s) e) a-parseWithStart p pos = parse p' (sourceName pos)-  where p' = do setPosition pos; p----- | Reimplementation of 'Text.Megaparsec.Char.string', but specialized to 'Text'.-#if MIN_VERSION_megaparsec(6,0,0)-string :: MonadParsec e s m => Tokens s -> m (Tokens s)-string = P.string-#else-string :: (MonadParsec e s m, Token s ~ Char) => Text -> m Text-string x = T.pack <$> P.string (T.unpack x)-#endif--neSingleton :: a -> NE.NonEmpty a-neSingleton x = x NE.:| []

@@ -54,7 +54,8 @@ import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, hPutStrLn, stderr) -- explicit package import since hledger-lib defines the same module-import qualified "hledger-iadd" Text.Megaparsec.Compat as P+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P  import Brick.Widgets.CommentDialog import Brick.Widgets.HelpMessage@@ -448,7 +449,7 @@     Left (_ :: SomeException) -> return (parserDefault $ confParser def)     Right res -> case parseConfig path res (confParser def) of       Left err -> do-        putStr (P.parseErrorPretty err)+        putStr (P.errorBundlePretty err)         exitFailure       Right res' -> return res' 

@@ -104,6 +104,48 @@       parseDate (fromGregorian 2016 9 15) yearMonth "2016.1"     ) `shouldBe` Right (fromGregorian 2016 1 31) +  it "literally yesterday" $ do+    parseGerman 2018 10 18 "yesterday" `shouldBe` Right (fromGregorian 2018 10 17)+    parseGerman 2018 10 18 "yest" `shouldBe` Right (fromGregorian 2018 10 17)++  it "literally today" $ do+    parseGerman 2018 10 18 "today" `shouldBe` Right (fromGregorian 2018 10 18)++  it "literally tomorrow" $ do+    parseGerman 2018 10 18 "tomorrow" `shouldBe` Right (fromGregorian 2018 10 19)++  it "literally monday" $ do+    parseGerman 2018 10 18 "monday" `shouldBe` Right (fromGregorian 2018 10 15)+    parseGerman 2018 10 18 "mon" `shouldBe` Right (fromGregorian 2018 10 15)++  it "literally tuesday" $ do+    parseGerman 2018 10 18 "tuesday" `shouldBe` Right (fromGregorian 2018 10 16)+    parseGerman 2018 10 18 "tues" `shouldBe` Right (fromGregorian 2018 10 16)+    parseGerman 2018 10 18 "tue" `shouldBe` Right (fromGregorian 2018 10 16)++  it "literally wednesday" $ do+    parseGerman 2018 10 18 "wednesday" `shouldBe` Right (fromGregorian 2018 10 17)+    parseGerman 2018 10 18 "wed" `shouldBe` Right (fromGregorian 2018 10 17)++  it "literally thursday" $ do+    parseGerman 2018 10 18 "thursday" `shouldBe` Right (fromGregorian 2018 10 18)+    parseGerman 2018 10 18 "thur" `shouldBe` Right (fromGregorian 2018 10 18)++  it "literally friday" $ do+    parseGerman 2018 10 18 "friday" `shouldBe` Right (fromGregorian 2018 10 12)+    parseGerman 2018 10 18 "fri" `shouldBe` Right (fromGregorian 2018 10 12)++  it "literally saturday" $ do+    parseGerman 2018 10 18 "saturday" `shouldBe` Right (fromGregorian 2018 10 13)+    parseGerman 2018 10 18 "sat" `shouldBe` Right (fromGregorian 2018 10 13)++  it "literally sunday" $ do+    parseGerman 2018 10 18 "sunday" `shouldBe` Right (fromGregorian 2018 10 14)+    parseGerman 2018 10 18 "sun" `shouldBe` Right (fromGregorian 2018 10 14)++  it "literally satan" $ do+    parseGerman 2018 10 18 "satan" `shouldSatisfy` isLeft+   where     parseGerman :: Integer -> Int -> Int -> String -> Either Text Day     parseGerman y m d str = parseDate (fromGregorian y m d)  german (T.pack str)

@@ -91,7 +91,9 @@     accountsByFrequency j `shouldBe` ["x:y", "x:z", "x"]    it "includes accounts from the 'account directive'" $ do-#if MIN_VERSION_hledger_lib(1,9,0)+#if MIN_VERSION_hledger_lib(1,11,0)+    let j = (mkJournal [ ((2017, 1, 1), "Foo", [("x:y", 2)]) ]) { HL.jdeclaredaccounts = ["foo:bar"]}+#elif MIN_VERSION_hledger_lib(1,9,0)     let j = (mkJournal [ ((2017, 1, 1), "Foo", [("x:y", 2)]) ]) { HL.jaccounts = [("foo:bar", Nothing)]} #else     let j = (mkJournal [ ((2017, 1, 1), "Foo", [("x:y", 2)]) ]) { HL.jaccounts = ["foo:bar"]}