slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

more general parser types enabling reuse outside of IO (#439)

Browse Source
This commit is contained in:
Johannes Gerer 2016-12-10 00:57:17 +01:00 committed by Simon Michael
parent 31e4f538c0
commit 74502f7e50
6 changed files with 68 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
hledger-lib/Hledger/Read/Common.hs
View File

@ -57,7 +57,7 @@ runJournalParser p t = runParserT p "" t
rjp = runJournalParser rjp = runJournalParser
-- | Run an error-raising journal parser with a null journal-parsing state. -- | Run an error-raising journal parser with a null journal-parsing state.
runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a) runErroringJournalParser, rejp :: Monad m => ErroringJournalParser m a -> Text -> m (Either String a)
runErroringJournalParser p t = runErroringJournalParser p t =
runExceptT $ runExceptT $
runJournalParser (evalStateT p mempty) runJournalParser (evalStateT p mempty)
@ -70,7 +70,8 @@ genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sou
-- | Given a megaparsec ParsedJournal parser, balance assertion flag, file -- | Given a megaparsec ParsedJournal parser, balance assertion flag, file
-- path and file content: parse and post-process a Journal, or give an error. -- path and file content: parse and post-process a Journal, or give an error.
parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> Bool
-> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal parser assrt f txt = do parseAndFinaliseJournal parser assrt f txt = do
t <- liftIO getClockTime t <- liftIO getClockTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
@ -98,26 +99,26 @@ setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
getYear :: JournalStateParser m (Maybe Year) getYear :: JournalStateParser m (Maybe Year)
getYear = fmap jparsedefaultyear get getYear = fmap jparsedefaultyear get
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> ErroringJournalParser () setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalStateParser m ()
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs}) setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
getDefaultCommodityAndStyle :: JournalStateParser m (Maybe (CommoditySymbol,AmountStyle)) getDefaultCommodityAndStyle :: JournalStateParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
pushAccount :: AccountName -> ErroringJournalParser () pushAccount :: AccountName -> JournalStateParser m ()
pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j}) pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j})
pushParentAccount :: AccountName -> ErroringJournalParser () pushParentAccount :: AccountName -> JournalStateParser m ()
pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j}) pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
popParentAccount :: ErroringJournalParser () popParentAccount :: JournalStateParser m ()
popParentAccount = do popParentAccount = do
j <- get j <- get
case jparseparentaccounts j of case jparseparentaccounts j of
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning")) [] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
(_:rest) -> put j{jparseparentaccounts=rest} (_:rest) -> put j{jparseparentaccounts=rest}
getParentAccount :: ErroringJournalParser AccountName getParentAccount :: JournalStateParser m AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
addAccountAlias :: MonadState Journal m => AccountAlias -> m () addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
@ -155,7 +156,7 @@ journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}
-- | Terminate parsing entirely, returning the given error message -- | Terminate parsing entirely, returning the given error message
-- with the given parse position prepended. -- with the given parse position prepended.
parserErrorAt :: SourcePos -> String -> ErroringJournalParser a parserErrorAt :: Monad m => SourcePos -> String -> ErroringJournalParser m a
parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s
--- * parsers --- * parsers
@ -173,7 +174,7 @@ statusp =
codep :: TextParser m String codep :: TextParser m String
codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return "" codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
descriptionp :: ErroringJournalParser String descriptionp :: JournalStateParser m String
descriptionp = many (noneOf (";\n" :: [Char])) descriptionp = many (noneOf (";\n" :: [Char]))
--- ** dates --- ** dates
@ -212,7 +213,7 @@ datep = do
-- Seconds are optional. -- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time). -- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone). -- Leading zeroes may be omitted (except in a timezone).
datetimep :: ErroringJournalParser LocalTime datetimep :: JournalStateParser m LocalTime
datetimep = do datetimep = do
day <- datep day <- datep
lift $ some spacenonewline lift $ some spacenonewline
@ -240,7 +241,7 @@ datetimep = do
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Day -> ErroringJournalParser Day secondarydatep :: Day -> JournalStateParser m Day
secondarydatep primarydate = do secondarydatep primarydate = do
char '=' char '='
-- kludgy way to use primary date for default year -- kludgy way to use primary date for default year
@ -266,7 +267,7 @@ secondarydatep primarydate = do
--- ** account names --- ** account names
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountnamep :: ErroringJournalParser AccountName modifiedaccountnamep :: JournalStateParser m AccountName
modifiedaccountnamep = do modifiedaccountnamep = do
parent <- getParentAccount parent <- getParentAccount
aliases <- getAccountAliases aliases <- getAccountAliases
@ -305,7 +306,7 @@ accountnamep = do
-- | Parse whitespace then an amount, with an optional left or right -- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special -- currency symbol and optional price, or return the special
-- "missing" marker amount. -- "missing" marker amount.
spaceandamountormissingp :: ErroringJournalParser MixedAmount spaceandamountormissingp :: Monad m => JournalStateParser m MixedAmount
spaceandamountormissingp = spaceandamountormissingp =
try (do try (do
lift $ some spacenonewline lift $ some spacenonewline
@ -426,7 +427,7 @@ priceamountp =
return $ UnitPrice a)) return $ UnitPrice a))
<|> return NoPrice <|> return NoPrice
partialbalanceassertionp :: ErroringJournalParser (Maybe MixedAmount) partialbalanceassertionp :: Monad m => JournalStateParser m (Maybe MixedAmount)
partialbalanceassertionp = partialbalanceassertionp =
try (do try (do
lift (many spacenonewline) lift (many spacenonewline)
@ -447,7 +448,7 @@ partialbalanceassertionp =
-- <|> return Nothing -- <|> return Nothing
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotpricep :: ErroringJournalParser (Maybe Amount) fixedlotpricep :: Monad m => JournalStateParser m (Maybe Amount)
fixedlotpricep = fixedlotpricep =
try (do try (do
lift (many spacenonewline) lift (many spacenonewline)
@ -547,7 +548,7 @@ numberp = do
--- ** comments --- ** comments
multilinecommentp :: ErroringJournalParser () multilinecommentp :: JournalStateParser m ()
multilinecommentp = do multilinecommentp = do
string "comment" >> lift (many spacenonewline) >> newline string "comment" >> lift (many spacenonewline) >> newline
go go
@ -556,13 +557,13 @@ multilinecommentp = do
<|> (anyLine >> go) <|> (anyLine >> go)
anyLine = anyChar `manyTill` newline anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: ErroringJournalParser () emptyorcommentlinep :: JournalStateParser m ()
emptyorcommentlinep = do emptyorcommentlinep = do
lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return "")) lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))
return () return ()
-- | Parse a possibly multi-line comment following a semicolon. -- | Parse a possibly multi-line comment following a semicolon.
followingcommentp :: ErroringJournalParser Text followingcommentp :: JournalStateParser m Text
followingcommentp = followingcommentp =
-- ptrace "followingcommentp" -- ptrace "followingcommentp"
do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return "")) do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return ""))
@ -588,7 +589,8 @@ followingcommentp =
-- >>> rejp (followingcommentandtagsp (Just $ fromGregorian 2000 1 2)) "; date:3/4=5/6" -- >>> rejp (followingcommentandtagsp (Just $ fromGregorian 2000 1 2)) "; date:3/4=5/6"
-- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing) -- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing)
-- --
followingcommentandtagsp :: Maybe Day -> ErroringJournalParser (Text, [Tag], Maybe Day, Maybe Day) followingcommentandtagsp :: MonadIO m => Maybe Day
-> ErroringJournalParser m (Text, [Tag], Maybe Day, Maybe Day)
followingcommentandtagsp mdefdate = do followingcommentandtagsp mdefdate = do
-- pdbg 0 "followingcommentandtagsp" -- pdbg 0 "followingcommentandtagsp"
@ -623,16 +625,16 @@ followingcommentandtagsp mdefdate = do
return (comment, tags, mdate, mdate2) return (comment, tags, mdate, mdate2)
commentp :: ErroringJournalParser Text commentp :: JournalStateParser m Text
commentp = commentStartingWithp commentchars commentp = commentStartingWithp commentchars
commentchars :: [Char] commentchars :: [Char]
commentchars = "#;*" commentchars = "#;*"
semicoloncommentp :: ErroringJournalParser Text semicoloncommentp :: JournalStateParser m Text
semicoloncommentp = commentStartingWithp ";" semicoloncommentp = commentStartingWithp ";"
commentStartingWithp :: [Char] -> ErroringJournalParser Text commentStartingWithp :: [Char] -> JournalStateParser m Text
commentStartingWithp cs = do commentStartingWithp cs = do
-- ptrace "commentStartingWith" -- ptrace "commentStartingWith"
oneOf cs oneOf cs
@ -714,7 +716,7 @@ tagvaluep = do
-- are parsed fully to give useful errors. Missing years can be -- are parsed fully to give useful errors. Missing years can be
-- inferred only if a default date is provided. -- inferred only if a default date is provided.
-- --
postingdatesp :: Maybe Day -> ErroringJournalParser [(TagName,Day)] postingdatesp :: Monad m => Maybe Day -> ErroringJournalParser m [(TagName,Day)]
postingdatesp mdefdate = do postingdatesp mdefdate = do
-- pdbg 0 $ "postingdatesp" -- pdbg 0 $ "postingdatesp"
let p = ((:[]) <$> datetagp mdefdate) <|> bracketeddatetagsp mdefdate let p = ((:[]) <$> datetagp mdefdate) <|> bracketeddatetagsp mdefdate
@ -739,7 +741,7 @@ postingdatesp mdefdate = do
-- >>> rejp (datetagp Nothing) "date: 3/4" -- >>> rejp (datetagp Nothing) "date: 3/4"
-- Left ...1:9...partial date 3/4 found, but the current year is unknown... -- Left ...1:9...partial date 3/4 found, but the current year is unknown...
-- --
datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day) datetagp :: Monad m => Maybe Day -> ErroringJournalParser m (TagName,Day)
datetagp mdefdate = do datetagp mdefdate = do
-- pdbg 0 "datetagp" -- pdbg 0 "datetagp"
string "date" string "date"
@ -795,7 +797,7 @@ datetagp mdefdate = do
-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" -- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
-- Left ...1:15:...bad date, different separators... -- Left ...1:15:...bad date, different separators...
-- --
bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)] bracketeddatetagsp :: Monad m => Maybe Day -> ErroringJournalParser m [(TagName, Day)]
bracketeddatetagsp mdefdate = do bracketeddatetagsp mdefdate = do
-- pdbg 0 "bracketeddatetagsp" -- pdbg 0 "bracketeddatetagsp"
char '[' char '['

54
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -127,7 +127,7 @@ parse _ = parseAndFinaliseJournal journalp
-- >>> rejp (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 Journal with 1 transactions, 1 accounts
-- --
journalp :: ErroringJournalParser ParsedJournal journalp :: MonadIO m => ErroringJournalParser m ParsedJournal
journalp = do journalp = do
many addJournalItemP many addJournalItemP
eof eof
@ -135,7 +135,7 @@ journalp = do
-- | A side-effecting parser; parses any kind of journal item -- | A side-effecting parser; parses any kind of journal item
-- and updates the parse state accordingly. -- and updates the parse state accordingly.
addJournalItemP :: ErroringJournalParser () addJournalItemP :: MonadIO m => ErroringJournalParser m ()
addJournalItemP = addJournalItemP =
-- all journal line types can be distinguished by the first -- all journal line types can be distinguished by the first
-- character, can use choice without backtracking -- character, can use choice without backtracking
@ -154,7 +154,7 @@ addJournalItemP =
-- | Parse any journal directive and update the parse state accordingly. -- | Parse any journal directive and update the parse state accordingly.
-- Cf http://hledger.org/manual.html#directives, -- Cf http://hledger.org/manual.html#directives,
-- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -- http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directivep :: ErroringJournalParser () directivep :: MonadIO m => ErroringJournalParser m ()
directivep = (do directivep = (do
optional $ char '!' optional $ char '!'
choiceInState [ choiceInState [
@ -174,7 +174,7 @@ directivep = (do
] ]
) <?> "directive" ) <?> "directive"
includedirectivep :: ErroringJournalParser () includedirectivep :: MonadIO m => ErroringJournalParser m ()
includedirectivep = do includedirectivep = do
string "include" string "include"
lift (some spacenonewline) lift (some spacenonewline)
@ -227,15 +227,17 @@ orRethrowIOError io msg =
(Right <$> io) (Right <$> io)
`C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e) `C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e)
accountdirectivep :: ErroringJournalParser () accountdirectivep :: JournalStateParser m ()
accountdirectivep = do accountdirectivep = do
string "account" string "account"
lift (some spacenonewline) lift (some spacenonewline)
acct <- lift accountnamep acct <- lift accountnamep
newline newline
_ <- many indentedlinep many indentedlinep
modify' (\j -> j{jaccounts = acct : jaccounts j}) modify' (\j -> j{jaccounts = acct : jaccounts j})
indentedlinep :: JournalStateParser m String
indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline) indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)
-- | Parse a one-line or multi-line commodity directive. -- | Parse a one-line or multi-line commodity directive.
@ -244,14 +246,14 @@ indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)
-- >>> Right _ <- rejp commoditydirectivep "commodity $\n format $1.00" -- >>> Right _ <- rejp commoditydirectivep "commodity $\n format $1.00"
-- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format -- >>> Right _ <- rejp commoditydirectivep "commodity $\n\n" -- a commodity with no format
-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ? -- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ?
commoditydirectivep :: ErroringJournalParser () commoditydirectivep :: Monad m => ErroringJournalParser m ()
commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep
-- | Parse a one-line commodity directive. -- | Parse a one-line commodity directive.
-- --
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
commoditydirectiveonelinep :: ErroringJournalParser () commoditydirectiveonelinep :: Monad m => JournalStateParser m ()
commoditydirectiveonelinep = do commoditydirectiveonelinep = do
string "commodity" string "commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -264,7 +266,7 @@ commoditydirectiveonelinep = do
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives. -- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
-- --
-- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah" -- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah"
commoditydirectivemultilinep :: ErroringJournalParser () commoditydirectivemultilinep :: Monad m => ErroringJournalParser m ()
commoditydirectivemultilinep = do commoditydirectivemultilinep = do
string "commodity" string "commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -278,7 +280,7 @@ commoditydirectivemultilinep = do
-- | Parse a format (sub)directive, throwing a parse error if its -- | Parse a format (sub)directive, throwing a parse error if its
-- symbol does not match the one given. -- symbol does not match the one given.
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle formatdirectivep :: Monad m => CommoditySymbol -> ErroringJournalParser m AmountStyle
formatdirectivep expectedsym = do formatdirectivep expectedsym = do
string "format" string "format"
lift (some spacenonewline) lift (some spacenonewline)
@ -290,7 +292,7 @@ formatdirectivep expectedsym = do
else parserErrorAt pos $ else parserErrorAt pos $
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
applyaccountdirectivep :: ErroringJournalParser () applyaccountdirectivep :: JournalStateParser m ()
applyaccountdirectivep = do applyaccountdirectivep = do
string "apply" >> lift (some spacenonewline) >> string "account" string "apply" >> lift (some spacenonewline) >> string "account"
lift (some spacenonewline) lift (some spacenonewline)
@ -298,12 +300,12 @@ applyaccountdirectivep = do
newline newline
pushParentAccount parent pushParentAccount parent
endapplyaccountdirectivep :: ErroringJournalParser () endapplyaccountdirectivep :: JournalStateParser m ()
endapplyaccountdirectivep = do endapplyaccountdirectivep = do
string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account" string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account"
popParentAccount popParentAccount
aliasdirectivep :: ErroringJournalParser () aliasdirectivep :: JournalStateParser m ()
aliasdirectivep = do aliasdirectivep = do
string "alias" string "alias"
lift (some spacenonewline) lift (some spacenonewline)
@ -334,12 +336,12 @@ regexaliasp = do
repl <- rstrip <$> anyChar `manyTill` eolof repl <- rstrip <$> anyChar `manyTill` eolof
return $ RegexAlias re repl return $ RegexAlias re repl
endaliasesdirectivep :: ErroringJournalParser () endaliasesdirectivep :: JournalStateParser m ()
endaliasesdirectivep = do endaliasesdirectivep = do
string "end aliases" string "end aliases"
clearAccountAliases clearAccountAliases
tagdirectivep :: ErroringJournalParser () tagdirectivep :: JournalStateParser m ()
tagdirectivep = do tagdirectivep = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
lift (some spacenonewline) lift (some spacenonewline)
@ -347,13 +349,13 @@ tagdirectivep = do
lift restofline lift restofline
return () return ()
endtagdirectivep :: ErroringJournalParser () endtagdirectivep :: JournalStateParser m ()
endtagdirectivep = do endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive" (string "end tag" <|> string "pop") <?> "end tag or pop directive"
lift restofline lift restofline
return () return ()
defaultyeardirectivep :: ErroringJournalParser () defaultyeardirectivep :: JournalStateParser m ()
defaultyeardirectivep = do defaultyeardirectivep = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
lift (many spacenonewline) lift (many spacenonewline)
@ -362,7 +364,7 @@ defaultyeardirectivep = do
failIfInvalidYear y failIfInvalidYear y
setYear y' setYear y'
defaultcommoditydirectivep :: ErroringJournalParser () defaultcommoditydirectivep :: Monad m => JournalStateParser m ()
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -370,7 +372,7 @@ defaultcommoditydirectivep = do
lift restofline lift restofline
setDefaultCommodityAndStyle (acommodity, astyle) setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: ErroringJournalParser MarketPrice marketpricedirectivep :: Monad m => JournalStateParser m MarketPrice
marketpricedirectivep = do marketpricedirectivep = do
char 'P' <?> "market price" char 'P' <?> "market price"
lift (many spacenonewline) lift (many spacenonewline)
@ -382,7 +384,7 @@ marketpricedirectivep = do
lift restofline lift restofline
return $ MarketPrice date symbol price return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: ErroringJournalParser () ignoredpricecommoditydirectivep :: JournalStateParser m ()
ignoredpricecommoditydirectivep = do ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -390,7 +392,7 @@ ignoredpricecommoditydirectivep = do
lift restofline lift restofline
return () return ()
commodityconversiondirectivep :: ErroringJournalParser () commodityconversiondirectivep :: Monad m => JournalStateParser m ()
commodityconversiondirectivep = do commodityconversiondirectivep = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
lift (some spacenonewline) lift (some spacenonewline)
@ -404,7 +406,7 @@ commodityconversiondirectivep = do
--- ** transactions --- ** transactions
modifiertransactionp :: ErroringJournalParser ModifierTransaction modifiertransactionp :: MonadIO m => ErroringJournalParser m ModifierTransaction
modifiertransactionp = do modifiertransactionp = do
char '=' <?> "modifier transaction" char '=' <?> "modifier transaction"
lift (many spacenonewline) lift (many spacenonewline)
@ -412,7 +414,7 @@ modifiertransactionp = do
postings <- postingsp Nothing postings <- postingsp Nothing
return $ ModifierTransaction valueexpr postings return $ ModifierTransaction valueexpr postings
periodictransactionp :: ErroringJournalParser PeriodicTransaction periodictransactionp :: MonadIO m => ErroringJournalParser m PeriodicTransaction
periodictransactionp = do periodictransactionp = do
char '~' <?> "periodic transaction" char '~' <?> "periodic transaction"
lift (many spacenonewline) lift (many spacenonewline)
@ -421,7 +423,7 @@ periodictransactionp = do
return $ PeriodicTransaction periodexpr postings return $ PeriodicTransaction periodexpr postings
-- | Parse a (possibly unbalanced) transaction. -- | Parse a (possibly unbalanced) transaction.
transactionp :: ErroringJournalParser Transaction transactionp :: MonadIO m => ErroringJournalParser m Transaction
transactionp = do transactionp = do
-- ptrace "transactionp" -- ptrace "transactionp"
sourcepos <- genericSourcePos <$> getPosition sourcepos <- genericSourcePos <$> getPosition
@ -533,7 +535,7 @@ test_transactionp = do
-- Parse the following whitespace-beginning lines as postings, posting -- Parse the following whitespace-beginning lines as postings, posting
-- tags, and/or comments (inferring year, if needed, from the given date). -- tags, and/or comments (inferring year, if needed, from the given date).
postingsp :: Maybe Day -> ErroringJournalParser [Posting] postingsp :: MonadIO m => Maybe Day -> ErroringJournalParser m [Posting]
postingsp mdate = many (try $ postingp mdate) <?> "postings" postingsp mdate = many (try $ postingp mdate) <?> "postings"
-- linebeginningwithspaces :: Monad m => JournalParser m String -- linebeginningwithspaces :: Monad m => JournalParser m String
@ -543,7 +545,7 @@ postingsp mdate = many (try $ postingp mdate) <?> "postings"
-- cs <- lift restofline -- cs <- lift restofline
-- return $ sp ++ (c:cs) ++ "\n" -- return $ sp ++ (c:cs) ++ "\n"
postingp :: Maybe Day -> ErroringJournalParser Posting postingp :: MonadIO m => Maybe Day -> ErroringJournalParser m Posting
postingp mtdate = do postingp mtdate = do
-- pdbg 0 "postingp" -- pdbg 0 "postingp"
lift (some spacenonewline) lift (some spacenonewline)

4
hledger-lib/Hledger/Read/TimeclockReader.hs
View File

@ -82,7 +82,7 @@ reader = Reader
parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timeclockfilep parse _ = parseAndFinaliseJournal timeclockfilep
timeclockfilep :: ErroringJournalParser ParsedJournal timeclockfilep :: ErroringJournalParser IO ParsedJournal
timeclockfilep = do many timeclockitemp timeclockfilep = do many timeclockitemp
eof eof
j@Journal{jparsetimeclockentries=es} <- get j@Journal{jparsetimeclockentries=es} <- get
@ -105,7 +105,7 @@ timeclockfilep = do many timeclockitemp
] <?> "timeclock entry, or default year or historical price directive" ] <?> "timeclock entry, or default year or historical price directive"
-- | Parse a timeclock entry. -- | Parse a timeclock entry.
timeclockentryp :: ErroringJournalParser TimeclockEntry timeclockentryp :: JournalStateParser m TimeclockEntry
timeclockentryp = do timeclockentryp = do
sourcepos <- genericSourcePos <$> lift getPosition sourcepos <- genericSourcePos <$> lift getPosition
code <- oneOf ("bhioO" :: [Char]) code <- oneOf ("bhioO" :: [Char])

15
hledger-lib/Hledger/Read/TimedotReader.hs
View File

@ -51,6 +51,7 @@ import Hledger.Utils hiding (ptrace)
-- easier to toggle this here sometimes -- easier to toggle this here sometimes
-- import qualified Hledger.Utils (ptrace) -- import qualified Hledger.Utils (ptrace)
-- ptrace = Hledger.Utils.ptrace -- ptrace = Hledger.Utils.ptrace
ptrace :: Monad m => a -> m a
ptrace = return ptrace = return
reader :: Reader reader :: Reader
@ -65,12 +66,12 @@ reader = Reader
parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timedotfilep parse _ = parseAndFinaliseJournal timedotfilep
timedotfilep :: ErroringJournalParser ParsedJournal timedotfilep :: JournalStateParser m ParsedJournal
timedotfilep = do many timedotfileitemp timedotfilep = do many timedotfileitemp
eof eof
get get
where where
timedotfileitemp :: ErroringJournalParser () timedotfileitemp :: JournalStateParser m ()
timedotfileitemp = do timedotfileitemp = do
ptrace "timedotfileitemp" ptrace "timedotfileitemp"
choice [ choice [
@ -88,7 +89,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
-- biz.research . -- biz.research .
-- inc.client1 .... .... .... .... .... .... -- inc.client1 .... .... .... .... .... ....
-- @ -- @
timedotdayp :: ErroringJournalParser [Transaction] timedotdayp :: JournalStateParser m [Transaction]
timedotdayp = do timedotdayp = do
ptrace " timedotdayp" ptrace " timedotdayp"
d <- datep <* lift eolof d <- datep <* lift eolof
@ -100,7 +101,7 @@ timedotdayp = do
-- @ -- @
-- fos.haskell .... .. -- fos.haskell .... ..
-- @ -- @
timedotentryp :: ErroringJournalParser Transaction timedotentryp :: JournalStateParser m Transaction
timedotentryp = do timedotentryp = do
ptrace " timedotentryp" ptrace " timedotentryp"
pos <- genericSourcePos <$> getPosition pos <- genericSourcePos <$> getPosition
@ -124,14 +125,14 @@ timedotentryp = do
} }
return t return t
timedotdurationp :: ErroringJournalParser Quantity timedotdurationp :: JournalStateParser m Quantity
timedotdurationp = try timedotnumberp <|> timedotdotsp timedotdurationp = try timedotnumberp <|> timedotdotsp
-- | Parse a duration written as a decimal number of hours (optionally followed by the letter h). -- | Parse a duration written as a decimal number of hours (optionally followed by the letter h).
-- @ -- @
-- 1.5h -- 1.5h
-- @ -- @
timedotnumberp :: ErroringJournalParser Quantity timedotnumberp :: JournalStateParser m Quantity
timedotnumberp = do timedotnumberp = do
(q, _, _, _) <- lift numberp (q, _, _, _) <- lift numberp
lift (many spacenonewline) lift (many spacenonewline)
@ -143,7 +144,7 @@ timedotnumberp = do
-- @ -- @
-- .... .. -- .... ..
-- @ -- @
timedotdotsp :: ErroringJournalParser Quantity timedotdotsp :: JournalStateParser m Quantity
timedotdotsp = do timedotdotsp = do
dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char])) dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
return $ (/4) $ fromIntegral $ length dots return $ (/4) $ fromIntegral $ length dots

2
hledger-lib/Hledger/Utils/Parse.hs
View File

@ -22,7 +22,7 @@ type JournalStateParser m a = StateT Journal (ParsecT Dec Text m) a
type JournalParser a = StateT Journal (ParsecT Dec Text Identity) a type JournalParser a = StateT Journal (ParsecT Dec Text Identity) a
-- | A journal parser that runs in IO and can throw an error mid-parse. -- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = StateT Journal (ParsecT Dec Text (ExceptT String IO)) a type ErroringJournalParser m a = StateT Journal (ParsecT Dec Text (ExceptT String m)) a
-- | 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.

2
tests/cli/multiple-files.test
View File

@ -56,3 +56,5 @@ hledger print -f personal.journal -f a.timeclock -f b.timedot
(b.bb) 1.00 (b.bb) 1.00
>>>=0 >>>=0
u