lib: make 'includedirectivep' an 'ErroringJournalParser'

- Update tests as well, requiring test utilities in Utils/Test.hs
  analogous to the those for 'JournalParser' but instead for
  'ErroringJournalParser'

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"
+-- >>> rejp (journalp <* eof) "2015/1/1\n a  0\n"
--- Right Journal  with 1 transactions, 1 accounts
+-- 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"
+      expectParseE directivep "!account a\n"
-      expectParse directivep "!D 1.0\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 "include" $ expectParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"
-    test "glob" $ expectParseError 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
     ]
 
   ]

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
+