diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index 91a2bf868..6daf0a92b 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -106,7 +106,7 @@ reader = Reader -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error. parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal -parse iopts = parseAndFinaliseJournal' journalp' iopts +parse iopts = parseAndFinaliseJournal journalp' iopts where journalp' = do -- reverse parsed aliases to ensure that they are applied in order given on commandline @@ -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,7 +174,7 @@ directivep = (do ] ) "directive" -includedirectivep :: MonadIO m => JournalParser m () +includedirectivep :: MonadIO m => ErroringJournalParser m () includedirectivep = do string "include" lift (skipSome spacenonewline) @@ -784,8 +784,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 @@ -808,8 +808,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" @@ -828,7 +828,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/Utils/Test.hs b/hledger-lib/Hledger/Utils/Test.hs index 208d5e6ef..c382cd311 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,6 +106,7 @@ 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 () @@ -108,6 +114,24 @@ expectParse parser input = do ep <- E.io (runParserT (evalStateT (parser <* eof) mempty) "" input) either (fail.(++"\n").("\nparse error at "++).parseErrorPretty) (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 = finalParseErrorPretty $ attachSource filepath input finalErr + in fail $ "parse error at " <> prettyErr + Right ep -> either (fail.(++"\n").("\nparse error at "++).parseErrorPretty) + (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. expectParseError :: (Monoid st, Eq a, Show a, HasCallStack) => @@ -122,12 +146,43 @@ expectParseError parser input errstr = do 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 = finalParseErrorPretty $ 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' = parseErrorPretty 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) => @@ -136,3 +191,23 @@ 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 +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 = finalParseErrorPretty $ attachSource filepath input finalErr + in fail $ "parse error at " <> prettyErr + Right ep -> + either (fail . (++"\n") . ("\nparse error at "++) . parseErrorPretty) + (expectEqPP expected . f) + ep +