{-# 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_Hledger_Read_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 Test.HUnit
#ifdef TESTS
import Test.Framework
import Text.Megaparsec.Error
#endif
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Text.Megaparsec.Custom
import Text.Printf
import System.FilePath
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
, modifiertransactionp >>= modify' . addModifierTransaction
, 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')
parentParserState <- getParserState
parentj <- get
let childj = newJournalWithParseStateFrom parentj
parentpos <- getPosition
let curdir = takeDirectory (sourceName parentpos)
filepath <- lift $ expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
childInput <- lift $ readFilePortably filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
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
void newline
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
macode' :: Maybe String <- (optional $ lift $ skipSome spacenonewline >> some digitChar)
let macode :: Maybe AccountCode = read <$> macode'
newline
skipMany indentedlinep
modify' (\j -> j{jaccounts = (acct, macode) : jaccounts j})
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 point 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 ()
modifiertransactionp :: JournalParser m ModifierTransaction
modifiertransactionp = do
char '=' <?> "modifier transaction"
lift (skipMany spacenonewline)
valueexpr <- T.pack <$> lift restofline
postings <- postingsp Nothing
return $ ModifierTransaction valueexpr 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 ""
#ifdef TESTS
test_transactionp = do
let s `gives` t = do
let p = parseWithState mempty transactionp s
assertBool $ isRight p
let Right t2 = p
assertEqual (tdate t) (tdate t2)
assertEqual (tdate2 t) (tdate2 t2)
assertEqual (tstatus t) (tstatus t2)
assertEqual (tcode t) (tcode t2)
assertEqual (tdescription t) (tdescription t2)
assertEqual (tcomment t) (tcomment t2)
assertEqual (ttags t) (ttags t2)
assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2)
assertEqual (show $ tpostings t) (show $ tpostings t2)
unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2",
" ; ttag1: val1",
" * a $1.00 ; pcomment1",
" ; pcomment2",
" ; ptag1: val1",
" ; ptag2: val2"
]
`gives`
nulltransaction{
tdate=parsedate "2012/05/14",
tdate2=Just $ parsedate "2012/05/15",
tstatus=Unmarked,
tcode="code",
tdescription="desc",
tcomment=" tcomment1\n tcomment2\n ttag1: val1\n",
ttags=[("ttag1","val1")],
tpostings=[
nullposting{
pstatus=Cleared,
paccount="a",
pamount=Mixed [usd 1],
pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n",
ptype=RegularPosting,
ptags=[("ptag1","val1"),("ptag2","val2")],
ptransaction=Nothing
}
],
tpreceding_comment_lines=""
}
unlines [
"2015/1/1",
]
`gives`
nulltransaction{
tdate=parsedate "2015/01/01",
}
assertRight $ parseWithState mempty transactionp $ unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
assertLeft $ parseWithState mempty transactionp "2009/1/1\n"
assertLeft $ parseWithState mempty transactionp "2009/1/1 a\n"
let p = parseWithState mempty transactionp "2009/1/1 a ;comment\n b 1\n"
assertRight p
assertEqual "a" (let Right p' = p in tdescription p')
assertRight $ parseWithState mempty transactionp $ unlines
["2012/1/1"
," a 1"
," b"
," "
]
let p = parseWithState mempty transactionp $ unlines
["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment"
," ; posting 1 comment 2"
," b"
," ; posting 2 comment"
]
assertRight p
assertEqual 2 (let Right t = p in length $ tpostings t)
#endif
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
}
#ifdef TESTS
test_postingp = do
let s `gives` ep = do
let parse = parseWithState mempty (postingp Nothing) s
assertBool
$ isRight parse
let Right ap = parse
same f = assertEqual (f ep) (f ap)
same pdate
same pstatus
same paccount
same pamount
same pcomment
same ptype
same ptags
same ptransaction
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" `gives`
posting{paccount="expenses:food:dining", pamount=Mixed [usd 10], pcomment=" a: a a \n b: b b \n", ptags=[("a","a a"), ("b","b b")]}
" a 1 ; [2012/11/28]\n" `gives`
("a" `post` num 1){pcomment=" [2012/11/28]\n"
,ptags=[("date","2012/11/28")]
,pdate=parsedateM "2012/11/28"}
" a 1 ; a:a, [=2012/11/28]\n" `gives`
("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n"
,ptags=[("a","a"), ("date2","2012/11/28")]
,pdate=Nothing}
" a 1 ; a:a\n ; [2012/11/28=2012/11/29],b:b\n" `gives`
("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n"
,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")]
,pdate=parsedateM "2012/11/28"}
assertBool
(isRight $ parseWithState mempty (postingp Nothing) " a 1 \"DE123\"\n")
assertBool (isRight $ parseWithState mempty (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n")
#endif
tests_Hledger_Read_JournalReader = TestList $ concat [
[
"showParsedMarketPrice" ~: do
let mp = parseWithState mempty marketpricedirectivep "P 2017/01/30 BTC $922.83\n"
mpString = (fmap . fmap) showMarketPrice mp
mpString `is` (Just (Right "P 2017/01/30 BTC $922.83"))
]
]