diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index f288c19f7..e3639dbb2 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/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 - let y = first3 . toGregorian $ _ioDay iopts - 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 +parseAndFinaliseJournal parser iopts f txt = + initialiseAndParseJournal parser iopts f txt >>= journalFinalise iopts f txt --- | Like parseAndFinaliseJournal but takes a (non-Erroring) JournalParser. --- Also, applies command-line account aliases before finalising. --- Used for timeclock/timedot. --- TODO: get rid of this, use parseAndFinaliseJournal instead -parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts - -> FilePath -> Text -> ExceptT String IO Journal -parseAndFinaliseJournal' parser iopts f txt = do - let y = first3 . toGregorian $ _ioDay iopts - initJournal = nulljournal - { jparsedefaultyear = Just y - , jincludefilestack = [f] } - ep <- liftIO $ runParserT (evalStateT parser initJournal) f txt - -- see notes above - case ep of - Left e -> throwError $ customErrorBundlePretty e - Right pj -> - -- apply any command line account aliases. Can fail with a bad replacement pattern. - case journalApplyAliases (aliasesFromOpts iopts) pj of - Left e -> throwError e - Right pj' -> journalFinalise iopts f txt pj' +-- | Given a parser to ParsedJournal, input options, file path and +-- content: run the parser on the content. This is all steps of +-- 'parseAndFinaliseJournal' without the finalisation step, and is used when +-- you need to perform other actions before finalisation, as in parsing +-- Timeclock and Timedot files. +initialiseAndParseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts + -> FilePath -> Text -> ExceptT String IO Journal +initialiseAndParseJournal parser iopts f txt = + prettyParseErrors $ runParserT (evalStateT parser initJournal) f txt + where + y = first3 . toGregorian $ _ioDay iopts + initJournal = nulljournal{jparsedefaultyear = Just y, jincludefilestack = [f]} + -- Flatten parse errors and final parse errors, and output each as a pretty String. + prettyParseErrors :: ExceptT FinalParseError IO (Either (ParseErrorBundle Text CustomErr) a) + -> ExceptT String IO a + prettyParseErrors = withExceptT customErrorBundlePretty . liftEither + <=< withExceptT (finalErrorBundlePretty . attachSource f txt) {- 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 diff --git a/hledger-lib/Hledger/Read/TimeclockReader.hs b/hledger-lib/Hledger/Read/TimeclockReader.hs index 18a46f643..14ca790bf 100644 --- a/hledger-lib/Hledger/Read/TimeclockReader.hs +++ b/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 - - diff --git a/hledger-lib/Hledger/Read/TimedotReader.hs b/hledger-lib/Hledger/Read/TimedotReader.hs index 3fff45b3f..aadf22775 100644 --- a/hledger-lib/Hledger/Read/TimedotReader.hs +++ b/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]))