diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Hans-Peter Deifel (c) 2015 +Copyright Hans-Peter Deifel (c) 2018 All rights reserved. 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.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 maintainer: Hans-Peter Deifel -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 diff --git a/src/AmountParser.hs b/src/AmountParser.hs --- a/src/AmountParser.hs +++ b/src/AmountParser.hs @@ -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 diff --git a/src/ConfigParser.hs b/src/ConfigParser.hs --- a/src/ConfigParser.hs +++ b/src/ConfigParser.hs @@ -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 = "" + } + } diff --git a/src/DateParser.hs b/src/DateParser.hs --- a/src/DateParser.hs +++ b/src/DateParser.hs @@ -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 -- diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Text/Megaparsec/Compat.hs b/src/Text/Megaparsec/Compat.hs deleted file mode 100644 --- a/src/Text/Megaparsec/Compat.hs +++ /dev/null @@ -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.:| [] diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -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' diff --git a/tests/DateParserSpec.hs b/tests/DateParserSpec.hs --- a/tests/DateParserSpec.hs +++ b/tests/DateParserSpec.hs @@ -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) diff --git a/tests/ModelSpec.hs b/tests/ModelSpec.hs --- a/tests/ModelSpec.hs +++ b/tests/ModelSpec.hs @@ -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"]}