cln!: Clean up journal parsing.

parseAndFinaliseJournal' has been removed. In the unlikely event you
needed it in your code, you can replace it with:
parseAndFinaliseJournal' parser iopts fp t =>
initialiseAndParseJournal parser iopts fp t
>>= liftEither . journalApplyAliases (aliasesFromOpts iopts)
>>= journalFinalise iopts fp t

Some parsers have been generalised from JournalParser to TextParser.

hledger-lib/Hledger/Read/Common.hs

@@ -35,7 +35,7 @@ module Hledger.Read.Common (
 
   -- * parsing utilities
   parseAndFinaliseJournal,
-  parseAndFinaliseJournal',
+  initialiseAndParseJournal,
   journalFinalise,
   journalCheckAccountsDeclared,
   journalCheckCommoditiesDeclared,
@@ -121,7 +121,7 @@ where
 --- ** imports
 import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)
 import qualified Control.Monad.Fail as Fail (fail)
-import Control.Monad.Except (ExceptT(..), liftEither, runExceptT, throwError)
+import Control.Monad.Except (ExceptT(..), liftEither, withExceptT)
 import Control.Monad.State.Strict hiding (fail)
 import Data.Bifunctor (bimap, second)
 import Data.Char (digitToInt, isDigit, isSpace)
@@ -144,7 +144,7 @@ import Text.Megaparsec
 import Text.Megaparsec.Char (char, char', digitChar, newline, string)
 import Text.Megaparsec.Char.Lexer (decimal)
 import Text.Megaparsec.Custom
-  (attachSource, customErrorBundlePretty, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)
+  (FinalParseError, attachSource, customErrorBundlePretty, finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)
 
 import Hledger.Data
 import Hledger.Query (Query(..), filterQuery, parseQueryTerm, queryEndDate, queryStartDate, queryIsDate, simplifyQuery)
@@ -249,42 +249,32 @@ commodityStyleFromRawOpts rawOpts =
     parseCommodity optStr = case amountp'' optStr of
         Left _ -> Left optStr
         Right (Amount acommodity _ astyle _) -> Right (acommodity, astyle)
+
 -- | Given a parser to ParsedJournal, input options, file path and
 -- content: run the parser on the content, and finalise the result to
 -- get a Journal; or throw an error.
 parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
                            -> FilePath -> Text -> ExceptT String IO Journal
-parseAndFinaliseJournal parser iopts f txt = do
+parseAndFinaliseJournal parser iopts f txt =
-  let y = first3 . toGregorian $ _ioDay iopts
+    initialiseAndParseJournal parser iopts f txt >>= journalFinalise iopts f txt
-      initJournal = nulljournal{ jparsedefaultyear = Just y, jincludefilestack = [f] }
-  eep <- liftIO $ runExceptT $ runParserT (evalStateT parser initJournal) f txt
-  -- TODO: urgh.. clean this up somehow
-  case eep of
-    Left finalParseError -> throwError $ finalErrorBundlePretty $ attachSource f txt finalParseError
-    Right ep -> case ep of
-                  Left e   -> throwError $ customErrorBundlePretty e
-                  Right pj -> journalFinalise iopts f txt pj
 
--- | Like parseAndFinaliseJournal but takes a (non-Erroring) JournalParser.
+-- | Given a parser to ParsedJournal, input options, file path and
--- Also, applies command-line account aliases before finalising.
+-- content: run the parser on the content. This is all steps of
--- Used for timeclock/timedot.
+-- 'parseAndFinaliseJournal' without the finalisation step, and is used when
--- TODO: get rid of this, use parseAndFinaliseJournal instead
+-- you need to perform other actions before finalisation, as in parsing
-parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts
+-- Timeclock and Timedot files.
-                           -> FilePath -> Text -> ExceptT String IO Journal
+initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
-parseAndFinaliseJournal' parser iopts f txt = do
+                          -> FilePath -> Text -> ExceptT String IO Journal
-  let y = first3 . toGregorian $ _ioDay iopts
+initialiseAndParseJournal parser iopts f txt =
-      initJournal = nulljournal
+    prettyParseErrors $ runParserT (evalStateT parser initJournal) f txt
-        { jparsedefaultyear = Just y
+  where
-        , jincludefilestack = [f] }
+    y = first3 . toGregorian $ _ioDay iopts
-  ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt
+    initJournal = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]}
-  -- see notes above
+    -- Flatten parse errors and final parse errors, and output each as a pretty String.
-  case ep of
+    prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text CustomErr) a)
-    Left e   -> throwError $ customErrorBundlePretty e
+                      -> ExceptT String IO a
-    Right pj ->
+    prettyParseErrors = withExceptT customErrorBundlePretty . liftEither
-      -- apply any command line account aliases. Can fail with a bad replacement pattern.
+                    <=< withExceptT (finalErrorBundlePretty . attachSource f txt)
-      case journalApplyAliases (aliasesFromOpts iopts) pj of
-        Left e    -> throwError e
-        Right pj' -> journalFinalise iopts f txt pj'
 
 {- HLINT ignore journalFinalise "Redundant <&>" -} -- silence this warning, the code is clearer as is
 -- NB activates TH, may slow compilation ? https://github.com/ndmitchell/hlint/blob/master/README.md#customizing-the-hints

hledger-lib/Hledger/Read/TimeclockReader.hs

@@ -58,7 +58,7 @@ where
 
 --- ** imports
 import           Control.Monad
-import           Control.Monad.Except (ExceptT)
+import           Control.Monad.Except (ExceptT, liftEither)
 import           Control.Monad.State.Strict
 import           Data.Maybe (fromMaybe)
 import           Data.Text (Text)
@@ -88,7 +88,9 @@ 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 iopts fp t = initialiseAndParseJournal timeclockfilep iopts fp t
+                   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)
+                   >>= journalFinalise iopts fp t
 
 --- ** parsers
 
@@ -124,5 +126,3 @@ timeclockentryp = do
   account <- fromMaybe "" <$> optional (lift skipNonNewlineSpaces1 >> modifiedaccountnamep)
   description <- T.pack . fromMaybe "" <$> lift (optional (skipNonNewlineSpaces1 >> restofline))
   return $ TimeclockEntry sourcepos (read [code]) datetime account description
-
-

hledger-lib/Hledger/Read/TimedotReader.hs

@@ -41,7 +41,7 @@ where
 
 --- ** imports
 import Control.Monad
-import Control.Monad.Except (ExceptT)
+import Control.Monad.Except (ExceptT, liftEither)
 import Control.Monad.State.Strict
 import Data.Char (isSpace)
 import Data.List (foldl')
@@ -71,7 +71,9 @@ 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' timedotp
+parse iopts fp t = initialiseAndParseJournal timedotp iopts fp t
+                   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts)
+                   >>= journalFinalise iopts fp t
 
 --- ** utilities
 
@@ -173,7 +175,7 @@ entryp = do
   lift skipNonNewlineSpaces
   hrs <-
     try (lift followingcommentp >> return 0)
-    <|> (durationp <*
+    <|> (lift durationp <*
          (try (lift followingcommentp) <|> (newline >> return "")))
   mcs <- getDefaultCommodityAndStyle
   let 
@@ -194,9 +196,9 @@ entryp = do
   lift $ traceparse' "entryp"
   return t
 
-durationp :: JournalParser m Quantity
+durationp :: TextParser m Quantity
 durationp = do
-  lift $ traceparse "durationp"
+  traceparse "durationp"
   try numericquantityp <|> dotquantityp
     -- <* traceparse' "durationp"
 
@@ -209,12 +211,12 @@ durationp = do
 -- 1.5h
 -- 90m
 -- @
-numericquantityp :: JournalParser m Quantity
+numericquantityp :: TextParser m Quantity
 numericquantityp = do
   -- lift $ traceparse "numericquantityp"
-  (q, _, _, _) <- lift $ numberp Nothing
+  (q, _, _, _) <- numberp Nothing
   msymbol <- optional $ choice $ map (string . fst) timeUnits
-  lift skipNonNewlineSpaces
+  skipNonNewlineSpaces
   let q' =
         case msymbol of
           Nothing  -> q
@@ -239,7 +241,7 @@ timeUnits =
 -- @
 -- .... ..
 -- @
-dotquantityp :: JournalParser m Quantity
+dotquantityp :: TextParser m Quantity
 dotquantityp = do
   -- lift $ traceparse "dotquantityp"
   dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))