{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, NoMonoLocalBinds, ScopedTypeVariables, FlexibleContexts, TupleSections, OverloadedStrings, PackageImports #-}
module Hledger.Read.JournalReader (
reader,
genericSourcePos,
parseAndFinaliseJournal,
runJournalParser,
rjp,
getParentAccount,
journalp,
directivep,
defaultyeardirectivep,
marketpricedirectivep,
datetimep,
datep,
modifiedaccountnamep,
postingp,
statusp,
emptyorcommentlinep,
followingcommentp
,tests_JournalReader
)
where
import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile)
import qualified Control.Exception as C
import Control.Monad
import Control.Monad.Except (ExceptT(..))
import Control.Monad.State.Strict
import Data.Bifunctor (first)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.String
import Data.List
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Safe
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Text.Megaparsec.Custom
import Text.Printf
import System.FilePath
import "Glob" System.FilePath.Glob hiding (match)
import Hledger.Data
import Hledger.Read.Common
import Hledger.Read.TimeclockReader (timeclockfilep)
import Hledger.Read.TimedotReader (timedotfilep)
import Hledger.Utils
reader :: Reader
reader = Reader
{rFormat = "journal"
,rExtensions = ["journal", "j", "hledger", "ledger"]
,rParser = parse
,rExperimental = False
}
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse iopts = parseAndFinaliseJournal journalp' iopts
where
journalp' = do
mapM_ addAccountAlias (reverse $ aliasesFromOpts iopts)
journalp
aliasesFromOpts :: InputOpts -> [AccountAlias]
aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)
. aliases_
journalp :: MonadIO m => JournalParser m ParsedJournal
journalp = do
many addJournalItemP
eof
get
addJournalItemP :: MonadIO m => JournalParser m ()
addJournalItemP =
choice [
directivep
, transactionp >>= modify' . addTransaction
, transactionmodifierp >>= modify' . addTransactionModifier
, periodictransactionp >>= modify' . addPeriodicTransaction
, marketpricedirectivep >>= modify' . addMarketPrice
, void (lift emptyorcommentlinep)
, void (lift multilinecommentp)
] <?> "transaction or directive"
directivep :: MonadIO m => JournalParser m ()
directivep = (do
optional $ char '!'
choice [
includedirectivep
,aliasdirectivep
,endaliasesdirectivep
,accountdirectivep
,applyaccountdirectivep
,commoditydirectivep
,endapplyaccountdirectivep
,tagdirectivep
,endtagdirectivep
,defaultyeardirectivep
,defaultcommoditydirectivep
,commodityconversiondirectivep
,ignoredpricecommoditydirectivep
]
) <?> "directive"
includedirectivep :: MonadIO m => JournalParser m ()
includedirectivep = do
string "include"
lift (skipSome spacenonewline)
filename <- T.unpack <$> takeWhileP Nothing (/= '\n')
parentpos <- getPosition
filepaths <- getFilePaths parentpos filename
forM_ filepaths $ parseChild parentpos
void newline
where
getFilePaths parserpos filename = do
curdir <- lift $ expandPath (takeDirectory $ sourceName parserpos) ""
`orRethrowIOError` (show parserpos ++ " locating " ++ filename)
fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename of
Right x -> pure x
Left e -> parseErrorAt parserpos $ "Invalid glob pattern: " ++ e
filepaths <- liftIO $ sort <$> globDir1 fileglob curdir
if (not . null) filepaths
then pure filepaths
else parseErrorAt parserpos $ "No existing files match pattern: " ++ filename
parseChild parentpos filepath = do
parentfilestack <- fmap sourceName . statePos <$> getParserState
when (filepath `elem` parentfilestack)
$ parseErrorAt parentpos ("Cyclic include: " ++ filepath)
childInput <- lift $ readFilePortably filepath
`orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
parentParserState <- getParserState
parentj <- get
let childj = newJournalWithParseStateFrom parentj
setInput childInput
pushPosition $ initialPos filepath
put childj
let parsers = [ journalp
, timeclockfilep
, timedotfilep
]
updatedChildj <- journalAddFile (filepath, childInput) <$>
region (withSource childInput) (choiceInState parsers)
setParserState parentParserState
put $ updatedChildj <> parentj
newJournalWithParseStateFrom :: Journal -> Journal
newJournalWithParseStateFrom j = mempty{
jparsedefaultyear = jparsedefaultyear j
,jparsedefaultcommodity = jparsedefaultcommodity j
,jparseparentaccounts = jparseparentaccounts j
,jparsealiases = jparsealiases j
,jcommodities = jcommodities j
,jparsetimeclockentries = jparsetimeclockentries j
}
orRethrowIOError :: MonadIO m => IO a -> String -> TextParser m a
orRethrowIOError io msg = do
eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e)
case eResult of
Right res -> pure res
Left errMsg -> fail errMsg
accountdirectivep :: JournalParser m ()
accountdirectivep = do
string "account"
lift (skipSome spacenonewline)
acct <- modifiedaccountnamep
_ :: Maybe String <- (optional $ lift $ skipSome spacenonewline >> some digitChar)
newline
skipMany indentedlinep
pushDeclaredAccount acct
indentedlinep :: JournalParser m String
indentedlinep = lift (skipSome spacenonewline) >> (rstrip <$> lift restofline)
commoditydirectivep :: JournalParser m ()
commoditydirectivep = commoditydirectiveonelinep <|> commoditydirectivemultilinep
commoditydirectiveonelinep :: JournalParser m ()
commoditydirectiveonelinep = do
(pos, Amount{acommodity,astyle}) <- try $ do
string "commodity"
lift (skipSome spacenonewline)
pos <- getPosition
amount <- amountp
pure $ (pos, amount)
lift (skipMany spacenonewline)
_ <- lift followingcommentp
let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg2 "style from commodity directive" astyle}
if asdecimalpoint astyle == Nothing
then parseErrorAt pos pleaseincludedecimalpoint
else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
pleaseincludedecimalpoint :: String
pleaseincludedecimalpoint = "to avoid ambiguity, please include a decimal separator in commodity directives"
commoditydirectivemultilinep :: JournalParser m ()
commoditydirectivemultilinep = do
string "commodity"
lift (skipSome spacenonewline)
sym <- lift commoditysymbolp
_ <- lift followingcommentp
mformat <- lastMay <$> many (indented $ formatdirectivep sym)
let comm = Commodity{csymbol=sym, cformat=mformat}
modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
where
indented = (lift (skipSome spacenonewline) >>)
formatdirectivep :: CommoditySymbol -> JournalParser m AmountStyle
formatdirectivep expectedsym = do
string "format"
lift (skipSome spacenonewline)
pos <- getPosition
Amount{acommodity,astyle} <- amountp
_ <- lift followingcommentp
if acommodity==expectedsym
then
if asdecimalpoint astyle == Nothing
then parseErrorAt pos pleaseincludedecimalpoint
else return $ dbg2 "style from format subdirective" astyle
else parseErrorAt pos $
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
keywordp :: String -> JournalParser m ()
keywordp = (() <$) . string . fromString
spacesp :: JournalParser m ()
spacesp = () <$ lift (skipSome spacenonewline)
keywordsp :: String -> JournalParser m ()
keywordsp = try . sequence_ . intersperse spacesp . map keywordp . words
applyaccountdirectivep :: JournalParser m ()
applyaccountdirectivep = do
keywordsp "apply account" <?> "apply account directive"
lift (skipSome spacenonewline)
parent <- lift accountnamep
newline
pushParentAccount parent
endapplyaccountdirectivep :: JournalParser m ()
endapplyaccountdirectivep = do
keywordsp "end apply account" <?> "end apply account directive"
popParentAccount
aliasdirectivep :: JournalParser m ()
aliasdirectivep = do
string "alias"
lift (skipSome spacenonewline)
alias <- lift accountaliasp
addAccountAlias alias
accountaliasp :: TextParser m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: TextParser m AccountAlias
basicaliasp = do
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
char '='
skipMany spacenonewline
new <- rstrip <$> anyChar `manyTill` eolof
return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: TextParser m AccountAlias
regexaliasp = do
char '/'
re <- some $ noneOf ("/\n\r" :: [Char])
char '/'
skipMany spacenonewline
char '='
skipMany spacenonewline
repl <- anyChar `manyTill` eolof
return $ RegexAlias re repl
endaliasesdirectivep :: JournalParser m ()
endaliasesdirectivep = do
keywordsp "end aliases" <?> "end aliases directive"
clearAccountAliases
tagdirectivep :: JournalParser m ()
tagdirectivep = do
string "tag" <?> "tag directive"
lift (skipSome spacenonewline)
_ <- lift $ some nonspace
lift restofline
return ()
endtagdirectivep :: JournalParser m ()
endtagdirectivep = do
(keywordsp "end tag" <|> keywordp "pop") <?> "end tag or pop directive"
lift restofline
return ()
defaultyeardirectivep :: JournalParser m ()
defaultyeardirectivep = do
char 'Y' <?> "default year"
lift (skipMany spacenonewline)
y <- some digitChar
let y' = read y
failIfInvalidYear y
setYear y'
defaultcommoditydirectivep :: JournalParser m ()
defaultcommoditydirectivep = do
char 'D' <?> "default commodity"
lift (skipSome spacenonewline)
pos <- getPosition
Amount{acommodity,astyle} <- amountp
lift restofline
if asdecimalpoint astyle == Nothing
then parseErrorAt pos pleaseincludedecimalpoint
else setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: JournalParser m MarketPrice
marketpricedirectivep = do
char 'P' <?> "market price"
lift (skipMany spacenonewline)
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep
lift (skipSome spacenonewline)
symbol <- lift commoditysymbolp
lift (skipMany spacenonewline)
price <- amountp
lift restofline
return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: JournalParser m ()
ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity"
lift (skipSome spacenonewline)
lift commoditysymbolp
lift restofline
return ()
commodityconversiondirectivep :: JournalParser m ()
commodityconversiondirectivep = do
char 'C' <?> "commodity conversion"
lift (skipSome spacenonewline)
amountp
lift (skipMany spacenonewline)
char '='
lift (skipMany spacenonewline)
amountp
lift restofline
return ()
transactionmodifierp :: JournalParser m TransactionModifier
transactionmodifierp = do
char '=' <?> "modifier transaction"
lift (skipMany spacenonewline)
querytxt <- lift $ T.strip <$> descriptionp
(_comment, _tags) <- lift transactioncommentp
postings <- postingsp Nothing
return $ TransactionModifier querytxt postings
periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction
periodictransactionp = do
char '~' <?> "periodic transaction"
lift $ skipMany spacenonewline
pos <- getPosition
d <- liftIO getCurrentDay
(periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp d)
case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> parseErrorAt pos e
Nothing -> pure ()
(status, code, description, (comment, tags)) <-
(lift eolof >> return (Unmarked, "", "", ("", [])))
<|>
(do
lift $ skipSome spacenonewline
s <- lift statusp
c <- lift codep
desc <- lift $ T.strip <$> descriptionp
(cmt, ts) <- lift transactioncommentp
return (s,c,desc,(cmt,ts))
)
postings <- postingsp (Just $ first3 $ toGregorian d)
return $ nullperiodictransaction{
ptperiodexpr=periodtxt
,ptinterval=interval
,ptspan=span
,ptstatus=status
,ptcode=code
,ptdescription=description
,ptcomment=comment
,pttags=tags
,ptpostings=postings
}
transactionp :: JournalParser m Transaction
transactionp = do
startpos <- getPosition
date <- datep <?> "transaction"
edate <- optional (lift $ secondarydatep date) <?> "secondary date"
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
status <- lift statusp <?> "cleared status"
code <- lift codep <?> "transaction code"
description <- lift $ T.strip <$> descriptionp
(comment, tags) <- lift transactioncommentp
let year = first3 $ toGregorian date
postings <- postingsp (Just year)
endpos <- getPosition
let sourcepos = journalSourcePos startpos endpos
return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings ""
postingsp :: Maybe Year -> JournalParser m [Posting]
postingsp mTransactionYear = many (postingp mTransactionYear) <?> "postings"
postingp :: Maybe Year -> JournalParser m Posting
postingp mTransactionYear = do
(status, account) <- try $ do
lift (skipSome spacenonewline)
status <- lift statusp
lift (skipMany spacenonewline)
account <- modifiedaccountnamep
return (status, account)
let (ptype, account') = (accountNamePostingType account, textUnbracket account)
lift (skipMany spacenonewline)
amount <- option missingmixedamt $ Mixed . (:[]) <$> amountp
massertion <- partialbalanceassertionp
_ <- fixedlotpricep
lift (skipMany spacenonewline)
(comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear
return posting
{ pdate=mdate
, pdate2=mdate2
, pstatus=status
, paccount=account'
, pamount=amount
, pcomment=comment
, ptype=ptype
, ptags=tags
, pbalanceassertion=massertion
}
tests_JournalReader = tests "JournalReader" [
let p = lift accountnamep :: JournalParser IO AccountName in
tests "accountnamep" [
test "basic" $ expectParse p "a:b:c"
,_test "empty inner component" $ expectParseError p "a::c" ""
,_test "empty leading component" $ expectParseError p ":b:c" "x"
,_test "empty trailing component" $ expectParseError p "a:b:" "x"
]
,test "datep" $ do
test "YYYY/MM/DD" $ expectParseEq datep "2018/01/01" (fromGregorian 2018 1 1)
test "YYYY-MM-DD" $ expectParse datep "2018-01-01"
test "YYYY.MM.DD" $ expectParse datep "2018.01.01"
test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown"
test "yearless date with default year" $ do
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep "1/1"
either (fail.("parse error at "++).parseErrorPretty) (const ok) ep
test "no leading zero" $ expectParse datep "2018/1/1"
,test "datetimep" $ do
let
good = expectParse datetimep
bad = (\t -> expectParseError datetimep t "")
good "2011/1/1 00:00"
good "2011/1/1 23:59:59"
bad "2011/1/1"
bad "2011/1/1 24:00:00"
bad "2011/1/1 00:60:00"
bad "2011/1/1 00:00:60"
bad "2011/1/1 3:5:7"
test "timezone is parsed but ignored" $ do
let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 (fromIntegral 0))
expectParseEq datetimep "2018/1/1 00:00-0800" t
expectParseEq datetimep "2018/1/1 00:00+1234" t
,tests "periodictransactionp" [
test "more period text in comment after one space" $ expectParseEq periodictransactionp
"~ monthly from 2018/6 ;In 2019 we will change this\n"
nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1
,ptspan = DateSpan (Just $ fromGregorian 2018 6 1) Nothing
,ptstatus = Unmarked
,ptcode = ""
,ptdescription = ""
,ptcomment = "In 2019 we will change this\n"
,pttags = []
,ptpostings = []
}
,_test "more period text in description after two spaces" $ expectParseEq periodictransactionp
"~ monthly from 2018/6 In 2019 we will change this\n"
nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1
,ptspan = DateSpan (Just $ fromGregorian 2018 6 1) Nothing
,ptdescription = "In 2019 we will change this\n"
}
,_test "more period text in description after one space" $ expectParseEq periodictransactionp
"~ monthly from 2018/6 In 2019 we will change this\n"
nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6"
,ptinterval = Months 1
,ptspan = DateSpan (Just $ fromGregorian 2018 6 1) Nothing
,ptdescription = "In 2019 we will change this\n"
}
,_test "Next year in description" $ expectParseEq periodictransactionp
"~ monthly Next year blah blah\n"
nullperiodictransaction {
ptperiodexpr = "monthly"
,ptinterval = Months 1
,ptspan = DateSpan Nothing Nothing
,ptdescription = "Next year blah blah\n"
}
]
,tests "postingp" [
test "basic" $ expectParseEq (postingp Nothing)
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
posting{
paccount="expenses:food:dining",
pamount=Mixed [usd 10],
pcomment="a: a a\nb: b b\n",
ptags=[("a","a a"), ("b","b b")]
}
,test "posting dates" $ expectParseEq (postingp Nothing)
" a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n"
nullposting{
paccount="a"
,pamount=Mixed [num 1]
,pcomment="date:2012/11/28, date2=2012/11/29,b:b\n"
,ptags=[("date", "2012/11/28"), ("date2=2012/11/29,b", "b")]
,pdate=Just $ fromGregorian 2012 11 28
,pdate2=Nothing
}
,test "posting dates bracket syntax" $ expectParseEq (postingp Nothing)
" a 1. ; [2012/11/28=2012/11/29]\n"
nullposting{
paccount="a"
,pamount=Mixed [num 1]
,pcomment="[2012/11/28=2012/11/29]\n"
,ptags=[]
,pdate= Just $ fromGregorian 2012 11 28
,pdate2=Just $ fromGregorian 2012 11 29
}
,test "quoted commodity symbol with digits" $ expectParse (postingp Nothing) " a 1 \"DE123\"\n"
,test "balance assertion and fixed lot price" $ expectParse (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n"
]
,tests "transactionmodifierp" [
test "basic" $ expectParseEq transactionmodifierp
"= (some value expr)\n some:postings 1.\n"
nulltransactionmodifier {
tmquerytxt = "(some value expr)"
,tmpostings = [nullposting{paccount="some:postings", pamount=Mixed[num 1]}]
}
]
,tests "transactionp" [
test "just a date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}
,test "more complex" $ expectParseEq transactionp
(T.unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
" ; ttag1: val1",
" * a $1.00 ; pcomment1",
" ; pcomment2",
" ; ptag1: val1",
" ; ptag2: val2"
])
nulltransaction{
tsourcepos=JournalSourcePos "" (1,7),
tpreceding_comment_lines="",
tdate=fromGregorian 2012 5 14,
tdate2=Just $ fromGregorian 2012 5 15,
tstatus=Unmarked,
tcode="code",
tdescription="desc",
tcomment="tcomment1\ntcomment2\nttag1: val1\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pdate=Nothing,
pstatus=Cleared,
paccount="a",
pamount=Mixed [usd 1],
pcomment="pcomment1\npcomment2\nptag1: val1\nptag2: val2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")],
ptransaction=Nothing
}
]
}
,test "parses a well-formed transaction" $
expect $ isRight $ rjp transactionp $ T.unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
,test "does not parse a following comment as part of the description" $
expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"
,test "transactionp parses a following whitespace line" $
expect $ isRight $ rjp transactionp $ T.unlines
["2012/1/1"
," a 1"
," b"
," "
]
,test "comments everywhere, two postings parsed" $
expectParseEqOn transactionp
(T.unlines
["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment"
," ; posting 1 comment 2"
," b"
," ; posting 2 comment"
])
(length . tpostings)
2
]
,tests "directivep" [
test "supports !" $ do
expectParse directivep "!account a\n"
expectParse directivep "!D 1.0\n"
]
,test "accountdirectivep" $ do
test "account" $ expectParse accountdirectivep "account a:b\n"
test "does not support !" $ expectParseError accountdirectivep "!account a:b\n" ""
,test "commodityconversiondirectivep" $ do
expectParse commodityconversiondirectivep "C 1h = $50.00\n"
,test "defaultcommoditydirectivep" $ do
expectParse defaultcommoditydirectivep "D $1,000.0\n"
expectParseError defaultcommoditydirectivep "D $1000\n" "please include a decimal separator"
,test "defaultyeardirectivep" $ do
test "1000" $ expectParse defaultyeardirectivep "Y 1000"
test "999" $ expectParseError defaultyeardirectivep "Y 999" "bad year number"
test "12345" $ expectParse defaultyeardirectivep "Y 12345"
,test "ignoredpricecommoditydirectivep" $ do
expectParse ignoredpricecommoditydirectivep "N $\n"
,test "includedirectivep" $ do
test "include" $ expectParseError includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"
test "glob" $ expectParseError includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*"
,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep
"P 2017/01/30 BTC $922.83\n"
MarketPrice{
mpdate = fromGregorian 2017 1 30,
mpcommodity = "BTC",
mpamount = usd 922.83
}
,test "tagdirectivep" $ do
expectParse tagdirectivep "tag foo \n"
,test "endtagdirectivep" $ do
expectParse endtagdirectivep "end tag \n"
expectParse endtagdirectivep "pop \n"
,tests "journalp" [
test "empty file" $ expectParseEq journalp "" nulljournal
]
]