diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 0e5334348..2838f3b3c 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -77,6 +77,7 @@ where import Prelude () import "base-compat-batteries" Prelude.Compat +import Control.Applicative.Permutations import Control.Monad import "base-compat-batteries" Data.List.Compat import Data.Default @@ -96,7 +97,7 @@ import Data.Time.LocalTime import Safe (headMay, lastMay, readMay) import Text.Megaparsec import Text.Megaparsec.Char -import Text.Megaparsec.Perm +import Text.Megaparsec.Custom import Text.Printf import Hledger.Data.Types @@ -314,13 +315,14 @@ earliest (Just d1) (Just d2) = Just $ min d1 d2 -- | Parse a period expression to an Interval and overall DateSpan using -- the provided reference date, or return a parse error. -parsePeriodExpr :: Day -> Text -> Either (ParseError Char CustomErr) (Interval, DateSpan) +parsePeriodExpr + :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan) parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s) -- | Like parsePeriodExpr, but call error' on failure. parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan) parsePeriodExpr' refdate s = - either (error' . ("failed to parse:" ++) . parseErrorPretty) id $ + either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $ parsePeriodExpr refdate s maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) @@ -380,13 +382,14 @@ fixSmartDateStr :: Day -> Text -> String fixSmartDateStr d s = either (\e->error' $ printf "could not parse date %s %s" (show s) (show e)) id - $ (fixSmartDateStrEither d s :: Either (ParseError Char CustomErr) String) + $ (fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String) -- | A safe version of fixSmartDateStr. -fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char CustomErr) String +fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) String fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d -fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char CustomErr) Day +fixSmartDateStrEither' + :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of Right sd -> Right $ fixSmartDate d sd Left e -> Left e @@ -987,7 +990,9 @@ reportingintervalp = choice' [ return $ DayOfMonth n, do string' "every" let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m) - d_o_y <- makePermParser $ DayOfYear <$$> try (skipMany spacenonewline *> mnth) <||> try (skipMany spacenonewline *> nth) + d_o_y <- runPermutation $ + DayOfYear <$> toPermutation (try (skipMany spacenonewline *> mnth)) + <*> toPermutation (try (skipMany spacenonewline *> nth)) optOf_ "year" return d_o_y, do string' "every" diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 9969d28af..ed6a2069c 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -163,6 +163,7 @@ instance Sem.Semigroup Journal where ,jparsealiases = jparsealiases j2 -- ,jparsetransactioncount = jparsetransactioncount j1 + jparsetransactioncount j2 ,jparsetimeclockentries = jparsetimeclockentries j1 <> jparsetimeclockentries j2 + ,jincludefilestack = jincludefilestack j2 ,jdeclaredaccounts = jdeclaredaccounts j1 <> jdeclaredaccounts j2 ,jcommodities = jcommodities j1 <> jcommodities j2 ,jinferredcommodities = jinferredcommodities j1 <> jinferredcommodities j2 @@ -189,8 +190,9 @@ nulljournal = Journal { ,jparseparentaccounts = [] ,jparsealiases = [] -- ,jparsetransactioncount = 0 - ,jparsetimeclockentries = [] - ,jdeclaredaccounts = [] + ,jparsetimeclockentries = [] + ,jincludefilestack = [] + ,jdeclaredaccounts = [] ,jcommodities = M.fromList [] ,jinferredcommodities = M.fromList [] ,jmarketprices = [] diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 4fee465a0..1521ac8da 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -366,6 +366,7 @@ data Journal = Journal { ,jparsealiases :: [AccountAlias] -- ^ the current account name aliases in effect, specified by alias directives (& options ?) -- ,jparsetransactioncount :: Integer -- ^ the current count of transactions parsed so far (only journal format txns, currently) ,jparsetimeclockentries :: [TimeclockEntry] -- ^ timeclock sessions which have not been clocked out + ,jincludefilestack :: [FilePath] -- principal data ,jdeclaredaccounts :: [AccountName] -- ^ Accounts declared by account directives, in parse order (after journal finalisation) ,jcommodities :: M.Map CommoditySymbol Commodity -- ^ commodities and formats declared by commodity directives diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index c760c3d3a..b305fa957 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -29,10 +29,13 @@ module Hledger.Read.Common ( rtp, runJournalParser, rjp, + runErroringJournalParser, + rejp, genericSourcePos, journalSourcePos, applyTransactionModifiers, parseAndFinaliseJournal, + parseAndFinaliseJournal', setYear, getYear, setDefaultCommodityAndStyle, @@ -99,7 +102,7 @@ where import Prelude () import "base-compat-batteries" Prelude.Compat hiding (readFile) import "base-compat-batteries" Control.Monad.Compat -import Control.Monad.Except (ExceptT(..), throwError) +import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import Control.Monad.State.Strict import Data.Bifunctor (bimap, second) import Data.Char @@ -191,15 +194,28 @@ rawOptsToInputOpts rawopts = InputOpts{ --- * parsing utilities -- | Run a text parser in the identity monad. See also: parseWithState. -runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char CustomErr) a +runTextParser, rtp + :: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a runTextParser p t = runParser p "" t rtp = runTextParser -- | Run a journal parser in some monad. See also: parseWithState. -runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either (ParseError Char CustomErr) a) +runJournalParser, rjp + :: Monad m + => JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a) runJournalParser p t = runParserT (evalStateT p mempty) "" t rjp = runJournalParser +-- | Run an erroring journal parser in some monad. See also: parseWithState. +runErroringJournalParser, rejp + :: Monad m + => ErroringJournalParser m a + -> Text + -> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a)) +runErroringJournalParser p t = + runExceptT $ runParserT (evalStateT p mempty) "" t +rejp = runErroringJournalParser + genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p) @@ -221,19 +237,46 @@ applyTransactionModifiers j = j { jtxns = map applyallmodifiers $ jtxns j } -- | Given a megaparsec ParsedJournal parser, input options, file -- path and file content: parse and post-process a Journal, or give an error. -parseAndFinaliseJournal :: JournalParser IO ParsedJournal -> InputOpts +parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts -> FilePath -> Text -> ExceptT String IO Journal parseAndFinaliseJournal parser iopts f txt = do t <- liftIO getClockTime y <- liftIO getCurrentYear - ep <- liftIO $ runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt + let initJournal = nulljournal + { jparsedefaultyear = Just y + , jincludefilestack = [f] } + eep <- liftIO $ runExceptT $ + runParserT (evalStateT parser initJournal) f txt + case eep of + Left finalParseError -> + throwError $ finalErrorBundlePretty $ attachSource f txt finalParseError + + Right ep -> case ep of + Left e -> throwError $ customErrorBundlePretty e + + Right pj -> + let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in + case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of + Right j -> return j + Left e -> throwError e + +parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts + -> FilePath -> Text -> ExceptT String IO Journal +parseAndFinaliseJournal' parser iopts f txt = do + t <- liftIO getClockTime + y <- liftIO getCurrentYear + let initJournal = nulljournal + { jparsedefaultyear = Just y + , jincludefilestack = [f] } + ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt case ep of + Left e -> throwError $ customErrorBundlePretty e + Right pj -> let pj' = if auto_ iopts then applyTransactionModifiers pj else pj in case journalFinalise t f txt (not $ ignore_assertions_ iopts) pj' of Right j -> return j Left e -> throwError e - Left e -> throwError $ customParseErrorPretty txt e setYear :: Year -> JournalParser m () setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) @@ -345,43 +388,43 @@ datep = do datep' :: Maybe Year -> TextParser m Day datep' mYear = do - startPos <- getPosition + startOffset <- getOffset d1 <- decimal "year or month" sep <- satisfy isDateSepChar "date separator" d2 <- decimal "month or day" - fullDate startPos d1 sep d2 <|> partialDate startPos mYear d1 sep d2 + fullDate startOffset d1 sep d2 <|> partialDate startOffset mYear d1 sep d2 "full or partial date" where - fullDate :: SourcePos -> Integer -> Char -> Int -> TextParser m Day - fullDate startPos year sep1 month = do + fullDate :: Int -> Integer -> Char -> Int -> TextParser m Day + fullDate startOffset year sep1 month = do sep2 <- satisfy isDateSepChar "date separator" day <- decimal "day" - endPos <- getPosition + endOffset <- getOffset let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day - when (sep1 /= sep2) $ parseErrorAtRegion startPos endPos $ + when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startOffset endOffset $ "invalid date (mixing date separators is not allowed): " ++ dateStr case fromGregorianValid year month day of - Nothing -> parseErrorAtRegion startPos endPos $ + Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ "well-formed but invalid date: " ++ dateStr Just date -> pure $! date partialDate - :: SourcePos -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day - partialDate startPos mYear month sep day = do - endPos <- getPosition + :: Int -> Maybe Year -> Integer -> Char -> Int -> TextParser m Day + partialDate startOffset mYear month sep day = do + endOffset <- getOffset case mYear of Just year -> case fromGregorianValid year (fromIntegral month) day of - Nothing -> parseErrorAtRegion startPos endPos $ + Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ "well-formed but invalid date: " ++ dateStr Just date -> pure $! date where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day - Nothing -> parseErrorAtRegion startPos endPos $ + Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ "partial date "++dateStr++" found, but the current year is unknown" where dateStr = show month ++ [sep] ++ show day @@ -409,26 +452,27 @@ datetimep' mYear = do where timeOfDay :: TextParser m TimeOfDay timeOfDay = do - pos1 <- getPosition + off1 <- getOffset h' <- twoDigitDecimal "hour" - pos2 <- getPosition - unless (h' >= 0 && h' <= 23) $ parseErrorAtRegion pos1 pos2 - "invalid time (bad hour)" + off2 <- getOffset + unless (h' >= 0 && h' <= 23) $ customFailure $ + parseErrorAtRegion off1 off2 "invalid time (bad hour)" char ':' "':' (hour-minute separator)" - pos3 <- getPosition + off3 <- getOffset m' <- twoDigitDecimal "minute" - pos4 <- getPosition - unless (m' >= 0 && m' <= 59) $ parseErrorAtRegion pos3 pos4 - "invalid time (bad minute)" + off4 <- getOffset + unless (m' >= 0 && m' <= 59) $ customFailure $ + parseErrorAtRegion off3 off4 "invalid time (bad minute)" s' <- option 0 $ do char ':' "':' (minute-second separator)" - pos5 <- getPosition + off5 <- getOffset s' <- twoDigitDecimal "second" - pos6 <- getPosition - unless (s' >= 0 && s' <= 59) $ parseErrorAtRegion pos5 pos6 - "invalid time (bad second)" -- we do not support leap seconds + off6 <- getOffset + unless (s' >= 0 && s' <= 59) $ customFailure $ + parseErrorAtRegion off5 off6 "invalid time (bad second)" + -- we do not support leap seconds pure s' pure $ TimeOfDay h' m' (fromIntegral s') @@ -524,22 +568,22 @@ amountwithoutpricep = do suggestedStyle <- getAmountStyle c commodityspaced <- lift $ skipMany' spacenonewline sign2 <- lift $ signp - posBeforeNum <- getPosition + offBeforeNum <- getOffset ambiguousRawNum <- lift rawnumberp mExponent <- lift $ optional $ try exponentp - posAfterNum <- getPosition - let numRegion = (posBeforeNum, posAfterNum) + offAfterNum <- getOffset + let numRegion = (offBeforeNum, offAfterNum) (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} return $ Amount c (sign (sign2 q)) NoPrice s mult rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount rightornosymbolamountp mult sign = label "amount" $ do - posBeforeNum <- getPosition + offBeforeNum <- getOffset ambiguousRawNum <- lift rawnumberp mExponent <- lift $ optional $ try exponentp - posAfterNum <- getPosition - let numRegion = (posBeforeNum, posAfterNum) + offAfterNum <- getOffset + let numRegion = (offBeforeNum, offAfterNum) mSpaceAndCommodity <- lift $ optional $ try $ (,) <$> skipMany' spacenonewline <*> commoditysymbolp case mSpaceAndCommodity of -- right symbol amount @@ -563,7 +607,7 @@ amountwithoutpricep = do -- For reducing code duplication. Doesn't parse anything. Has the type -- of a parser only in order to throw parse errors (for convenience). interpretNumber - :: (SourcePos, SourcePos) + :: (Int, Int) -- offsets -> Maybe AmountStyle -> Either AmbiguousNumber RawNumber -> Maybe Int @@ -571,7 +615,8 @@ amountwithoutpricep = do interpretNumber posRegion suggestedStyle ambiguousNum mExp = let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum in case fromRawNumber rawNum mExp of - Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg + Left errMsg -> customFailure $ + uncurry parseErrorAtRegion posRegion errMsg Right res -> pure res -- | Parse an amount from a string, or get an error. @@ -629,7 +674,7 @@ partialbalanceassertionp :: JournalParser m BalanceAssertion partialbalanceassertionp = optional $ do sourcepos <- try $ do lift (skipMany spacenonewline) - sourcepos <- genericSourcePos <$> lift getPosition + sourcepos <- genericSourcePos <$> lift getSourcePos char '=' pure sourcepos lift (skipMany spacenonewline) @@ -788,9 +833,10 @@ rawnumberp = label "number" $ do fail "invalid number (invalid use of separator)" mExtraFragment <- optional $ lookAhead $ try $ - char ' ' *> getPosition <* digitChar + char ' ' *> getOffset <* digitChar case mExtraFragment of - Just pos -> parseErrorAt pos "invalid number (excessive trailing digits)" + Just off -> customFailure $ + parseErrorAt off "invalid number (excessive trailing digits)" Nothing -> pure () return $ dbg8 "rawnumberp" rawNumber @@ -1150,19 +1196,19 @@ commenttagsanddatesp mYear = do -- default date is provided. A missing year in DATE2 will be inferred -- from DATE. -- --- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]" +-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]" -- Right [("date",2016-01-02),("date2",2016-03-04)] -- --- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]" +-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]" -- Left ...not a bracketed date... -- --- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]" --- Left ...1:11:...well-formed but invalid date: 2016/1/32... +-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]" +-- Left ...1:2:...well-formed but invalid date: 2016/1/32... -- --- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]" --- Left ...1:6:...partial date 1/31 found, but the current year is unknown... +-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]" +-- Left ...1:2:...partial date 1/31 found, but the current year is unknown... -- --- >>> either (Left . parseErrorPretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" +-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" -- Left ...1:13:...expecting month or day... -- bracketeddatetagsp diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 34dae98a0..419bf2435 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -38,7 +38,6 @@ import Control.Monad.Except import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Data.Char (toLower, isDigit, isSpace, ord) import "base-compat-batteries" Data.List.Compat -import Data.List.NonEmpty (fromList) import Data.Maybe import Data.Ord import qualified Data.Set as S @@ -59,12 +58,12 @@ import System.FilePath import qualified Data.Csv as Cassava import qualified Data.Csv.Parser.Megaparsec as CassavaMP import qualified Data.ByteString as B -import Data.ByteString.Lazy (fromStrict) +import qualified Data.ByteString.Lazy as BL import Data.Foldable import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char +import Text.Megaparsec.Custom import Text.Printf (printf) -import Data.Word import Hledger.Data import Hledger.Utils @@ -76,7 +75,7 @@ type Record = [Field] type Field = String -data CSVError = CSVError (ParseError Word8 CassavaMP.ConversionError) +data CSVError = CSVError (ParseErrorBundle BL.ByteString CassavaMP.ConversionError) deriving Show reader :: Reader @@ -193,7 +192,7 @@ parseCassava separator path content = Left msg -> Left $ CSVError msg Right a -> Right a where parseResult = fmap parseResultToCsv $ CassavaMP.decodeWith (decodeOptions separator) Cassava.NoHeader path lazyContent - lazyContent = fromStrict $ T.encodeUtf8 content + lazyContent = BL.fromStrict $ T.encodeUtf8 content decodeOptions :: Char -> Cassava.DecodeOptions decodeOptions separator = Cassava.defaultDecodeOptions { @@ -431,19 +430,19 @@ parseAndValidateCsvRules :: FilePath -> T.Text -> ExceptT String IO CsvRules parseAndValidateCsvRules rulesfile s = do let rules = parseCsvRules rulesfile s case rules of - Left e -> ExceptT $ return $ Left $ parseErrorPretty e + Left e -> ExceptT $ return $ Left $ customErrorBundlePretty e Right r -> do r_ <- liftIO $ runExceptT $ validateRules r ExceptT $ case r_ of - Left s -> return $ Left $ parseErrorPretty $ makeParseError rulesfile s + Left s -> return $ Left $ parseErrorPretty $ makeParseError s Right r -> return $ Right r where - makeParseError :: FilePath -> String -> ParseError Char String - makeParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s) + makeParseError :: String -> ParseError T.Text String + makeParseError s = FancyError 0 (S.singleton $ ErrorFail s) -- | Parse this text as CSV conversion rules. The file path is for error messages. -parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char CustomErr) CsvRules +parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text CustomErr) CsvRules -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s parseCsvRules rulesfile s = runParser (evalStateT rulesp rules) rulesfile s @@ -513,7 +512,7 @@ directives = ] directivevalp :: CsvRulesParser String -directivevalp = anyChar `manyTill` lift eolof +directivevalp = anySingle `manyTill` lift eolof fieldnamelistp :: CsvRulesParser [CsvFieldName] fieldnamelistp = (do @@ -588,7 +587,7 @@ assignmentseparatorp = do fieldvalp :: CsvRulesParser String fieldvalp = do lift $ dbgparse 2 "trying fieldvalp" - anyChar `manyTill` lift eolof + anySingle `manyTill` lift eolof conditionalblockp :: CsvRulesParser ConditionalBlock conditionalblockp = do @@ -631,7 +630,7 @@ regexp = do lift $ dbgparse 3 "trying regexp" notFollowedBy matchoperatorp c <- lift nonspace - cs <- anyChar `manyTill` lift eolof + cs <- anySingle `manyTill` lift eolof return $ strip $ c:cs -- fieldmatcher = do diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 6f9656a29..37b034869 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -124,10 +124,10 @@ aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++qu -- | A journal parser. Accumulates and returns a "ParsedJournal", -- which should be finalised/validated before use. -- --- >>> rjp (journalp <* eof) "2015/1/1\n a 0\n" --- Right Journal with 1 transactions, 1 accounts +-- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n" +-- Right (Right Journal with 1 transactions, 1 accounts) -- -journalp :: MonadIO m => JournalParser m ParsedJournal +journalp :: MonadIO m => ErroringJournalParser m ParsedJournal journalp = do many addJournalItemP eof @@ -135,7 +135,7 @@ journalp = do -- | A side-effecting parser; parses any kind of journal item -- and updates the parse state accordingly. -addJournalItemP :: MonadIO m => JournalParser m () +addJournalItemP :: MonadIO m => ErroringJournalParser m () addJournalItemP = -- all journal line types can be distinguished by the first -- character, can use choice without backtracking @@ -154,7 +154,7 @@ addJournalItemP = -- | Parse any journal directive and update the parse state accordingly. -- Cf http://hledger.org/manual.html#directives, -- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -directivep :: MonadIO m => JournalParser m () +directivep :: MonadIO m => ErroringJournalParser m () directivep = (do optional $ char '!' choice [ @@ -174,78 +174,74 @@ directivep = (do ] ) "directive" -includedirectivep :: MonadIO m => JournalParser m () +includedirectivep :: MonadIO m => ErroringJournalParser m () includedirectivep = do string "include" lift (skipSome spacenonewline) filename <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet - parentpos <- getPosition + parentoff <- getOffset + parentpos <- getSourcePos - filepaths <- getFilePaths parentpos filename + filepaths <- getFilePaths parentoff parentpos filename forM_ filepaths $ parseChild parentpos void newline where - getFilePaths parserpos filename = do + getFilePaths + :: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath] + getFilePaths parseroff parserpos filename = do curdir <- lift $ expandPath (takeDirectory $ sourceName parserpos) "" `orRethrowIOError` (show parserpos ++ " locating " ++ filename) -- Compiling filename as a glob pattern works even if it is a literal fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of Right x -> pure x - Left e -> parseErrorAt parserpos $ "Invalid glob pattern: " ++ e + Left e -> customFailure $ + parseErrorAt parseroff $ "Invalid glob pattern: " ++ e -- Get all matching files in the current working directory, sorting in -- lexicographic order to simulate the output of 'ls'. filepaths <- liftIO $ sort <$> globDir1 fileglob curdir if (not . null) filepaths then pure filepaths - else parseErrorAt parserpos $ "No existing files match pattern: " ++ filename + else customFailure $ parseErrorAt parseroff $ + "No existing files match pattern: " ++ filename + parseChild :: MonadIO m => SourcePos -> FilePath -> ErroringJournalParser m () parseChild parentpos filepath = do - parentfilestack <- fmap sourceName . statePos <$> getParserState - when (filepath `elem` parentfilestack) - $ parseErrorAt parentpos ("Cyclic include: " ++ filepath) + parentj <- get - childInput <- lift $ readFilePortably filepath - `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) + let parentfilestack = jincludefilestack parentj + when (filepath `elem` parentfilestack) $ + fail ("Cyclic include: " ++ filepath) - -- save parent state - parentParserState <- getParserState - parentj <- get + childInput <- lift $ readFilePortably filepath + `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) + let initChildj = newJournalWithParseStateFrom filepath parentj - let childj = newJournalWithParseStateFrom parentj + let parser = choiceInState + [ journalp + , timeclockfilep + , timedotfilep + ] -- can't include a csv file yet, that reader is special + updatedChildj <- journalAddFile (filepath, childInput) <$> + parseIncludeFile parser initChildj filepath childInput - -- set child state - setInput childInput - pushPosition $ initialPos filepath - put childj + -- discard child's parse info, combine other fields + put $ updatedChildj <> parentj - -- parse include file - let parsers = [ journalp - , timeclockfilep - , timedotfilep - ] -- can't include a csv file yet, that reader is special - updatedChildj <- journalAddFile (filepath, childInput) <$> - region (withSource childInput) (choiceInState parsers) - - -- restore parent state, prepending the child's parse info - setParserState parentParserState - put $ updatedChildj <> parentj - -- discard child's parse info, prepend its (reversed) list data, combine other fields - - -newJournalWithParseStateFrom :: Journal -> Journal -newJournalWithParseStateFrom j = mempty{ - jparsedefaultyear = jparsedefaultyear j - ,jparsedefaultcommodity = jparsedefaultcommodity j - ,jparseparentaccounts = jparseparentaccounts j - ,jparsealiases = jparsealiases j - ,jcommodities = jcommodities j - -- ,jparsetransactioncount = jparsetransactioncount j - ,jparsetimeclockentries = jparsetimeclockentries j - } + newJournalWithParseStateFrom :: FilePath -> Journal -> Journal + newJournalWithParseStateFrom filepath j = mempty{ + jparsedefaultyear = jparsedefaultyear j + ,jparsedefaultcommodity = jparsedefaultcommodity j + ,jparseparentaccounts = jparseparentaccounts j + ,jparsealiases = jparsealiases j + ,jcommodities = jcommodities j + -- ,jparsetransactioncount = jparsetransactioncount j + ,jparsetimeclockentries = jparsetimeclockentries j + ,jincludefilestack = filepath : jincludefilestack j + } -- | Lift an IO action into the exception monad, rethrowing any IO -- error with the given message prepended. @@ -284,17 +280,17 @@ commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultiline -- >>> Right _ <- rjp commoditydirectiveonelinep "commodity $1.00 ; blah\n" commoditydirectiveonelinep :: JournalParser m () commoditydirectiveonelinep = do - (pos, Amount{acommodity,astyle}) <- try $ do + (off, Amount{acommodity,astyle}) <- try $ do string "commodity" lift (skipSome spacenonewline) - pos <- getPosition + off <- getOffset amount <- amountp - pure $ (pos, amount) + pure $ (off, amount) lift (skipMany spacenonewline) _ <- lift followingcommentp let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle} if asdecimalpoint astyle == Nothing - then parseErrorAt pos pleaseincludedecimalpoint + then customFailure $ parseErrorAt off pleaseincludedecimalpoint else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j}) pleaseincludedecimalpoint :: String @@ -321,15 +317,15 @@ formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle formatdirectivep expectedsym = do string "format" lift (skipSome spacenonewline) - pos <- getPosition + off <- getOffset Amount{acommodity,astyle} <- amountp _ <- lift followingcommentp if acommodity==expectedsym then if asdecimalpoint astyle == Nothing - then parseErrorAt pos pleaseincludedecimalpoint + then customFailure $ parseErrorAt off pleaseincludedecimalpoint else return $ dbg2 "style from format subdirective" astyle - else parseErrorAt pos $ + else customFailure $ parseErrorAt off $ printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity keywordp :: String -> JournalParser m () @@ -371,7 +367,7 @@ basicaliasp = do old <- rstrip <$> (some $ noneOf ("=" :: [Char])) char '=' skipMany spacenonewline - new <- rstrip <$> anyChar `manyTill` eolof -- eol in journal, eof in command lines, normally + new <- rstrip <$> anySingle `manyTill` eolof -- eol in journal, eof in command lines, normally return $ BasicAlias (T.pack old) (T.pack new) regexaliasp :: TextParser m AccountAlias @@ -383,7 +379,7 @@ regexaliasp = do skipMany spacenonewline char '=' skipMany spacenonewline - repl <- anyChar `manyTill` eolof + repl <- anySingle `manyTill` eolof return $ RegexAlias re repl endaliasesdirectivep :: JournalParser m () @@ -418,11 +414,11 @@ defaultcommoditydirectivep :: JournalParser m () defaultcommoditydirectivep = do char 'D' "default commodity" lift (skipSome spacenonewline) - pos <- getPosition + off <- getOffset Amount{acommodity,astyle} <- amountp lift restofline if asdecimalpoint astyle == Nothing - then parseErrorAt pos pleaseincludedecimalpoint + then customFailure $ parseErrorAt off pleaseincludedecimalpoint else setDefaultCommodityAndStyle (acommodity, astyle) marketpricedirectivep :: JournalParser m MarketPrice @@ -484,17 +480,20 @@ periodictransactionp = do char '~' "periodic transaction" lift $ skipMany spacenonewline -- a period expression + off <- getOffset pos <- getPosition + -- if there's a default year in effect, use Y/1/1 as base for partial/relative dates today <- liftIO getCurrentDay mdefaultyear <- getYear let refdate = case mdefaultyear of Nothing -> today Just y -> fromGregorian y 1 1 (periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp refdate) + -- In periodic transactions, the period expression has an additional constraint: case checkPeriodicTransactionStartDate interval span periodtxt of - Just e -> parseErrorAt pos e + Just e -> customFailure $ parseErrorAt off e Nothing -> pure () -- The line can end here, or it can continue with one or more spaces -- and then zero or more of the following fields. A bit awkward. @@ -529,7 +528,7 @@ periodictransactionp = do transactionp :: JournalParser m Transaction transactionp = do -- dbgparse 0 "transactionp" - startpos <- getPosition + startpos <- getSourcePos date <- datep "transaction" edate <- optional (lift $ secondarydatep date) "secondary date" lookAhead (lift spacenonewline <|> newline) "whitespace or newline" @@ -539,7 +538,7 @@ transactionp = do (comment, tags) <- lift transactioncommentp let year = first3 $ toGregorian date postings <- postingsp (Just year) - endpos <- getPosition + endpos <- getSourcePos let sourcepos = journalSourcePos startpos endpos return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings "" @@ -607,8 +606,9 @@ tests_JournalReader = tests "JournalReader" [ test "YYYY.MM.DD" $ expectParse datep "2018.01.01" test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown" test "yearless date with default year" $ do - ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep "1/1" - either (fail.("parse error at "++).parseErrorPretty) (const ok) ep + let s = "1/1" + ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s + either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep test "no leading zero" $ expectParse datep "2018/1/1" ,test "datetimep" $ do @@ -795,8 +795,8 @@ tests_JournalReader = tests "JournalReader" [ ,tests "directivep" [ test "supports !" $ do - expectParse directivep "!account a\n" - expectParse directivep "!D 1.0\n" + expectParseE directivep "!account a\n" + expectParseE directivep "!D 1.0\n" ] ,test "accountdirectivep" $ do @@ -819,8 +819,8 @@ tests_JournalReader = tests "JournalReader" [ expectParse ignoredpricecommoditydirectivep "N $\n" ,test "includedirectivep" $ do - test "include" $ expectParseError includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile" - test "glob" $ expectParseError includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" + test "include" $ expectParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile" + test "glob" $ expectParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" ,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep "P 2017/01/30 BTC $922.83\n" @@ -839,7 +839,7 @@ tests_JournalReader = tests "JournalReader" [ ,tests "journalp" [ - test "empty file" $ expectParseEq journalp "" nulljournal + test "empty file" $ expectParseEqE journalp "" nulljournal ] ] diff --git a/hledger-lib/Hledger/Read/TimeclockReader.hs b/hledger-lib/Hledger/Read/TimeclockReader.hs index 22bc2901c..e997b59ec 100644 --- a/hledger-lib/Hledger/Read/TimeclockReader.hs +++ b/hledger-lib/Hledger/Read/TimeclockReader.hs @@ -58,7 +58,6 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Text.Megaparsec hiding (parse) -import Text.Megaparsec.Char import Hledger.Data -- XXX too much reuse ? @@ -78,7 +77,7 @@ reader = Reader -- format, saving the provided file path and the current time, or give an -- error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal -parse = parseAndFinaliseJournal timeclockfilep +parse = parseAndFinaliseJournal' timeclockfilep timeclockfilep :: MonadIO m => JournalParser m ParsedJournal timeclockfilep = do many timeclockitemp @@ -105,7 +104,7 @@ timeclockfilep = do many timeclockitemp -- | Parse a timeclock entry. timeclockentryp :: JournalParser m TimeclockEntry timeclockentryp = do - sourcepos <- genericSourcePos <$> lift getPosition + sourcepos <- genericSourcePos <$> lift getSourcePos code <- oneOf ("bhioO" :: [Char]) lift (skipSome spacenonewline) datetime <- datetimep diff --git a/hledger-lib/Hledger/Read/TimedotReader.hs b/hledger-lib/Hledger/Read/TimedotReader.hs index 77fb37b7a..2eafd0902 100644 --- a/hledger-lib/Hledger/Read/TimedotReader.hs +++ b/hledger-lib/Hledger/Read/TimedotReader.hs @@ -64,7 +64,7 @@ reader = Reader -- | Parse and post-process a "Journal" from the timedot format, or give an error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal -parse = parseAndFinaliseJournal timedotfilep +parse = parseAndFinaliseJournal' timedotfilep timedotfilep :: JournalParser m ParsedJournal timedotfilep = do many timedotfileitemp @@ -104,7 +104,7 @@ timedotdayp = do timedotentryp :: JournalParser m Transaction timedotentryp = do traceParse " timedotentryp" - pos <- genericSourcePos <$> getPosition + pos <- genericSourcePos <$> getSourcePos lift (skipMany spacenonewline) a <- modifiedaccountnamep lift (skipMany spacenonewline) diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 271060386..17687b838 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -48,7 +48,7 @@ import Data.Default import Safe import System.Console.ANSI (hSupportsANSI) import System.IO (stdout) -import Text.Megaparsec.Error +import Text.Megaparsec.Custom import Hledger.Data import Hledger.Query @@ -240,11 +240,11 @@ beginDatesFromRawOpts d = catMaybes . map (begindatefromrawopt d) where begindatefromrawopt d (n,v) | n == "begin" = - either (\e -> usageError $ "could not parse "++n++" date: "++parseErrorPretty e) Just $ + either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $ fixSmartDateStrEither' d (T.pack v) | n == "period" = case - either (\e -> usageError $ "could not parse period option: "++parseErrorPretty e) id $ + either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $ parsePeriodExpr d (stripquotes $ T.pack v) of (_, DateSpan (Just b) _) -> Just b @@ -258,11 +258,11 @@ endDatesFromRawOpts d = catMaybes . map (enddatefromrawopt d) where enddatefromrawopt d (n,v) | n == "end" = - either (\e -> usageError $ "could not parse "++n++" date: "++parseErrorPretty e) Just $ + either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $ fixSmartDateStrEither' d (T.pack v) | n == "period" = case - either (\e -> usageError $ "could not parse period option: "++parseErrorPretty e) id $ + either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $ parsePeriodExpr d (stripquotes $ T.pack v) of (_, DateSpan _ (Just e)) -> Just e @@ -276,7 +276,7 @@ intervalFromRawOpts = lastDef NoInterval . catMaybes . map intervalfromrawopt where intervalfromrawopt (n,v) | n == "period" = - either (\e -> usageError $ "could not parse period option: "++parseErrorPretty e) (Just . fst) $ + either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) (Just . fst) $ parsePeriodExpr nulldate (stripquotes $ T.pack v) -- reference date does not affect the interval | n == "daily" = Just $ Days 1 | n == "weekly" = Just $ Weeks 1 diff --git a/hledger-lib/Hledger/Utils/Debug.hs b/hledger-lib/Hledger/Utils/Debug.hs index 567a3db27..055282dfc 100644 --- a/hledger-lib/Hledger/Utils/Debug.hs +++ b/hledger-lib/Hledger/Utils/Debug.hs @@ -225,7 +225,7 @@ plogAt lvl -- (position and next input) to the console. (See also megaparsec's dbg.) traceParse :: String -> TextParser m () traceParse msg = do - pos <- getPosition + pos <- getSourcePos next <- (T.take peeklength) `fmap` getInput let (l,c) = (sourceLine pos, sourceColumn pos) s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String diff --git a/hledger-lib/Hledger/Utils/Parse.hs b/hledger-lib/Hledger/Utils/Parse.hs index 409ee40e3..3a7c0bbae 100644 --- a/hledger-lib/Hledger/Utils/Parse.hs +++ b/hledger-lib/Hledger/Utils/Parse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Hledger.Utils.Parse ( @@ -5,6 +6,7 @@ module Hledger.Utils.Parse ( SimpleTextParser, TextParser, JournalParser, + ErroringJournalParser, choice', choiceInState, @@ -27,6 +29,7 @@ module Hledger.Utils.Parse ( ) where +import Control.Monad.Except (ExceptT) import Control.Monad.State.Strict (StateT, evalStateT) import Data.Char import Data.Functor.Identity (Identity(..)) @@ -52,6 +55,11 @@ type TextParser m a = ParsecT CustomErr Text m a -- | A parser of text in some monad, with a journal as state. type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a +-- | A parser of text in some monad, with a journal as state, that can throw a +-- "final" parse error that does not backtrack. +type ErroringJournalParser m a = + StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a + -- | Backtracking choice, use this when alternatives share a prefix. -- Consumes no input if all choices fail. choice' :: [TextParser m a] -> TextParser m a @@ -65,15 +73,21 @@ choiceInState = choice . map try surroundedBy :: Applicative m => m openclose -> m a -> m a surroundedBy p = between p p -parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a +parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a parsewith p = runParser p "" -parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a +parsewithString + :: Parsec e String a -> String -> Either (ParseErrorBundle String e) a parsewithString p = runParser p "" -- | Run a stateful parser with some initial state on a text. -- See also: runTextParser, runJournalParser. -parseWithState :: Monad m => st -> StateT st (ParsecT CustomErr Text m) a -> Text -> m (Either (ParseError Char CustomErr) a) +parseWithState + :: Monad m + => st + -> StateT st (ParsecT CustomErr Text m) a + -> Text + -> m (Either (ParseErrorBundle Text CustomErr) a) parseWithState ctx p s = runParserT (evalStateT p ctx) "" s parseWithState' @@ -81,19 +95,23 @@ parseWithState' => st -> StateT st (ParsecT e s Identity) a -> s - -> (Either (ParseError (Token s) e) a) + -> (Either (ParseErrorBundle s e) a) parseWithState' ctx p s = runParser (evalStateT p ctx) "" s -fromparse :: (Show t, Show e) => Either (ParseError t e) a -> a +fromparse + :: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a fromparse = either parseerror id -parseerror :: (Show t, Show e) => ParseError t e -> a +parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a parseerror e = error' $ showParseError e -showParseError :: (Show t, Show e) => ParseError t e -> String +showParseError + :: (Show t, Show (Token t), Show e) + => ParseErrorBundle t e -> String showParseError e = "parse error at " ++ show e -showDateParseError :: (Show t, Show e) => ParseError t e -> String +showDateParseError + :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) nonspace :: TextParser m Char @@ -106,7 +124,7 @@ spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char spacenonewline = satisfy isNonNewlineSpace restofline :: TextParser m String -restofline = anyChar `manyTill` newline +restofline = anySingle `manyTill` newline eolof :: TextParser m () eolof = (newline >> return ()) <|> eof diff --git a/hledger-lib/Hledger/Utils/Test.hs b/hledger-lib/Hledger/Utils/Test.hs index 208d5e6ef..98f939b79 100644 --- a/hledger-lib/Hledger/Utils/Test.hs +++ b/hledger-lib/Hledger/Utils/Test.hs @@ -16,13 +16,18 @@ module Hledger.Utils.Test ( ,is ,expectEqPP ,expectParse + ,expectParseE ,expectParseError + ,expectParseErrorE ,expectParseEq + ,expectParseEqE ,expectParseEqOn + ,expectParseEqOnE ) where import Control.Exception +import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.State.Strict (StateT, evalStateT) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) @@ -101,12 +106,34 @@ is = flip expectEqPP -- | Test that this stateful parser runnable in IO successfully parses -- all of the given input text, showing the parse error if it fails. + -- Suitable for hledger's JournalParser parsers. expectParse :: (Monoid st, Eq a, Show a, HasCallStack) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test () expectParse parser input = do ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input) - either (fail.(++"\n").("\nparse error at "++).parseErrorPretty) (const ok) ep + either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty) + (const ok) + ep + +-- Suitable for hledger's ErroringJournalParser parsers. +expectParseE + :: (Monoid st, Eq a, Show a, HasCallStack) + => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a + -> T.Text + -> E.Test () +expectParseE parser input = do + let filepath = "" + eep <- E.io $ runExceptT $ + runParserT (evalStateT (parser <* eof) mempty) filepath input + case eep of + Left finalErr -> + let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr + in fail $ "parse error at " <> prettyErr + Right ep -> + either (fail.(++"\n").("\nparse error at "++).customErrorBundlePretty) + (const ok) + ep -- | Test that this stateful parser runnable in IO fails to parse -- the given input text, with a parse error containing the given string. @@ -117,22 +144,75 @@ expectParseError parser input errstr = do case ep of Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n" Left e -> do - let e' = parseErrorPretty e + let e' = customErrorBundlePretty e if errstr `isInfixOf` e' then ok else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n" +expectParseErrorE + :: (Monoid st, Eq a, Show a, HasCallStack) + => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a + -> T.Text + -> String + -> E.Test () +expectParseErrorE parser input errstr = do + let filepath = "" + eep <- E.io $ runExceptT $ runParserT (evalStateT parser mempty) filepath input + case eep of + Left finalErr -> do + let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr + if errstr `isInfixOf` prettyErr + then ok + else fail $ "\nparse error is not as expected:\n" ++ prettyErr ++ "\n" + Right ep -> case ep of + Right v -> fail $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n" + Left e -> do + let e' = customErrorBundlePretty e + if errstr `isInfixOf` e' + then ok + else fail $ "\nparse error is not as expected:\n" ++ e' ++ "\n" + -- | Like expectParse, but also test the parse result is an expected value, -- pretty-printing both if it fails. expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test () expectParseEq parser input expected = expectParseEqOn parser input id expected +expectParseEqE + :: (Monoid st, Eq a, Show a, HasCallStack) + => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a + -> T.Text + -> a + -> E.Test () +expectParseEqE parser input expected = expectParseEqOnE parser input id expected + -- | Like expectParseEq, but transform the parse result with the given function -- before comparing it. expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test () expectParseEqOn parser input f expected = do ep <- E.io $ runParserT (evalStateT (parser <* eof) mempty) "" input - either (fail . (++"\n") . ("\nparse error at "++) . parseErrorPretty) (expectEqPP expected . f) ep + either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty) + (expectEqPP expected . f) + ep + +expectParseEqOnE + :: (Monoid st, Eq b, Show b, HasCallStack) + => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a + -> T.Text + -> (a -> b) + -> b + -> E.Test () +expectParseEqOnE parser input f expected = do + let filepath = "" + eep <- E.io $ runExceptT $ + runParserT (evalStateT (parser <* eof) mempty) filepath input + case eep of + Left finalErr -> + let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr + in fail $ "parse error at " <> prettyErr + Right ep -> + either (fail . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty) + (expectEqPP expected . f) + ep diff --git a/hledger-lib/Text/Megaparsec/Custom.hs b/hledger-lib/Text/Megaparsec/Custom.hs index 5dce6f785..c71df3e7a 100644 --- a/hledger-lib/Text/Megaparsec/Custom.hs +++ b/hledger-lib/Text/Megaparsec/Custom.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PackageImports #-} @@ -9,25 +8,44 @@ module Text.Megaparsec.Custom ( -- * Custom parse error type CustomErr, - -- * Throwing custom parse errors + -- * Constructing custom parse errors parseErrorAt, parseErrorAtRegion, - withSource, -- * Pretty-printing custom parse errors - customParseErrorPretty + customErrorBundlePretty, + + + -- * "Final" parse errors + FinalParseError, + FinalParseError', + FinalParseErrorBundle, + FinalParseErrorBundle', + + -- * Constructing "final" parse errors + finalError, + finalFancyFailure, + finalFail, + finalCustomFailure, + + -- * Pretty-printing "final" parse errors + finalErrorBundlePretty, + attachSource, + + -- * Handling parse errors from include files with "final" parse errors + parseIncludeFile, ) where import Prelude () import "base-compat-batteries" Prelude.Compat hiding (readFile) +import Control.Monad.Except +import Control.Monad.State.Strict (StateT, evalStateT) import Data.Foldable (asum, toList) import qualified Data.List.NonEmpty as NE -import Data.Proxy (Proxy (Proxy)) import qualified Data.Set as S import Data.Text (Text) -import Data.Void (Void) import Text.Megaparsec @@ -39,13 +57,9 @@ import Text.Megaparsec data CustomErr -- | Fail with a message at a specific source position interval. The -- interval must be contained within a single line. - = ErrorFailAt SourcePos -- Starting position - Pos -- Ending position (column; same line as start) + = ErrorFailAt Int -- Starting offset + Int -- Ending offset String -- Error message - -- | Attach a source file to a parse error (for error reporting from - -- include files, e.g. with the 'region' parser combinator) - | ErrorWithSource Text -- Source file contents - (ParseError Char CustomErr) -- The original deriving (Show, Eq, Ord) -- We require an 'Ord' instance for 'CustomError' so that they may be @@ -53,76 +67,68 @@ data CustomErr -- derive it, but this requires an (orphan) instance for 'ParseError'. -- Hopefully this does not cause any trouble. -deriving instance (Ord c, Ord e) => Ord (ParseError c e) +deriving instance (Eq (Token c), Ord (Token c), Ord c, Ord e) => Ord (ParseError c e) instance ShowErrorComponent CustomErr where showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg - showErrorComponent (ErrorWithSource _ e) = parseErrorTextPretty e + errorComponentLen (ErrorFailAt startOffset endOffset _) = + endOffset - startOffset ---- * Throwing custom parse errors +--- * Constructing custom parse errors --- | Fail at a specific source position. +-- | Fail at a specific source position, given by the raw offset from the +-- start of the input stream (the number of tokens processed at that +-- point). -parseErrorAt :: MonadParsec CustomErr s m => SourcePos -> String -> m a -parseErrorAt pos msg = customFailure (ErrorFailAt pos (sourceColumn pos) msg) -{-# INLINABLE parseErrorAt #-} +parseErrorAt :: Int -> String -> CustomErr +parseErrorAt offset msg = ErrorFailAt offset (offset+1) msg --- | Fail at a specific source interval (within a single line). The --- interval is inclusive on the left and exclusive on the right; that is, --- it spans from the start position to just before (and not including) the --- end position. +-- | Fail at a specific source interval, given by the raw offsets of its +-- endpoints from the start of the input stream (the numbers of tokens +-- processed at those points). +-- +-- Note that care must be taken to ensure that the specified interval does +-- not span multiple lines of the input source, as this will not be +-- checked. parseErrorAtRegion - :: MonadParsec CustomErr s m - => SourcePos -- ^ Start position - -> SourcePos -- ^ End position - -> String -- ^ Error message - -> m a -parseErrorAtRegion startPos endPos msg = - let startCol = sourceColumn startPos - endCol' = mkPos $ subtract 1 $ unPos $ sourceColumn endPos - endCol = if startCol <= endCol' - && sourceLine startPos == sourceLine endPos - then endCol' else startCol - in customFailure (ErrorFailAt startPos endCol msg) -{-# INLINABLE parseErrorAtRegion #-} - --- | Attach a source file to a parse error. Intended for use with the --- 'region' parser combinator. - -withSource :: Text -> ParseError Char CustomErr -> ParseError Char CustomErr -withSource s e = - FancyError (errorPos e) $ S.singleton $ ErrorCustom $ ErrorWithSource s e + :: Int -- ^ Start offset + -> Int -- ^ End end offset + -> String -- ^ Error message + -> CustomErr +parseErrorAtRegion startOffset endOffset msg = + if startOffset < endOffset + then ErrorFailAt startOffset endOffset msg + else ErrorFailAt startOffset (startOffset+1) msg --- * Pretty-printing custom parse errors -- | Pretty-print our custom parse errors and display the line on which --- the parse error occured. Use this instead of 'parseErrorPretty'. +-- the parse error occured. -- --- If any custom errors are present, arbitrarily take the first one (since --- only one custom error should be used at a time). +-- Use this instead of 'errorBundlePretty' when custom parse errors are +-- thrown, otherwise the continuous highlighting in the pretty-printed +-- parse error will be displaced from its proper position. -customParseErrorPretty :: Text -> ParseError Char CustomErr -> String -customParseErrorPretty source err = case findCustomError err of - Nothing -> customParseErrorPretty' source err pos1 - - Just (ErrorWithSource customSource customErr) -> - customParseErrorPretty customSource customErr - - Just (ErrorFailAt sourcePos col errMsg) -> - let newPositionStack = sourcePos NE.:| NE.tail (errorPos err) - errorIntervalLength = mkPos $ max 1 $ - unPos col - unPos (sourceColumn sourcePos) + 1 - - newErr :: ParseError Char Void - newErr = FancyError newPositionStack (S.singleton (ErrorFail errMsg)) - - in customParseErrorPretty' source newErr errorIntervalLength +customErrorBundlePretty :: ParseErrorBundle Text CustomErr -> String +customErrorBundlePretty errBundle = + let errBundle' = errBundle + { bundleErrors = fmap setCustomErrorOffset $ bundleErrors errBundle } + in errorBundlePretty errBundle' where - findCustomError :: ParseError Char CustomErr -> Maybe CustomErr + setCustomErrorOffset + :: ParseError Text CustomErr -> ParseError Text CustomErr + setCustomErrorOffset err = case findCustomError err of + Nothing -> err + Just errFailAt@(ErrorFailAt startOffset _ _) -> + FancyError startOffset $ S.singleton $ ErrorCustom errFailAt + + -- If any custom errors are present, arbitrarily take the first one + -- (since only one custom error should be used at a time). + findCustomError :: ParseError Text CustomErr -> Maybe CustomErr findCustomError err = case err of FancyError _ errSet -> finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet @@ -132,117 +138,183 @@ customParseErrorPretty source err = case findCustomError err of finds f = asum . map f . toList ---- * Modified Megaparsec source +--- * "Final" parse errors +-- +-- | A type representing "final" parse errors that cannot be backtracked +-- from and are guaranteed to halt parsing. The anti-backtracking +-- behaviour is implemented by an 'ExceptT' layer in the parser's monad +-- stack, using this type as the 'ExceptT' error type. +-- +-- We have three goals for this type: +-- (1) it should be possible to convert any parse error into a "final" +-- parse error, +-- (2) it should be possible to take a parse error thrown from an include +-- file and re-throw it in the parent file, and +-- (3) the pretty-printing of "final" parse errors should be consistent +-- with that of ordinary parse errors, but should also report a stack of +-- files for errors thrown from include files. +-- +-- In order to pretty-print a "final" parse error (goal 3), it must be +-- bundled with include filepaths and its full source text. When a "final" +-- parse error is thrown from within a parser, we do not have access to +-- the full source, so we must hold the parse error until it can be joined +-- with its source (and include filepaths, if it was thrown from an +-- include file) by the parser's caller. +-- +-- A parse error with include filepaths and its full source text is +-- represented by the 'FinalParseErrorBundle' type, while a parse error in +-- need of either include filepaths, full source text, or both is +-- represented by the 'FinalParseError' type. --- The below code has been copied from Megaparsec (v.6.4.1, --- Text.Megaparsec.Error) and modified to suit our needs. These changes are --- indicated by square brackets. The following copyright notice, conditions, --- and disclaimer apply to all code below this point. +data FinalParseError' e + -- a parse error thrown as a "final" parse error + = FinalError (ParseError Text e) + -- a parse error obtained from running a parser, e.g. using 'runParserT' + | FinalBundle (ParseErrorBundle Text e) + -- a parse error thrown from an include file + | FinalBundleWithStack (FinalParseErrorBundle' e) + deriving (Show) + +type FinalParseError = FinalParseError' CustomErr + +-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT +-- FinalParseError m' is an instance of Alternative and MonadPlus, which +-- is needed to use some parser combinators, e.g. 'many'. -- --- Copyright © 2015–2018 Megaparsec contributors
--- Copyright © 2007 Paolo Martini
--- Copyright © 1999–2000 Daan Leijen +-- This monoid instance simply takes the first (left-most) error. + +instance Semigroup (FinalParseError' e) where + e <> _ = e + +instance Monoid (FinalParseError' e) where + mempty = FinalError $ FancyError 0 $ + S.singleton (ErrorFail "default parse error") + mappend = (<>) + +-- | A type bundling a 'ParseError' with its full source text, filepath, +-- and stack of include files. Suitable for pretty-printing. -- --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS --- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES --- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN --- NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, --- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, --- OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, --- EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with +-- its full source text and filepath, so we just add a stack of include +-- files. + +data FinalParseErrorBundle' e = FinalParseErrorBundle' + { finalErrorBundle :: ParseErrorBundle Text e + , includeFileStack :: [FilePath] + } deriving (Show) + +type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr --- | Pretty-print a 'ParseError Char CustomErr' and display the line on --- which the parse error occurred. The rendered 'String' always ends with --- a newline. +--- * Constructing and throwing final parse errors -customParseErrorPretty' - :: ( ShowToken (Token s) - , LineToken (Token s) - , ShowErrorComponent e - , Stream s ) - => s -- ^ Original input stream - -> ParseError (Token s) e -- ^ Parse error to render - -> Pos -- ^ Length of error interval [added] - -> String -- ^ Result of rendering -customParseErrorPretty' = customParseErrorPretty_ defaultTabWidth +-- | Convert a "regular" parse error into a "final" parse error. + +finalError :: ParseError Text e -> FinalParseError' e +finalError = FinalError + +-- | Like megaparsec's 'fancyFailure', but as a "final" parse error. + +finalFancyFailure + :: (MonadParsec e s m, MonadError (FinalParseError' e) m) + => S.Set (ErrorFancy e) -> m a +finalFancyFailure errSet = do + offset <- getOffset + throwError $ FinalError $ FancyError offset errSet + +-- | Like 'fail', but as a "final" parse error. + +finalFail + :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a +finalFail = finalFancyFailure . S.singleton . ErrorFail + +-- | Like megaparsec's 'customFailure', but as a "final" parse error. + +finalCustomFailure + :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a +finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom -customParseErrorPretty_ - :: forall s e. - ( ShowToken (Token s) - , LineToken (Token s) - , ShowErrorComponent e - , Stream s ) - => Pos -- ^ Tab width - -> s -- ^ Original input stream - -> ParseError (Token s) e -- ^ Parse error to render - -> Pos -- ^ Length of error interval [added] - -> String -- ^ Result of rendering -customParseErrorPretty_ w s e l = - sourcePosStackPretty (errorPos e) <> ":\n" <> - padding <> "|\n" <> - lineNumber <> " | " <> rline <> "\n" <> - padding <> "| " <> rpadding <> highlight <> "\n" <> -- [added `highlight`] - parseErrorTextPretty e +--- * Pretty-printing "final" parse errors + +-- | Pretty-print a "final" parse error: print the stack of include files, +-- then apply the pretty-printer for parse error bundles. Note that +-- 'attachSource' must be used on a "final" parse error before it can be +-- pretty-printed. + +finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String +finalErrorBundlePretty bundle = + concatMap showIncludeFilepath (includeFileStack bundle) + <> customErrorBundlePretty (finalErrorBundle bundle) where - epos = NE.head (errorPos e) -- [changed from NE.last to NE.head] - lineNumber = (show . unPos . sourceLine) epos - padding = replicate (length lineNumber + 1) ' ' - rpadding = replicate (unPos (sourceColumn epos) - 1) ' ' - highlight = replicate (unPos l) '^' -- [added] - rline = - case rline' of - [] -> "" - xs -> expandTab w xs - rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy s) $ - selectLine (sourceLine epos) s + showIncludeFilepath path = "in file included from " <> path <> ",\n" --- | Select a line from input stream given its number. +-- | Supply a filepath and source text to a "final" parse error so that it +-- can be pretty-printed. You must ensure that you provide the appropriate +-- source text and filepath. -selectLine - :: forall s. (LineToken (Token s), Stream s) - => Pos -- ^ Number of line to select - -> s -- ^ Input stream - -> Tokens s -- ^ Selected line -selectLine l = go pos1 +attachSource + :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e +attachSource filePath sourceText finalParseError = case finalParseError of + + -- A parse error thrown directly with the 'FinalError' constructor + -- requires both source and filepath. + FinalError parseError -> + let bundle = ParseErrorBundle + { bundleErrors = parseError NE.:| [] + , bundlePosState = initialPosState filePath sourceText } + in FinalParseErrorBundle' + { finalErrorBundle = bundle + , includeFileStack = [] } + + -- A 'ParseErrorBundle' already has the appropriate source and filepath + -- and so needs neither. + FinalBundle peBundle -> FinalParseErrorBundle' + { finalErrorBundle = peBundle + , includeFileStack = [] } + + -- A parse error from a 'FinalParseErrorBundle' was thrown from an + -- include file, so we add the filepath to the stack. + FinalBundleWithStack fpeBundle -> fpeBundle + { includeFileStack = filePath : includeFileStack fpeBundle } + + +--- * Handling parse errors from include files with "final" parse errors + +-- | Parse a file with the given parser and initial state, discarding the +-- final state and re-throwing any parse errors as "final" parse errors. + +parseIncludeFile + :: Monad m + => StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a + -> st + -> FilePath + -> Text + -> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a +parseIncludeFile parser initialState filepath text = + catchError parser' handler where - go !n !s = - if n == l - then fst (takeWhile_ notNewline s) - else go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s)) - notNewline = not . tokenIsNewline - stripNewline s = - case take1_ s of - Nothing -> s - Just (_, s') -> s' + parser' = do + eResult <- lift $ lift $ + runParserT (evalStateT parser initialState) filepath text + case eResult of + Left parseErrorBundle -> throwError $ FinalBundle parseErrorBundle + Right result -> pure result --- | Replace tab characters with given number of spaces. + -- Attach source and filepath of the include file to its parse errors + handler e = throwError $ FinalBundleWithStack $ attachSource filepath text e -expandTab - :: Pos - -> String - -> String -expandTab w' = go 0 - where - go 0 [] = [] - go 0 ('\t':xs) = go w xs - go 0 (x:xs) = x : go 0 xs - go !n xs = ' ' : go (n - 1) xs - w = unPos w' +--- * Helpers + +-- Like megaparsec's 'initialState', but instead for 'PosState'. Used when +-- constructing 'ParseErrorBundle's. The values for "tab width" and "line +-- prefix" are taken from 'initialState'. + +initialPosState :: FilePath -> Text -> PosState Text +initialPosState filePath sourceText = PosState + { pstateInput = sourceText + , pstateOffset = 0 + , pstateSourcePos = initialPos filePath + , pstateTabWidth = defaultTabWidth + , pstateLinePrefix = "" } diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index d90dcb306..26e4135d7 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 02f1a6c7e0679654979a211571c7d927ae759fb5831bfd8b180bab19a9bea977 +-- hash: 22a6817292c6f2d53f935ce939331bea06b956c94b4e391d198760704ec294b3 name: hledger-lib version: 1.11.99 @@ -122,7 +122,7 @@ library , extra , filepath , hashtables >=1.2.3.1 - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time @@ -222,7 +222,7 @@ test-suite doctests , extra , filepath , hashtables >=1.2.3.1 - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time @@ -322,7 +322,7 @@ test-suite easytests , filepath , hashtables >=1.2.3.1 , hledger-lib - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index fd9125d7c..65f61bf90 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -57,7 +57,7 @@ dependencies: - easytest - filepath - hashtables >=1.2.3.1 -- megaparsec >=6.4.1 && < 7 +- megaparsec >=7.0.0 && <8 - mtl - mtl-compat - old-time diff --git a/hledger-ui/Hledger/UI/ErrorScreen.hs b/hledger-ui/Hledger/UI/ErrorScreen.hs index ec04ca0de..5ca55eb3f 100644 --- a/hledger-ui/Hledger/UI/ErrorScreen.hs +++ b/hledger-ui/Hledger/UI/ErrorScreen.hs @@ -112,8 +112,8 @@ esHandle _ _ = error "event handler called with wrong screen type, should not ha -- Temporary, we should keep the original parse error location. XXX hledgerparseerrorpositionp :: ParsecT Void String t (String, Int, Int) hledgerparseerrorpositionp = do - anyChar `manyTill` char '"' - f <- anyChar `manyTill` (oneOf ['"','\n']) + anySingle `manyTill` char '"' + f <- anySingle `manyTill` (oneOf ['"','\n']) string " (line " l <- read <$> some digitChar string ", column " diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index a03323ec4..e5d4ae20f 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4d019af731dfbe758d41b4a95151b8ba358a733fe52ae6333854b7430aec13ff +-- hash: fb0ef2467dcf115f1fc7a6f9d7781ec6912e7545a52921968067666c1747fff4 name: hledger-ui version: 1.11.99 @@ -77,7 +77,7 @@ executable hledger-ui , fsnotify >=0.2.1.2 && <0.4 , hledger >=1.11.99 && <1.12 , hledger-lib >=1.11.99 && <1.12 - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , microlens >=0.4 , microlens-platform >=0.2.3.1 , pretty-show >=1.6.4 diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index 30cf4af53..f0c6f2438 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -54,7 +54,7 @@ dependencies: - fsnotify >=0.2.1.2 && <0.4 - microlens >=0.4 - microlens-platform >=0.2.3.1 -- megaparsec >=6.4.1 && < 7 +- megaparsec >=7.0.0 && <8 - pretty-show >=1.6.4 - process >=1.2 - safe >=0.2 diff --git a/hledger-web/Hledger/Web/Widget/AddForm.hs b/hledger-web/Hledger/Web/Widget/AddForm.hs index c66d2767e..47e85f070 100644 --- a/hledger-web/Hledger/Web/Widget/AddForm.hs +++ b/hledger-web/Hledger/Web/Widget/AddForm.hs @@ -21,7 +21,7 @@ import qualified Data.Text as T import Data.Time (Day) import Text.Blaze.Internal (Markup, preEscapedString) import Text.JSON -import Text.Megaparsec (eof, parseErrorPretty, runParser) +import Text.Megaparsec (eof, errorBundlePretty, runParser) import Yesod import Hledger @@ -131,7 +131,7 @@ validatePostings a b = catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs - errorToFormMsg = first (("Invalid value: " <>) . T.pack . parseErrorPretty) + errorToFormMsg = first (("Invalid value: " <>) . T.pack . errorBundlePretty) validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 7d7b53128..b02326fb4 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 3a93b8df7229c5b65b88f7003205c93bcc295013203a85e0ed937303c18d8c84 +-- hash: 443e668fdd64fb57d1d9488224df0bc6ee4e796bcc75f81655a92850ff809d34 name: hledger-web version: 1.11.99 @@ -127,8 +127,6 @@ flag threaded default: True library - hs-source-dirs: - ./. exposed-modules: Hledger.Web Hledger.Web.Application @@ -148,6 +146,8 @@ library Hledger.Web.Widget.Common other-modules: Paths_hledger_web + hs-source-dirs: + ./. ghc-options: -Wall -fwarn-tabs cpp-options: -DVERSION="1.11.99" build-depends: @@ -169,7 +169,7 @@ library , http-client , http-conduit , json - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , semigroups , shakespeare >=2.0.2.2 diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index 80a12f783..4adcca759 100644 --- a/hledger-web/package.yaml +++ b/hledger-web/package.yaml @@ -114,7 +114,7 @@ library: - http-conduit - http-client - json - - megaparsec >=6.4.1 && < 7 + - megaparsec >=7.0.0 && <8 - mtl - semigroups - shakespeare >=2.0.2.2 diff --git a/hledger/Hledger/Cli/Commands/Add.hs b/hledger/Hledger/Cli/Commands/Add.hs index 40c3875ce..bb75737dc 100644 --- a/hledger/Hledger/Cli/Commands/Add.hs +++ b/hledger/Hledger/Cli/Commands/Add.hs @@ -296,7 +296,7 @@ amountAndCommentWizard EntryState{..} = do amountandcommentp = do a <- amountp lift (skipMany spacenonewline) - c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar) + c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle) -- eof return (a,c) balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings diff --git a/hledger/Hledger/Cli/Commands/Rewrite.hs b/hledger/Hledger/Cli/Commands/Rewrite.hs index 5234bc462..893436b2a 100755 --- a/hledger/Hledger/Cli/Commands/Rewrite.hs +++ b/hledger/Hledger/Cli/Commands/Rewrite.hs @@ -193,7 +193,7 @@ transactionModifierFromOpts CliOpts{rawopts_=rawopts,reportopts_=ropts} = where q = T.pack $ query_ ropts ps = map (parseposting . stripquotes . T.pack) $ listofstringopt "add-posting" rawopts - parseposting t = either (error' . parseErrorPretty' t') id ep + parseposting t = either (error' . errorBundlePretty) id ep where ep = runIdentity (runJournalParser (postingp Nothing <* eof) t') t' = " " <> t <> "\n" -- inject space and newline for proper parsing diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 62713e884..d32629977 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: fc4b42dee35f79a4fed845e87b2e5c08b3c68466fe1cf59d952e6be4f15df413 +-- hash: 78515e93d6f08be6d098bdd697b951a1577e4e71c6b24ad64cf69916d3af191c name: hledger version: 1.11.99 @@ -131,7 +131,7 @@ library , here , hledger-lib >=1.11.99 && <1.12 , lucid - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time @@ -182,7 +182,7 @@ executable hledger , here , hledger , hledger-lib >=1.11.99 && <1.12 - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time @@ -236,7 +236,7 @@ test-suite test , here , hledger , hledger-lib >=1.11.99 && <1.12 - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time @@ -291,7 +291,7 @@ benchmark bench , hledger , hledger-lib >=1.11.99 && <1.12 , html - , megaparsec >=6.4.1 && <7 + , megaparsec >=7.0.0 && <8 , mtl , mtl-compat , old-time diff --git a/hledger/package.yaml b/hledger/package.yaml index 6b93960bd..692f15132 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -93,7 +93,7 @@ dependencies: - filepath - haskeline >=0.6 - here -- megaparsec >=6.4.1 && < 7 +- megaparsec >=7.0.0 && <8 - mtl - mtl-compat - old-time diff --git a/stack-ghc7.10.yaml b/stack-ghc7.10.yaml index 5f2e9c07e..2b6e51fc8 100644 --- a/stack-ghc7.10.yaml +++ b/stack-ghc7.10.yaml @@ -26,8 +26,8 @@ extra-deps: - base-orphans-0.7 - bifunctors-5.5.2 - brick-0.37.1 -- cassava-megaparsec-1.0.0 -- config-ini-0.2.2.0 +- cassava-megaparsec-2.0.0 +- config-ini-0.2.3.0 - criterion-1.4.1.0 - data-clist-0.1.2.1 - directory-1.2.7.0 @@ -43,13 +43,13 @@ extra-deps: - integer-logarithms-1.0.2.1 - kan-extensions-5.1 - lens-4.16.1 -- megaparsec-6.4.1 +- megaparsec-7.0.1 - microstache-1.0.1.1 - mmorph-1.1.2 - monad-control-1.0.2.3 - network-2.6.3.5 - optparse-applicative-0.14.2.0 -- parser-combinators-0.4.0 +- parser-combinators-1.0.0 - persistent-2.7.0 - persistent-template-2.5.4 - profunctors-5.2.2 diff --git a/stack-ghc8.0.yaml b/stack-ghc8.0.yaml index df616e2e4..d566e2b24 100644 --- a/stack-ghc8.0.yaml +++ b/stack-ghc8.0.yaml @@ -20,7 +20,8 @@ extra-deps: - base-compat-0.10.1 - base-compat-batteries-0.10.1 - bifunctors-5.5.2 -- cassava-megaparsec-1.0.0 +- cassava-megaparsec-2.0.0 +- config-ini-0.2.3.0 - criterion-1.4.1.0 - doctest-0.16.0 - generics-sop-0.3.2.0 @@ -29,11 +30,11 @@ extra-deps: - http-types-0.12.1 - insert-ordered-containers-0.2.1.0 - lens-4.16.1 -- megaparsec-6.4.1 +- megaparsec-7.0.1 - microstache-1.0.1.1 - mmorph-1.1.2 - network-2.6.3.5 -- parser-combinators-0.4.0 +- parser-combinators-1.0.0 - persistent-template-2.5.4 - scientific-0.3.6.2 - servant-0.13.0.1 diff --git a/stack-ghc8.2.yaml b/stack-ghc8.2.yaml index a72106c7d..a579ae2e6 100644 --- a/stack-ghc8.2.yaml +++ b/stack-ghc8.2.yaml @@ -15,9 +15,12 @@ extra-deps: - aeson-1.3.1.1 - base-compat-0.10.1 - base-compat-batteries-0.10.1 -- cassava-megaparsec-1.0.0 +- cassava-megaparsec-2.0.0 +- config-ini-0.2.3.0 - criterion-1.4.1.0 - doctest-0.16.0 +- megaparsec-7.0.1 +- parser-combinators-1.0.0 - swagger2-2.2.2 # avoid no hashable instance for AccountName from doctests - hashtables-1.2.3.1 diff --git a/stack.yaml b/stack.yaml index b5814d9c9..cec70e4b6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,7 +10,9 @@ packages: - hledger-api extra-deps: -- cassava-megaparsec-1.0.0 +- cassava-megaparsec-2.0.0 +- megaparsec-7.0.1 +- config-ini-0.2.3.0 nix: pure: false diff --git a/tests/journal/parse-errors.test b/tests/journal/parse-errors.test index 32093fff8..b24347f78 100644 --- a/tests/journal/parse-errors.test +++ b/tests/journal/parse-errors.test @@ -12,7 +12,7 @@ hledger: -:1:5: 1 | 2018 | ^ unexpected newline -expecting date separator or the rest of year or month +expecting date separator or digit >=1