more general parser types enabling reuse outside of IO (#439)
This commit is contained in:
Johannes Gerer
Simon Michael
parent
31e4f538c0
commit
74502f7e50
@ -57,7 +57,7 @@ runJournalParser p t = runParserT p "" t
|
||||
rjp = runJournalParser
|
||||
|
||||
-- | 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 =
|
||||
runExceptT $
|
||||
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
|
||||
-- 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
|
||||
t <- liftIO getClockTime
|
||||
y <- liftIO getCurrentYear
|
||||
@ -98,26 +99,26 @@ setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
|
||||
getYear :: JournalStateParser m (Maybe Year)
|
||||
getYear = fmap jparsedefaultyear get
|
||||
|
||||
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> ErroringJournalParser ()
|
||||
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalStateParser m ()
|
||||
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
|
||||
|
||||
getDefaultCommodityAndStyle :: JournalStateParser m (Maybe (CommoditySymbol,AmountStyle))
|
||||
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
|
||||
|
||||
pushAccount :: AccountName -> ErroringJournalParser ()
|
||||
pushAccount :: AccountName -> JournalStateParser m ()
|
||||
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})
|
||||
|
||||
popParentAccount :: ErroringJournalParser ()
|
||||
popParentAccount :: JournalStateParser m ()
|
||||
popParentAccount = do
|
||||
j <- get
|
||||
case jparseparentaccounts j of
|
||||
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
|
||||
(_:rest) -> put j{jparseparentaccounts=rest}
|
||||
|
||||
getParentAccount :: ErroringJournalParser AccountName
|
||||
getParentAccount :: JournalStateParser m AccountName
|
||||
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
|
||||
|
||||
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
|
||||
-- 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
|
||||
|
||||
--- * parsers
|
||||
@ -173,7 +174,7 @@ statusp =
|
||||
codep :: TextParser m String
|
||||
codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
|
||||
|
||||
descriptionp :: ErroringJournalParser String
|
||||
descriptionp :: JournalStateParser m String
|
||||
descriptionp = many (noneOf (";\n" :: [Char]))
|
||||
|
||||
--- ** dates
|
||||
@ -212,7 +213,7 @@ datep = do
|
||||
-- Seconds are optional.
|
||||
-- The timezone is optional and ignored (the time is always interpreted as a local time).
|
||||
-- Leading zeroes may be omitted (except in a timezone).
|
||||
datetimep :: ErroringJournalParser LocalTime
|
||||
datetimep :: JournalStateParser m LocalTime
|
||||
datetimep = do
|
||||
day <- datep
|
||||
lift $ some spacenonewline
|
||||
@ -240,7 +241,7 @@ datetimep = do
|
||||
-- return $ localTimeToUTC tz' $ 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
|
||||
char '='
|
||||
-- kludgy way to use primary date for default year
|
||||
@ -266,7 +267,7 @@ secondarydatep primarydate = do
|
||||
--- ** account names
|
||||
|
||||
-- | 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
|
||||
parent <- getParentAccount
|
||||
aliases <- getAccountAliases
|
||||
@ -305,7 +306,7 @@ accountnamep = do
|
||||
-- | Parse whitespace then an amount, with an optional left or right
|
||||
-- currency symbol and optional price, or return the special
|
||||
-- "missing" marker amount.
|
||||
spaceandamountormissingp :: ErroringJournalParser MixedAmount
|
||||
spaceandamountormissingp :: Monad m => JournalStateParser m MixedAmount
|
||||
spaceandamountormissingp =
|
||||
try (do
|
||||
lift $ some spacenonewline
|
||||
@ -426,7 +427,7 @@ priceamountp =
|
||||
return $ UnitPrice a))
|
||||
<|> return NoPrice
|
||||
|
||||
partialbalanceassertionp :: ErroringJournalParser (Maybe MixedAmount)
|
||||
partialbalanceassertionp :: Monad m => JournalStateParser m (Maybe MixedAmount)
|
||||
partialbalanceassertionp =
|
||||
try (do
|
||||
lift (many spacenonewline)
|
||||
@ -447,7 +448,7 @@ partialbalanceassertionp =
|
||||
-- <|> return Nothing
|
||||
|
||||
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
|
||||
fixedlotpricep :: ErroringJournalParser (Maybe Amount)
|
||||
fixedlotpricep :: Monad m => JournalStateParser m (Maybe Amount)
|
||||
fixedlotpricep =
|
||||
try (do
|
||||
lift (many spacenonewline)
|
||||
@ -547,7 +548,7 @@ numberp = do
|
||||
|
||||
--- ** comments
|
||||
|
||||
multilinecommentp :: ErroringJournalParser ()
|
||||
multilinecommentp :: JournalStateParser m ()
|
||||
multilinecommentp = do
|
||||
string "comment" >> lift (many spacenonewline) >> newline
|
||||
go
|
||||
@ -556,13 +557,13 @@ multilinecommentp = do
|
||||
<|> (anyLine >> go)
|
||||
anyLine = anyChar `manyTill` newline
|
||||
|
||||
emptyorcommentlinep :: ErroringJournalParser ()
|
||||
emptyorcommentlinep :: JournalStateParser m ()
|
||||
emptyorcommentlinep = do
|
||||
lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))
|
||||
return ()
|
||||
|
||||
-- | Parse a possibly multi-line comment following a semicolon.
|
||||
followingcommentp :: ErroringJournalParser Text
|
||||
followingcommentp :: JournalStateParser m Text
|
||||
followingcommentp =
|
||||
-- ptrace "followingcommentp"
|
||||
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"
|
||||
-- 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
|
||||
-- pdbg 0 "followingcommentandtagsp"
|
||||
|
||||
@ -623,16 +625,16 @@ followingcommentandtagsp mdefdate = do
|
||||
|
||||
return (comment, tags, mdate, mdate2)
|
||||
|
||||
commentp :: ErroringJournalParser Text
|
||||
commentp :: JournalStateParser m Text
|
||||
commentp = commentStartingWithp commentchars
|
||||
|
||||
commentchars :: [Char]
|
||||
commentchars = "#;*"
|
||||
|
||||
semicoloncommentp :: ErroringJournalParser Text
|
||||
semicoloncommentp :: JournalStateParser m Text
|
||||
semicoloncommentp = commentStartingWithp ";"
|
||||
|
||||
commentStartingWithp :: [Char] -> ErroringJournalParser Text
|
||||
commentStartingWithp :: [Char] -> JournalStateParser m Text
|
||||
commentStartingWithp cs = do
|
||||
-- ptrace "commentStartingWith"
|
||||
oneOf cs
|
||||
@ -714,7 +716,7 @@ tagvaluep = do
|
||||
-- are parsed fully to give useful errors. Missing years can be
|
||||
-- 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
|
||||
-- pdbg 0 $ "postingdatesp"
|
||||
let p = ((:[]) <$> datetagp mdefdate) <|> bracketeddatetagsp mdefdate
|
||||
@ -739,7 +741,7 @@ postingdatesp mdefdate = do
|
||||
-- >>> rejp (datetagp Nothing) "date: 3/4"
|
||||
-- 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
|
||||
-- pdbg 0 "datetagp"
|
||||
string "date"
|
||||
@ -795,7 +797,7 @@ datetagp mdefdate = do
|
||||
-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
|
||||
-- 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
|
||||
-- pdbg 0 "bracketeddatetagsp"
|
||||
char '['
|
||||
|
||||
@ -127,7 +127,7 @@ parse _ = parseAndFinaliseJournal journalp
|
||||
-- >>> rejp (journalp <* eof) "2015/1/1\n a 0\n"
|
||||
-- Right Journal with 1 transactions, 1 accounts
|
||||
--
|
||||
journalp :: ErroringJournalParser 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 :: ErroringJournalParser ()
|
||||
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 :: ErroringJournalParser ()
|
||||
directivep :: MonadIO m => ErroringJournalParser m ()
|
||||
directivep = (do
|
||||
optional $ char '!'
|
||||
choiceInState [
|
||||
@ -174,7 +174,7 @@ directivep = (do
|
||||
]
|
||||
) <?> "directive"
|
||||
|
||||
includedirectivep :: ErroringJournalParser ()
|
||||
includedirectivep :: MonadIO m => ErroringJournalParser m ()
|
||||
includedirectivep = do
|
||||
string "include"
|
||||
lift (some spacenonewline)
|
||||
@ -227,15 +227,17 @@ orRethrowIOError io msg =
|
||||
(Right <$> io)
|
||||
`C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e)
|
||||
|
||||
accountdirectivep :: ErroringJournalParser ()
|
||||
accountdirectivep :: JournalStateParser m ()
|
||||
accountdirectivep = do
|
||||
string "account"
|
||||
lift (some spacenonewline)
|
||||
acct <- lift accountnamep
|
||||
newline
|
||||
_ <- many indentedlinep
|
||||
many indentedlinep
|
||||
modify' (\j -> j{jaccounts = acct : jaccounts j})
|
||||
|
||||
|
||||
indentedlinep :: JournalStateParser m String
|
||||
indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)
|
||||
|
||||
-- | 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\n" -- a commodity with no format
|
||||
-- >>> Right _ <- rejp commoditydirectivep "commodity $1.00\n format $1.00" -- both, what happens ?
|
||||
commoditydirectivep :: ErroringJournalParser ()
|
||||
commoditydirectivep :: Monad m => ErroringJournalParser m ()
|
||||
commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemultilinep
|
||||
|
||||
-- | Parse a one-line commodity directive.
|
||||
--
|
||||
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"
|
||||
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
|
||||
commoditydirectiveonelinep :: ErroringJournalParser ()
|
||||
commoditydirectiveonelinep :: Monad m => JournalStateParser m ()
|
||||
commoditydirectiveonelinep = do
|
||||
string "commodity"
|
||||
lift (some spacenonewline)
|
||||
@ -264,7 +266,7 @@ commoditydirectiveonelinep = do
|
||||
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
|
||||
--
|
||||
-- >>> Right _ <- rejp commoditydirectivemultilinep "commodity $ ; blah \n format $1.00 ; blah"
|
||||
commoditydirectivemultilinep :: ErroringJournalParser ()
|
||||
commoditydirectivemultilinep :: Monad m => ErroringJournalParser m ()
|
||||
commoditydirectivemultilinep = do
|
||||
string "commodity"
|
||||
lift (some spacenonewline)
|
||||
@ -278,7 +280,7 @@ commoditydirectivemultilinep = do
|
||||
|
||||
-- | Parse a format (sub)directive, throwing a parse error if its
|
||||
-- symbol does not match the one given.
|
||||
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle
|
||||
formatdirectivep :: Monad m => CommoditySymbol -> ErroringJournalParser m AmountStyle
|
||||
formatdirectivep expectedsym = do
|
||||
string "format"
|
||||
lift (some spacenonewline)
|
||||
@ -290,7 +292,7 @@ formatdirectivep expectedsym = do
|
||||
else parserErrorAt pos $
|
||||
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
|
||||
|
||||
applyaccountdirectivep :: ErroringJournalParser ()
|
||||
applyaccountdirectivep :: JournalStateParser m ()
|
||||
applyaccountdirectivep = do
|
||||
string "apply" >> lift (some spacenonewline) >> string "account"
|
||||
lift (some spacenonewline)
|
||||
@ -298,12 +300,12 @@ applyaccountdirectivep = do
|
||||
newline
|
||||
pushParentAccount parent
|
||||
|
||||
endapplyaccountdirectivep :: ErroringJournalParser ()
|
||||
endapplyaccountdirectivep :: JournalStateParser m ()
|
||||
endapplyaccountdirectivep = do
|
||||
string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account"
|
||||
popParentAccount
|
||||
|
||||
aliasdirectivep :: ErroringJournalParser ()
|
||||
aliasdirectivep :: JournalStateParser m ()
|
||||
aliasdirectivep = do
|
||||
string "alias"
|
||||
lift (some spacenonewline)
|
||||
@ -334,12 +336,12 @@ regexaliasp = do
|
||||
repl <- rstrip <$> anyChar `manyTill` eolof
|
||||
return $ RegexAlias re repl
|
||||
|
||||
endaliasesdirectivep :: ErroringJournalParser ()
|
||||
endaliasesdirectivep :: JournalStateParser m ()
|
||||
endaliasesdirectivep = do
|
||||
string "end aliases"
|
||||
clearAccountAliases
|
||||
|
||||
tagdirectivep :: ErroringJournalParser ()
|
||||
tagdirectivep :: JournalStateParser m ()
|
||||
tagdirectivep = do
|
||||
string "tag" <?> "tag directive"
|
||||
lift (some spacenonewline)
|
||||
@ -347,13 +349,13 @@ tagdirectivep = do
|
||||
lift restofline
|
||||
return ()
|
||||
|
||||
endtagdirectivep :: ErroringJournalParser ()
|
||||
endtagdirectivep :: JournalStateParser m ()
|
||||
endtagdirectivep = do
|
||||
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
|
||||
lift restofline
|
||||
return ()
|
||||
|
||||
defaultyeardirectivep :: ErroringJournalParser ()
|
||||
defaultyeardirectivep :: JournalStateParser m ()
|
||||
defaultyeardirectivep = do
|
||||
char 'Y' <?> "default year"
|
||||
lift (many spacenonewline)
|
||||
@ -362,7 +364,7 @@ defaultyeardirectivep = do
|
||||
failIfInvalidYear y
|
||||
setYear y'
|
||||
|
||||
defaultcommoditydirectivep :: ErroringJournalParser ()
|
||||
defaultcommoditydirectivep :: Monad m => JournalStateParser m ()
|
||||
defaultcommoditydirectivep = do
|
||||
char 'D' <?> "default commodity"
|
||||
lift (some spacenonewline)
|
||||
@ -370,7 +372,7 @@ defaultcommoditydirectivep = do
|
||||
lift restofline
|
||||
setDefaultCommodityAndStyle (acommodity, astyle)
|
||||
|
||||
marketpricedirectivep :: ErroringJournalParser MarketPrice
|
||||
marketpricedirectivep :: Monad m => JournalStateParser m MarketPrice
|
||||
marketpricedirectivep = do
|
||||
char 'P' <?> "market price"
|
||||
lift (many spacenonewline)
|
||||
@ -382,7 +384,7 @@ marketpricedirectivep = do
|
||||
lift restofline
|
||||
return $ MarketPrice date symbol price
|
||||
|
||||
ignoredpricecommoditydirectivep :: ErroringJournalParser ()
|
||||
ignoredpricecommoditydirectivep :: JournalStateParser m ()
|
||||
ignoredpricecommoditydirectivep = do
|
||||
char 'N' <?> "ignored-price commodity"
|
||||
lift (some spacenonewline)
|
||||
@ -390,7 +392,7 @@ ignoredpricecommoditydirectivep = do
|
||||
lift restofline
|
||||
return ()
|
||||
|
||||
commodityconversiondirectivep :: ErroringJournalParser ()
|
||||
commodityconversiondirectivep :: Monad m => JournalStateParser m ()
|
||||
commodityconversiondirectivep = do
|
||||
char 'C' <?> "commodity conversion"
|
||||
lift (some spacenonewline)
|
||||
@ -404,7 +406,7 @@ commodityconversiondirectivep = do
|
||||
|
||||
--- ** transactions
|
||||
|
||||
modifiertransactionp :: ErroringJournalParser ModifierTransaction
|
||||
modifiertransactionp :: MonadIO m => ErroringJournalParser m ModifierTransaction
|
||||
modifiertransactionp = do
|
||||
char '=' <?> "modifier transaction"
|
||||
lift (many spacenonewline)
|
||||
@ -412,7 +414,7 @@ modifiertransactionp = do
|
||||
postings <- postingsp Nothing
|
||||
return $ ModifierTransaction valueexpr postings
|
||||
|
||||
periodictransactionp :: ErroringJournalParser PeriodicTransaction
|
||||
periodictransactionp :: MonadIO m => ErroringJournalParser m PeriodicTransaction
|
||||
periodictransactionp = do
|
||||
char '~' <?> "periodic transaction"
|
||||
lift (many spacenonewline)
|
||||
@ -421,7 +423,7 @@ periodictransactionp = do
|
||||
return $ PeriodicTransaction periodexpr postings
|
||||
|
||||
-- | Parse a (possibly unbalanced) transaction.
|
||||
transactionp :: ErroringJournalParser Transaction
|
||||
transactionp :: MonadIO m => ErroringJournalParser m Transaction
|
||||
transactionp = do
|
||||
-- ptrace "transactionp"
|
||||
sourcepos <- genericSourcePos <$> getPosition
|
||||
@ -533,7 +535,7 @@ test_transactionp = do
|
||||
|
||||
-- Parse the following whitespace-beginning lines as postings, posting
|
||||
-- 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"
|
||||
|
||||
-- linebeginningwithspaces :: Monad m => JournalParser m String
|
||||
@ -543,7 +545,7 @@ postingsp mdate = many (try $ postingp mdate) <?> "postings"
|
||||
-- cs <- lift restofline
|
||||
-- return $ sp ++ (c:cs) ++ "\n"
|
||||
|
||||
postingp :: Maybe Day -> ErroringJournalParser Posting
|
||||
postingp :: MonadIO m => Maybe Day -> ErroringJournalParser m Posting
|
||||
postingp mtdate = do
|
||||
-- pdbg 0 "postingp"
|
||||
lift (some spacenonewline)
|
||||
|
||||
@ -82,7 +82,7 @@ reader = Reader
|
||||
parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
|
||||
parse _ = parseAndFinaliseJournal timeclockfilep
|
||||
|
||||
timeclockfilep :: ErroringJournalParser ParsedJournal
|
||||
timeclockfilep :: ErroringJournalParser IO ParsedJournal
|
||||
timeclockfilep = do many timeclockitemp
|
||||
eof
|
||||
j@Journal{jparsetimeclockentries=es} <- get
|
||||
@ -105,7 +105,7 @@ timeclockfilep = do many timeclockitemp
|
||||
] <?> "timeclock entry, or default year or historical price directive"
|
||||
|
||||
-- | Parse a timeclock entry.
|
||||
timeclockentryp :: ErroringJournalParser TimeclockEntry
|
||||
timeclockentryp :: JournalStateParser m TimeclockEntry
|
||||
timeclockentryp = do
|
||||
sourcepos <- genericSourcePos <$> lift getPosition
|
||||
code <- oneOf ("bhioO" :: [Char])
|
||||
|
||||
@ -51,6 +51,7 @@ import Hledger.Utils hiding (ptrace)
|
||||
-- easier to toggle this here sometimes
|
||||
-- import qualified Hledger.Utils (ptrace)
|
||||
-- ptrace = Hledger.Utils.ptrace
|
||||
ptrace :: Monad m => a -> m a
|
||||
ptrace = return
|
||||
|
||||
reader :: Reader
|
||||
@ -65,12 +66,12 @@ reader = Reader
|
||||
parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
|
||||
parse _ = parseAndFinaliseJournal timedotfilep
|
||||
|
||||
timedotfilep :: ErroringJournalParser ParsedJournal
|
||||
timedotfilep :: JournalStateParser m ParsedJournal
|
||||
timedotfilep = do many timedotfileitemp
|
||||
eof
|
||||
get
|
||||
where
|
||||
timedotfileitemp :: ErroringJournalParser ()
|
||||
timedotfileitemp :: JournalStateParser m ()
|
||||
timedotfileitemp = do
|
||||
ptrace "timedotfileitemp"
|
||||
choice [
|
||||
@ -88,7 +89,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
|
||||
-- biz.research .
|
||||
-- inc.client1 .... .... .... .... .... ....
|
||||
-- @
|
||||
timedotdayp :: ErroringJournalParser [Transaction]
|
||||
timedotdayp :: JournalStateParser m [Transaction]
|
||||
timedotdayp = do
|
||||
ptrace " timedotdayp"
|
||||
d <- datep <* lift eolof
|
||||
@ -100,7 +101,7 @@ timedotdayp = do
|
||||
-- @
|
||||
-- fos.haskell .... ..
|
||||
-- @
|
||||
timedotentryp :: ErroringJournalParser Transaction
|
||||
timedotentryp :: JournalStateParser m Transaction
|
||||
timedotentryp = do
|
||||
ptrace " timedotentryp"
|
||||
pos <- genericSourcePos <$> getPosition
|
||||
@ -124,14 +125,14 @@ timedotentryp = do
|
||||
}
|
||||
return t
|
||||
|
||||
timedotdurationp :: ErroringJournalParser Quantity
|
||||
timedotdurationp :: JournalStateParser m Quantity
|
||||
timedotdurationp = try timedotnumberp <|> timedotdotsp
|
||||
|
||||
-- | Parse a duration written as a decimal number of hours (optionally followed by the letter h).
|
||||
-- @
|
||||
-- 1.5h
|
||||
-- @
|
||||
timedotnumberp :: ErroringJournalParser Quantity
|
||||
timedotnumberp :: JournalStateParser m Quantity
|
||||
timedotnumberp = do
|
||||
(q, _, _, _) <- lift numberp
|
||||
lift (many spacenonewline)
|
||||
@ -143,7 +144,7 @@ timedotnumberp = do
|
||||
-- @
|
||||
-- .... ..
|
||||
-- @
|
||||
timedotdotsp :: ErroringJournalParser Quantity
|
||||
timedotdotsp :: JournalStateParser m Quantity
|
||||
timedotdotsp = do
|
||||
dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
|
||||
return $ (/4) $ fromIntegral $ length dots
|
||||
|
||||
@ -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
|
||||
|
||||
-- | 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.
|
||||
-- Consumes no input if all choices fail.
|
||||
|
||||
@ -56,3 +56,5 @@ hledger print -f personal.journal -f a.timeclock -f b.timedot
|
||||
(b.bb) 1.00
|
||||
|
||||
>>>=0
|
||||
|
||||
u
|
||||
Loading…
Reference in New Issue
Block a user