ref: rename CustomErr -> HledgerParseErrorData
Verbose, but use every chance to clarify the complicated parse error situation.
This commit is contained in:
parent
07502bd41c
commit
2f28e1b0a7
@ -360,7 +360,7 @@ latestSpanContaining datespans = go
|
|||||||
-- | Parse a period expression to an Interval and overall DateSpan using
|
-- | Parse a period expression to an Interval and overall DateSpan using
|
||||||
-- the provided reference date, or return a parse error.
|
-- the provided reference date, or return a parse error.
|
||||||
parsePeriodExpr
|
parsePeriodExpr
|
||||||
:: Day -> Text -> Either (ParseErrorBundle Text CustomErr) (Interval, DateSpan)
|
:: Day -> Text -> Either (ParseErrorBundle Text HledgerParseErrorData) (Interval, DateSpan)
|
||||||
parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)
|
parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)
|
||||||
|
|
||||||
-- | Like parsePeriodExpr, but call error' on failure.
|
-- | Like parsePeriodExpr, but call error' on failure.
|
||||||
@ -408,14 +408,14 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
|
|||||||
fixSmartDateStr :: Day -> Text -> Text
|
fixSmartDateStr :: Day -> Text -> Text
|
||||||
fixSmartDateStr d s =
|
fixSmartDateStr d s =
|
||||||
either (error' . printf "could not parse date %s %s" (show s) . show) id $ -- PARTIAL:
|
either (error' . printf "could not parse date %s %s" (show s) . show) id $ -- PARTIAL:
|
||||||
(fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) Text)
|
(fixSmartDateStrEither d s :: Either (ParseErrorBundle Text HledgerParseErrorData) Text)
|
||||||
|
|
||||||
-- | A safe version of fixSmartDateStr.
|
-- | A safe version of fixSmartDateStr.
|
||||||
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Text
|
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text HledgerParseErrorData) Text
|
||||||
fixSmartDateStrEither d = fmap showDate . fixSmartDateStrEither' d
|
fixSmartDateStrEither d = fmap showDate . fixSmartDateStrEither' d
|
||||||
|
|
||||||
fixSmartDateStrEither'
|
fixSmartDateStrEither'
|
||||||
:: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day
|
:: Day -> Text -> Either (ParseErrorBundle Text HledgerParseErrorData) Day
|
||||||
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
|
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
|
||||||
Right sd -> Right $ fixSmartDate d sd
|
Right sd -> Right $ fixSmartDate d sd
|
||||||
Left e -> Left e
|
Left e -> Left e
|
||||||
|
|||||||
@ -142,13 +142,13 @@ import Hledger.Query
|
|||||||
|
|
||||||
|
|
||||||
-- | A parser of text that runs in some monad, keeping a Journal as state.
|
-- | A parser of text that runs in some monad, keeping a Journal as state.
|
||||||
type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a
|
type JournalParser m a = StateT Journal (ParsecT HledgerParseErrorData Text m) a
|
||||||
|
|
||||||
-- | A parser of text that runs in some monad, keeping a Journal as
|
-- | A parser of text that runs in some monad, keeping a Journal as
|
||||||
-- state, that can throw an exception to end parsing, preventing
|
-- state, that can throw an exception to end parsing, preventing
|
||||||
-- further parser backtracking.
|
-- further parser backtracking.
|
||||||
type ErroringJournalParser m a =
|
type ErroringJournalParser m a =
|
||||||
StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
|
StateT Journal (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a
|
||||||
|
|
||||||
-- deriving instance Show Journal
|
-- deriving instance Show Journal
|
||||||
instance Show Journal where
|
instance Show Journal where
|
||||||
|
|||||||
@ -271,7 +271,7 @@ initialiseAndParseJournal parser iopts f txt =
|
|||||||
y = first3 . toGregorian $ _ioDay iopts
|
y = first3 . toGregorian $ _ioDay iopts
|
||||||
initJournal = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]}
|
initJournal = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]}
|
||||||
-- Flatten parse errors and final parse errors, and output each as a pretty String.
|
-- Flatten parse errors and final parse errors, and output each as a pretty String.
|
||||||
prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text CustomErr) a)
|
prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text HledgerParseErrorData) a)
|
||||||
-> ExceptT String IO a
|
-> ExceptT String IO a
|
||||||
prettyParseErrors = withExceptT customErrorBundlePretty . liftEither
|
prettyParseErrors = withExceptT customErrorBundlePretty . liftEither
|
||||||
<=< withExceptT (finalErrorBundlePretty . attachSource f txt)
|
<=< withExceptT (finalErrorBundlePretty . attachSource f txt)
|
||||||
@ -855,7 +855,7 @@ amountwithoutpricep mult = do
|
|||||||
Right (q,p,d,g) -> pure (q, Precision p, d, g)
|
Right (q,p,d,g) -> pure (q, Precision p, d, g)
|
||||||
|
|
||||||
-- | Try to parse an amount from a string
|
-- | Try to parse an amount from a string
|
||||||
amountp'' :: String -> Either (ParseErrorBundle Text CustomErr) Amount
|
amountp'' :: String -> Either (ParseErrorBundle Text HledgerParseErrorData) Amount
|
||||||
amountp'' s = runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s)
|
amountp'' s = runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s)
|
||||||
|
|
||||||
-- | Parse an amount from a string, or get an error.
|
-- | Parse an amount from a string, or get an error.
|
||||||
|
|||||||
@ -216,7 +216,7 @@ parseAndValidateCsvRules rulesfile s =
|
|||||||
parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String)
|
parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String)
|
||||||
|
|
||||||
-- | Parse this text as CSV conversion rules. The file path is for error messages.
|
-- | Parse this text as CSV conversion rules. The file path is for error messages.
|
||||||
parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text CustomErr) CsvRules
|
parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text HledgerParseErrorData) CsvRules
|
||||||
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
|
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
|
||||||
parseCsvRules = runParser (evalStateT rulesp defrules)
|
parseCsvRules = runParser (evalStateT rulesp defrules)
|
||||||
|
|
||||||
@ -1232,7 +1232,7 @@ renderTemplate rules record t = maybe t mconcat $ parseMaybe
|
|||||||
<|> replaceCsvFieldReference rules record <$> referencep)
|
<|> replaceCsvFieldReference rules record <$> referencep)
|
||||||
t
|
t
|
||||||
where
|
where
|
||||||
referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) :: Parsec CustomErr Text Text
|
referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) :: Parsec HledgerParseErrorData Text Text
|
||||||
isFieldNameChar c = isAlphaNum c || c == '_' || c == '-'
|
isFieldNameChar c = isAlphaNum c || c == '_' || c == '-'
|
||||||
|
|
||||||
-- | Replace something that looks like a reference to a csv field ("%date" or "%1)
|
-- | Replace something that looks like a reference to a csv field ("%date" or "%1)
|
||||||
|
|||||||
@ -113,7 +113,7 @@ import qualified Hledger.Read.CsvReader as CsvReader (reader)
|
|||||||
-- | Run a journal parser in some monad. See also: parseWithState.
|
-- | Run a journal parser in some monad. See also: parseWithState.
|
||||||
runJournalParser, rjp
|
runJournalParser, rjp
|
||||||
:: Monad m
|
:: Monad m
|
||||||
=> JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
|
=> JournalParser m a -> Text -> m (Either (ParseErrorBundle Text HledgerParseErrorData) a)
|
||||||
runJournalParser p = runParserT (evalStateT p nulljournal) ""
|
runJournalParser p = runParserT (evalStateT p nulljournal) ""
|
||||||
rjp = runJournalParser
|
rjp = runJournalParser
|
||||||
|
|
||||||
@ -122,7 +122,7 @@ runErroringJournalParser, rejp
|
|||||||
:: Monad m
|
:: Monad m
|
||||||
=> ErroringJournalParser m a
|
=> ErroringJournalParser m a
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
|
-> m (Either FinalParseError (Either (ParseErrorBundle Text HledgerParseErrorData) a))
|
||||||
runErroringJournalParser p t =
|
runErroringJournalParser p t =
|
||||||
runExceptT $ runParserT (evalStateT p nulljournal) "" t
|
runExceptT $ runParserT (evalStateT p nulljournal) "" t
|
||||||
rejp = runErroringJournalParser
|
rejp = runErroringJournalParser
|
||||||
|
|||||||
@ -38,7 +38,7 @@ module Hledger.Utils.Parse (
|
|||||||
skipNonNewlineSpaces',
|
skipNonNewlineSpaces',
|
||||||
|
|
||||||
-- * re-exports
|
-- * re-exports
|
||||||
CustomErr
|
HledgerParseErrorData
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -54,13 +54,13 @@ import Text.Megaparsec.Custom
|
|||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
-- | A parser of string to some type.
|
-- | A parser of string to some type.
|
||||||
type SimpleStringParser a = Parsec CustomErr String a
|
type SimpleStringParser a = Parsec HledgerParseErrorData String a
|
||||||
|
|
||||||
-- | A parser of strict text to some type.
|
-- | A parser of strict text to some type.
|
||||||
type SimpleTextParser = Parsec CustomErr Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
|
type SimpleTextParser = Parsec HledgerParseErrorData Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
|
||||||
|
|
||||||
-- | A parser of text that runs in some monad.
|
-- | A parser of text that runs in some monad.
|
||||||
type TextParser m a = ParsecT CustomErr Text m a
|
type TextParser m a = ParsecT HledgerParseErrorData Text m a
|
||||||
|
|
||||||
-- | Render a pair of source positions in human-readable form, only displaying the range of lines.
|
-- | Render a pair of source positions in human-readable form, only displaying the range of lines.
|
||||||
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
|
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
|
||||||
@ -76,7 +76,7 @@ choice' = choice . map try
|
|||||||
|
|
||||||
-- | Backtracking choice, use this when alternatives share a prefix.
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
||||||
-- Consumes no input if all choices fail.
|
-- Consumes no input if all choices fail.
|
||||||
choiceInState :: [StateT s (ParsecT CustomErr Text m) a] -> StateT s (ParsecT CustomErr Text m) a
|
choiceInState :: [StateT s (ParsecT HledgerParseErrorData Text m) a] -> StateT s (ParsecT HledgerParseErrorData Text m) a
|
||||||
choiceInState = choice . map try
|
choiceInState = choice . map try
|
||||||
|
|
||||||
surroundedBy :: Applicative m => m openclose -> m a -> m a
|
surroundedBy :: Applicative m => m openclose -> m a -> m a
|
||||||
@ -87,7 +87,7 @@ parsewith p = runParser p ""
|
|||||||
|
|
||||||
-- | Run a text parser in the identity monad. See also: parseWithState.
|
-- | Run a text parser in the identity monad. See also: parseWithState.
|
||||||
runTextParser, rtp
|
runTextParser, rtp
|
||||||
:: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a
|
:: TextParser Identity a -> Text -> Either (ParseErrorBundle Text HledgerParseErrorData) a
|
||||||
runTextParser = parsewith
|
runTextParser = parsewith
|
||||||
rtp = runTextParser
|
rtp = runTextParser
|
||||||
|
|
||||||
@ -100,9 +100,9 @@ parsewithString p = runParser p ""
|
|||||||
parseWithState
|
parseWithState
|
||||||
:: Monad m
|
:: Monad m
|
||||||
=> st
|
=> st
|
||||||
-> StateT st (ParsecT CustomErr Text m) a
|
-> StateT st (ParsecT HledgerParseErrorData Text m) a
|
||||||
-> Text
|
-> Text
|
||||||
-> m (Either (ParseErrorBundle Text CustomErr) a)
|
-> m (Either (ParseErrorBundle Text HledgerParseErrorData) a)
|
||||||
parseWithState ctx p = runParserT (evalStateT p ctx) ""
|
parseWithState ctx p = runParserT (evalStateT p ctx) ""
|
||||||
|
|
||||||
parseWithState'
|
parseWithState'
|
||||||
@ -139,7 +139,7 @@ nonspace = satisfy (not . isSpace)
|
|||||||
isNonNewlineSpace :: Char -> Bool
|
isNonNewlineSpace :: Char -> Bool
|
||||||
isNonNewlineSpace c = not (isNewline c) && isSpace c
|
isNonNewlineSpace c = not (isNewline c) && isSpace c
|
||||||
|
|
||||||
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
|
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT HledgerParseErrorData s m Char
|
||||||
spacenonewline = satisfy isNonNewlineSpace
|
spacenonewline = satisfy isNonNewlineSpace
|
||||||
{-# INLINABLE spacenonewline #-}
|
{-# INLINABLE spacenonewline #-}
|
||||||
|
|
||||||
@ -147,17 +147,17 @@ restofline :: TextParser m String
|
|||||||
restofline = anySingle `manyTill` eolof
|
restofline = anySingle `manyTill` eolof
|
||||||
|
|
||||||
-- Skip many non-newline spaces.
|
-- Skip many non-newline spaces.
|
||||||
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m ()
|
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
||||||
skipNonNewlineSpaces = () <$ takeWhileP Nothing isNonNewlineSpace
|
skipNonNewlineSpaces = () <$ takeWhileP Nothing isNonNewlineSpace
|
||||||
{-# INLINABLE skipNonNewlineSpaces #-}
|
{-# INLINABLE skipNonNewlineSpaces #-}
|
||||||
|
|
||||||
-- Skip many non-newline spaces, failing if there are none.
|
-- Skip many non-newline spaces, failing if there are none.
|
||||||
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m ()
|
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
||||||
skipNonNewlineSpaces1 = () <$ takeWhile1P Nothing isNonNewlineSpace
|
skipNonNewlineSpaces1 = () <$ takeWhile1P Nothing isNonNewlineSpace
|
||||||
{-# INLINABLE skipNonNewlineSpaces1 #-}
|
{-# INLINABLE skipNonNewlineSpaces1 #-}
|
||||||
|
|
||||||
-- Skip many non-newline spaces, returning True if any have been skipped.
|
-- Skip many non-newline spaces, returning True if any have been skipped.
|
||||||
skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m Bool
|
skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m Bool
|
||||||
skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False
|
skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False
|
||||||
{-# INLINABLE skipNonNewlineSpaces' #-}
|
{-# INLINABLE skipNonNewlineSpaces' #-}
|
||||||
|
|
||||||
|
|||||||
@ -31,7 +31,7 @@ import Test.Tasty.HUnit
|
|||||||
-- import Test.Tasty.SmallCheck as SC
|
-- import Test.Tasty.SmallCheck as SC
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
import Text.Megaparsec.Custom
|
import Text.Megaparsec.Custom
|
||||||
( CustomErr,
|
( HledgerParseErrorData,
|
||||||
FinalParseError,
|
FinalParseError,
|
||||||
attachSource,
|
attachSource,
|
||||||
customErrorBundlePretty,
|
customErrorBundlePretty,
|
||||||
@ -56,7 +56,7 @@ assertRight (Left a) = assertFailure $ "expected Right, got (Left " ++ show a +
|
|||||||
|
|
||||||
-- | Run a parser on the given text and display a helpful error.
|
-- | Run a parser on the given text and display a helpful error.
|
||||||
parseHelper :: (HasCallStack, Default st, Monad m) =>
|
parseHelper :: (HasCallStack, Default st, Monad m) =>
|
||||||
StateT st (ParsecT CustomErr T.Text m) a -> T.Text -> ExceptT String m a
|
StateT st (ParsecT HledgerParseErrorData T.Text m) a -> T.Text -> ExceptT String m a
|
||||||
parseHelper parser input =
|
parseHelper parser input =
|
||||||
withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . ExceptT
|
withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . ExceptT
|
||||||
$ runParserT (evalStateT (parser <* eof) def) "" input
|
$ runParserT (evalStateT (parser <* eof) def) "" input
|
||||||
@ -65,7 +65,7 @@ parseHelper parser input =
|
|||||||
-- produce an 'Assertion'. Suitable for hledger's JournalParser parsers.
|
-- produce an 'Assertion'. Suitable for hledger's JournalParser parsers.
|
||||||
assertParseHelper :: (HasCallStack, Default st) =>
|
assertParseHelper :: (HasCallStack, Default st) =>
|
||||||
(String -> Assertion) -> (a -> Assertion)
|
(String -> Assertion) -> (a -> Assertion)
|
||||||
-> StateT st (ParsecT CustomErr T.Text IO) a -> T.Text
|
-> StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text
|
||||||
-> Assertion
|
-> Assertion
|
||||||
assertParseHelper onFailure onSuccess parser input =
|
assertParseHelper onFailure onSuccess parser input =
|
||||||
either onFailure onSuccess =<< runExceptT (parseHelper parser input)
|
either onFailure onSuccess =<< runExceptT (parseHelper parser input)
|
||||||
@ -74,25 +74,25 @@ assertParseHelper onFailure onSuccess parser input =
|
|||||||
-- all of the given input text, showing the parse error if it fails.
|
-- all of the given input text, showing the parse error if it fails.
|
||||||
-- Suitable for hledger's JournalParser parsers.
|
-- Suitable for hledger's JournalParser parsers.
|
||||||
assertParse :: (HasCallStack, Default st) =>
|
assertParse :: (HasCallStack, Default st) =>
|
||||||
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> Assertion
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> Assertion
|
||||||
assertParse = assertParseHelper assertFailure (const $ return ())
|
assertParse = assertParseHelper assertFailure (const $ return ())
|
||||||
|
|
||||||
-- | Assert a parser produces an expected value.
|
-- | Assert a parser produces an expected value.
|
||||||
assertParseEq :: (HasCallStack, Eq a, Show a, Default st) =>
|
assertParseEq :: (HasCallStack, Eq a, Show a, Default st) =>
|
||||||
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> Assertion
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> a -> Assertion
|
||||||
assertParseEq parser input = assertParseEqOn parser input id
|
assertParseEq parser input = assertParseEqOn parser input id
|
||||||
|
|
||||||
-- | Like assertParseEq, but transform the parse result with the given function
|
-- | Like assertParseEq, but transform the parse result with the given function
|
||||||
-- before comparing it.
|
-- before comparing it.
|
||||||
assertParseEqOn :: (HasCallStack, Eq b, Show b, Default st) =>
|
assertParseEqOn :: (HasCallStack, Eq b, Show b, Default st) =>
|
||||||
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> Assertion
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> (a -> b) -> b -> Assertion
|
||||||
assertParseEqOn parser input f expected =
|
assertParseEqOn parser input f expected =
|
||||||
assertParseHelper assertFailure (assertEqual "" expected . f) parser input
|
assertParseHelper assertFailure (assertEqual "" expected . f) parser input
|
||||||
|
|
||||||
-- | Assert that this stateful parser runnable in IO fails to parse
|
-- | Assert that this stateful parser runnable in IO fails to parse
|
||||||
-- the given input text, with a parse error containing the given string.
|
-- the given input text, with a parse error containing the given string.
|
||||||
assertParseError :: (HasCallStack, Eq a, Show a, Default st) =>
|
assertParseError :: (HasCallStack, Eq a, Show a, Default st) =>
|
||||||
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> String -> Assertion
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> String -> Assertion
|
||||||
assertParseError parser input errstr = assertParseHelper
|
assertParseError parser input errstr = assertParseHelper
|
||||||
(\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)
|
(\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)
|
||||||
(\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")
|
(\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")
|
||||||
@ -102,7 +102,7 @@ assertParseError parser input errstr = assertParseHelper
|
|||||||
-- final state (the wrapped state, not megaparsec's internal state),
|
-- final state (the wrapped state, not megaparsec's internal state),
|
||||||
-- transformed by the given function, matches the given expected value.
|
-- transformed by the given function, matches the given expected value.
|
||||||
assertParseStateOn :: (HasCallStack, Eq b, Show b, Default st) =>
|
assertParseStateOn :: (HasCallStack, Eq b, Show b, Default st) =>
|
||||||
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (st -> b) -> b -> Assertion
|
StateT st (ParsecT HledgerParseErrorData T.Text IO) a -> T.Text -> (st -> b) -> b -> Assertion
|
||||||
assertParseStateOn parser input f expected = do
|
assertParseStateOn parser input f expected = do
|
||||||
es <- runParserT (execStateT (parser <* eof) def) "" input
|
es <- runParserT (execStateT (parser <* eof) def) "" input
|
||||||
case es of
|
case es of
|
||||||
@ -111,7 +111,7 @@ assertParseStateOn parser input f expected = do
|
|||||||
|
|
||||||
-- | These "E" variants of the above are suitable for hledger's ErroringJournalParser parsers.
|
-- | These "E" variants of the above are suitable for hledger's ErroringJournalParser parsers.
|
||||||
parseHelperE :: (HasCallStack, Default st, Monad m) =>
|
parseHelperE :: (HasCallStack, Default st, Monad m) =>
|
||||||
StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError m)) a -> T.Text -> ExceptT String m a
|
StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError m)) a -> T.Text -> ExceptT String m a
|
||||||
parseHelperE parser input = do
|
parseHelperE parser input = do
|
||||||
withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . liftEither
|
withExceptT (\e -> "\nparse error at " ++ customErrorBundlePretty e ++ "\n") . liftEither
|
||||||
=<< withExceptT (\e -> "parse error at " ++ finalErrorBundlePretty (attachSource "" input e))
|
=<< withExceptT (\e -> "parse error at " ++ finalErrorBundlePretty (attachSource "" input e))
|
||||||
@ -119,30 +119,30 @@ parseHelperE parser input = do
|
|||||||
|
|
||||||
assertParseHelperE :: (HasCallStack, Default st) =>
|
assertParseHelperE :: (HasCallStack, Default st) =>
|
||||||
(String -> Assertion) -> (a -> Assertion)
|
(String -> Assertion) -> (a -> Assertion)
|
||||||
-> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text
|
-> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text
|
||||||
-> Assertion
|
-> Assertion
|
||||||
assertParseHelperE onFailure onSuccess parser input =
|
assertParseHelperE onFailure onSuccess parser input =
|
||||||
either onFailure onSuccess =<< runExceptT (parseHelperE parser input)
|
either onFailure onSuccess =<< runExceptT (parseHelperE parser input)
|
||||||
|
|
||||||
assertParseE
|
assertParseE
|
||||||
:: (HasCallStack, Eq a, Show a, Default st)
|
:: (HasCallStack, Eq a, Show a, Default st)
|
||||||
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> Assertion
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> Assertion
|
||||||
assertParseE = assertParseHelperE assertFailure (const $ return ())
|
assertParseE = assertParseHelperE assertFailure (const $ return ())
|
||||||
|
|
||||||
assertParseEqE
|
assertParseEqE
|
||||||
:: (Default st, Eq a, Show a, HasCallStack)
|
:: (Default st, Eq a, Show a, HasCallStack)
|
||||||
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> a -> Assertion
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> a -> Assertion
|
||||||
assertParseEqE parser input = assertParseEqOnE parser input id
|
assertParseEqE parser input = assertParseEqOnE parser input id
|
||||||
|
|
||||||
assertParseEqOnE
|
assertParseEqOnE
|
||||||
:: (HasCallStack, Eq b, Show b, Default st)
|
:: (HasCallStack, Eq b, Show b, Default st)
|
||||||
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> (a -> b) -> b -> Assertion
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> (a -> b) -> b -> Assertion
|
||||||
assertParseEqOnE parser input f expected =
|
assertParseEqOnE parser input f expected =
|
||||||
assertParseHelperE assertFailure (assertEqual "" expected . f) parser input
|
assertParseHelperE assertFailure (assertEqual "" expected . f) parser input
|
||||||
|
|
||||||
assertParseErrorE
|
assertParseErrorE
|
||||||
:: (Default st, Eq a, Show a, HasCallStack)
|
:: (Default st, Eq a, Show a, HasCallStack)
|
||||||
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> String -> Assertion
|
=> StateT st (ParsecT HledgerParseErrorData T.Text (ExceptT FinalParseError IO)) a -> T.Text -> String -> Assertion
|
||||||
assertParseErrorE parser input errstr = assertParseHelperE
|
assertParseErrorE parser input errstr = assertParseHelperE
|
||||||
(\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)
|
(\e -> unless (errstr `isInfixOf` e) $ assertFailure $ "\nparse error is not as expected:" ++ e)
|
||||||
(\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")
|
(\v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n")
|
||||||
|
|||||||
@ -8,7 +8,7 @@
|
|||||||
|
|
||||||
module Text.Megaparsec.Custom (
|
module Text.Megaparsec.Custom (
|
||||||
-- * Custom parse error type
|
-- * Custom parse error type
|
||||||
CustomErr,
|
HledgerParseErrorData,
|
||||||
|
|
||||||
-- * Failing with an arbitrary source position
|
-- * Failing with an arbitrary source position
|
||||||
parseErrorAt,
|
parseErrorAt,
|
||||||
@ -60,7 +60,7 @@ import Text.Megaparsec
|
|||||||
-- | A custom error type for the parser. The type is specialized to
|
-- | A custom error type for the parser. The type is specialized to
|
||||||
-- parsers of 'Text' streams.
|
-- parsers of 'Text' streams.
|
||||||
|
|
||||||
data CustomErr
|
data HledgerParseErrorData
|
||||||
-- | Fail with a message at a specific source position interval. The
|
-- | Fail with a message at a specific source position interval. The
|
||||||
-- interval must be contained within a single line.
|
-- interval must be contained within a single line.
|
||||||
= ErrorFailAt Int -- Starting offset
|
= ErrorFailAt Int -- Starting offset
|
||||||
@ -69,7 +69,7 @@ data CustomErr
|
|||||||
-- | Re-throw parse errors obtained from the "re-parsing" of an excerpt
|
-- | Re-throw parse errors obtained from the "re-parsing" of an excerpt
|
||||||
-- of the source text.
|
-- of the source text.
|
||||||
| ErrorReparsing
|
| ErrorReparsing
|
||||||
(NE.NonEmpty (ParseError Text CustomErr)) -- Source fragment parse errors
|
(NE.NonEmpty (ParseError Text HledgerParseErrorData)) -- Source fragment parse errors
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- We require an 'Ord' instance for 'CustomError' so that they may be
|
-- We require an 'Ord' instance for 'CustomError' so that they may be
|
||||||
@ -77,13 +77,13 @@ data CustomErr
|
|||||||
-- derive it, but the derived instance requires an (orphan) instance for
|
-- derive it, but the derived instance requires an (orphan) instance for
|
||||||
-- 'ParseError'. Hopefully this does not cause any trouble.
|
-- 'ParseError'. Hopefully this does not cause any trouble.
|
||||||
|
|
||||||
deriving instance Ord (ParseError Text CustomErr)
|
deriving instance Ord (ParseError Text HledgerParseErrorData)
|
||||||
|
|
||||||
-- Note: the pretty-printing of our 'CustomErr' type is only partally
|
-- Note: the pretty-printing of our 'HledgerParseErrorData' type is only partally
|
||||||
-- defined in its 'ShowErrorComponent' instance; we perform additional
|
-- defined in its 'ShowErrorComponent' instance; we perform additional
|
||||||
-- adjustments in 'customErrorBundlePretty'.
|
-- adjustments in 'customErrorBundlePretty'.
|
||||||
|
|
||||||
instance ShowErrorComponent CustomErr where
|
instance ShowErrorComponent HledgerParseErrorData where
|
||||||
showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg
|
showErrorComponent (ErrorFailAt _ _ errMsg) = errMsg
|
||||||
showErrorComponent (ErrorReparsing _) = "" -- dummy value
|
showErrorComponent (ErrorReparsing _) = "" -- dummy value
|
||||||
|
|
||||||
@ -98,7 +98,7 @@ instance ShowErrorComponent CustomErr where
|
|||||||
-- start of the input stream (the number of tokens processed at that
|
-- start of the input stream (the number of tokens processed at that
|
||||||
-- point).
|
-- point).
|
||||||
|
|
||||||
parseErrorAt :: Int -> String -> CustomErr
|
parseErrorAt :: Int -> String -> HledgerParseErrorData
|
||||||
parseErrorAt offset = ErrorFailAt offset (offset+1)
|
parseErrorAt offset = ErrorFailAt offset (offset+1)
|
||||||
|
|
||||||
-- | Fail at a specific source interval, given by the raw offsets of its
|
-- | Fail at a specific source interval, given by the raw offsets of its
|
||||||
@ -112,7 +112,7 @@ parseErrorAtRegion
|
|||||||
:: Int -- ^ Start offset
|
:: Int -- ^ Start offset
|
||||||
-> Int -- ^ End end offset
|
-> Int -- ^ End end offset
|
||||||
-> String -- ^ Error message
|
-> String -- ^ Error message
|
||||||
-> CustomErr
|
-> HledgerParseErrorData
|
||||||
parseErrorAtRegion startOffset endOffset msg =
|
parseErrorAtRegion startOffset endOffset msg =
|
||||||
if startOffset < endOffset
|
if startOffset < endOffset
|
||||||
then ErrorFailAt startOffset endOffset msg
|
then ErrorFailAt startOffset endOffset msg
|
||||||
@ -142,7 +142,7 @@ getExcerptText (SourceExcerpt _ txt) = txt
|
|||||||
-- This function could be extended to return the result of 'p', but we don't
|
-- This function could be extended to return the result of 'p', but we don't
|
||||||
-- currently need this.
|
-- currently need this.
|
||||||
|
|
||||||
excerpt_ :: MonadParsec CustomErr Text m => m a -> m SourceExcerpt
|
excerpt_ :: MonadParsec HledgerParseErrorData Text m => m a -> m SourceExcerpt
|
||||||
excerpt_ p = do
|
excerpt_ p = do
|
||||||
offset <- getOffset
|
offset <- getOffset
|
||||||
(!txt, _) <- match p
|
(!txt, _) <- match p
|
||||||
@ -164,8 +164,8 @@ excerpt_ p = do
|
|||||||
reparseExcerpt
|
reparseExcerpt
|
||||||
:: Monad m
|
:: Monad m
|
||||||
=> SourceExcerpt
|
=> SourceExcerpt
|
||||||
-> ParsecT CustomErr Text m a
|
-> ParsecT HledgerParseErrorData Text m a
|
||||||
-> ParsecT CustomErr Text m a
|
-> ParsecT HledgerParseErrorData Text m a
|
||||||
reparseExcerpt (SourceExcerpt offset txt) p = do
|
reparseExcerpt (SourceExcerpt offset txt) p = do
|
||||||
(_, res) <- lift $ runParserT' p (offsetInitialState offset txt)
|
(_, res) <- lift $ runParserT' p (offsetInitialState offset txt)
|
||||||
case res of
|
case res of
|
||||||
@ -210,7 +210,7 @@ reparseExcerpt (SourceExcerpt offset txt) p = do
|
|||||||
-- 0 (that is, the beginning of the source file), which is the
|
-- 0 (that is, the beginning of the source file), which is the
|
||||||
-- case for 'ParseErrorBundle's returned from 'runParserT'.
|
-- case for 'ParseErrorBundle's returned from 'runParserT'.
|
||||||
|
|
||||||
customErrorBundlePretty :: ParseErrorBundle Text CustomErr -> String
|
customErrorBundlePretty :: ParseErrorBundle Text HledgerParseErrorData -> String
|
||||||
customErrorBundlePretty errBundle =
|
customErrorBundlePretty errBundle =
|
||||||
let errBundle' = errBundle { bundleErrors =
|
let errBundle' = errBundle { bundleErrors =
|
||||||
NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets
|
NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets
|
||||||
@ -219,7 +219,7 @@ customErrorBundlePretty errBundle =
|
|||||||
|
|
||||||
where
|
where
|
||||||
finalizeCustomError
|
finalizeCustomError
|
||||||
:: ParseError Text CustomErr -> NE.NonEmpty (ParseError Text CustomErr)
|
:: ParseError Text HledgerParseErrorData -> NE.NonEmpty (ParseError Text HledgerParseErrorData)
|
||||||
finalizeCustomError err = case findCustomError err of
|
finalizeCustomError err = case findCustomError err of
|
||||||
Nothing -> pure err
|
Nothing -> pure err
|
||||||
|
|
||||||
@ -233,7 +233,7 @@ customErrorBundlePretty errBundle =
|
|||||||
|
|
||||||
-- If any custom errors are present, arbitrarily take the first one
|
-- If any custom errors are present, arbitrarily take the first one
|
||||||
-- (since only one custom error should be used at a time).
|
-- (since only one custom error should be used at a time).
|
||||||
findCustomError :: ParseError Text CustomErr -> Maybe CustomErr
|
findCustomError :: ParseError Text HledgerParseErrorData -> Maybe HledgerParseErrorData
|
||||||
findCustomError err = case err of
|
findCustomError err = case err of
|
||||||
FancyError _ errSet ->
|
FancyError _ errSet ->
|
||||||
finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
|
finds (\case {ErrorCustom e -> Just e; _ -> Nothing}) errSet
|
||||||
@ -280,7 +280,7 @@ data FinalParseError' e
|
|||||||
| FinalBundleWithStack (FinalParseErrorBundle' e)
|
| FinalBundleWithStack (FinalParseErrorBundle' e)
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
type FinalParseError = FinalParseError' CustomErr
|
type FinalParseError = FinalParseError' HledgerParseErrorData
|
||||||
|
|
||||||
-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT
|
-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT
|
||||||
-- FinalParseError m' is an instance of Alternative and MonadPlus, which
|
-- FinalParseError m' is an instance of Alternative and MonadPlus, which
|
||||||
@ -308,7 +308,7 @@ data FinalParseErrorBundle' e = FinalParseErrorBundle'
|
|||||||
, includeFileStack :: [FilePath]
|
, includeFileStack :: [FilePath]
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
type FinalParseErrorBundle = FinalParseErrorBundle' CustomErr
|
type FinalParseErrorBundle = FinalParseErrorBundle' HledgerParseErrorData
|
||||||
|
|
||||||
|
|
||||||
--- * Constructing and throwing final parse errors
|
--- * Constructing and throwing final parse errors
|
||||||
@ -347,7 +347,7 @@ finalCustomFailure = finalFancyFailure . S.singleton . ErrorCustom
|
|||||||
-- 'attachSource' must be used on a "final" parse error before it can be
|
-- 'attachSource' must be used on a "final" parse error before it can be
|
||||||
-- pretty-printed.
|
-- pretty-printed.
|
||||||
|
|
||||||
finalErrorBundlePretty :: FinalParseErrorBundle' CustomErr -> String
|
finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String
|
||||||
finalErrorBundlePretty bundle =
|
finalErrorBundlePretty bundle =
|
||||||
concatMap showIncludeFilepath (includeFileStack bundle)
|
concatMap showIncludeFilepath (includeFileStack bundle)
|
||||||
<> customErrorBundlePretty (finalErrorBundle bundle)
|
<> customErrorBundlePretty (finalErrorBundle bundle)
|
||||||
@ -391,11 +391,11 @@ attachSource filePath sourceText finalParseError = case finalParseError of
|
|||||||
|
|
||||||
parseIncludeFile
|
parseIncludeFile
|
||||||
:: Monad m
|
:: Monad m
|
||||||
=> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
|
=> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a
|
||||||
-> st
|
-> st
|
||||||
-> FilePath
|
-> FilePath
|
||||||
-> Text
|
-> Text
|
||||||
-> StateT st (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
|
-> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a
|
||||||
parseIncludeFile parser initialState filepath text =
|
parseIncludeFile parser initialState filepath text =
|
||||||
catchError parser' handler
|
catchError parser' handler
|
||||||
where
|
where
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user