module Hledger.Read.JournalReader (
tests_JournalReader,
reader,
journalFile,
journalAddFile,
someamount,
ledgeraccountname,
ledgerExclamationDirective,
ledgerHistoricalPrice,
ledgerDefaultYear,
emptyLine,
ledgerdatetime,
)
where
import Control.Monad.Error (ErrorT(..), throwError, catchError)
import Data.List.Split (wordsBy)
import Text.ParserCombinators.Parsec hiding (parse)
#if __GLASGOW_HASKELL__ <= 610
import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
import System.IO.UTF8
#endif
import Hledger.Data
import Hledger.Read.Utils
reader :: Reader
reader = Reader format detect parse
format :: String
format = "journal"
detect :: FilePath -> String -> Bool
detect f _ = fileSuffix f == format
parse :: FilePath -> String -> ErrorT String IO Journal
parse = parseJournalWith journalFile
journalFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)
journalFile = do
journalupdates <- many journalItem
eof
finalctx <- getState
return $ (juSequence journalupdates, finalctx)
where
journalItem = choice [ ledgerExclamationDirective
, liftM (return . addTransaction) ledgerTransaction
, liftM (return . addModifierTransaction) ledgerModifierTransaction
, liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
, liftM (return . addHistoricalPrice) ledgerHistoricalPrice
, ledgerDefaultYear
, ledgerDefaultCommodity
, ledgerCommodityConversion
, ledgerIgnoredPriceCommodity
, ledgerTagDirective
, ledgerEndTagDirective
, emptyLine >> return (return id)
] <?> "journal transaction or directive"
journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
emptyLine :: GenParser Char JournalContext ()
emptyLine = do many spacenonewline
optional $ (char ';' <?> "comment") >> many (noneOf "\n")
newline
return ()
ledgercomment :: GenParser Char JournalContext String
ledgercomment = do
many1 $ char ';'
many spacenonewline
many (noneOf "\n")
<?> "comment"
ledgercommentline :: GenParser Char JournalContext String
ledgercommentline = do
many spacenonewline
s <- ledgercomment
optional newline
eof
return s
<?> "comment"
ledgerExclamationDirective :: GenParser Char JournalContext JournalUpdate
ledgerExclamationDirective = do
char '!' <?> "directive"
directive <- many nonspace
case directive of
"include" -> ledgerInclude
"account" -> ledgerAccountBegin
"end" -> ledgerAccountEnd
_ -> mzero
ledgerInclude :: GenParser Char JournalContext JournalUpdate
ledgerInclude = do
many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
return $ do filepath <- expandPath outerPos filename
txt <- readFileOrError outerPos filepath
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
case runParser journalFile outerState filepath txt of
Right (ju,_) -> juSequence [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))
Left err -> throwError $ inIncluded ++ show err
where readFileOrError pos fp =
ErrorT $ liftM Right (readFile fp) `catch`
\err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err)
ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate
ledgerAccountBegin = do many1 spacenonewline
parent <- ledgeraccountname
newline
pushParentAccount parent
return $ return id
ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate
ledgerAccountEnd = popParentAccount >> return (return id)
ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction
ledgerModifierTransaction = do
char '=' <?> "modifier transaction"
many spacenonewline
valueexpr <- restofline
postings <- ledgerpostings
return $ ModifierTransaction valueexpr postings
ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction
ledgerPeriodicTransaction = do
char '~' <?> "periodic transaction"
many spacenonewline
periodexpr <- restofline
postings <- ledgerpostings
return $ PeriodicTransaction periodexpr postings
ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice
ledgerHistoricalPrice = do
char 'P' <?> "historical price"
many spacenonewline
date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate
many1 spacenonewline
symbol <- commoditysymbol
many spacenonewline
price <- someamount
restofline
return $ HistoricalPrice date symbol price
ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate
ledgerIgnoredPriceCommodity = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
commoditysymbol
restofline
return $ return id
ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate
ledgerCommodityConversion = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
someamount
many spacenonewline
char '='
many spacenonewline
someamount
restofline
return $ return id
ledgerTagDirective :: GenParser Char JournalContext JournalUpdate
ledgerTagDirective = do
string "tag" <?> "tag directive"
many1 spacenonewline
_ <- many1 nonspace
restofline
return $ return id
ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate
ledgerEndTagDirective = do
string "end tag" <?> "end tag directive"
restofline
return $ return id
ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate
ledgerDefaultYear = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
let y' = read y
failIfInvalidYear y
setYear y'
return $ return id
ledgerDefaultCommodity :: GenParser Char JournalContext JournalUpdate
ledgerDefaultCommodity = do
char 'D' <?> "default commodity"
many1 spacenonewline
a <- someamount
let as = amounts a
when (not $ null as) $ setCommodity $ commodity $ head as
restofline
return $ return id
ledgerTransaction :: GenParser Char JournalContext Transaction
ledgerTransaction = do
date <- ledgerdate <?> "transaction"
edate <- optionMaybe (ledgereffectivedate date) <?> "effective date"
status <- ledgerstatus <?> "cleared flag"
code <- ledgercode <?> "transaction code"
(description, comment) <-
(do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|>
do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)}
) <?> "description and/or comment"
md <- try ledgermetadata <|> return []
postings <- ledgerpostings
let t = txnTieKnot $ Transaction date edate status code description comment md postings ""
return t
ledgerdate :: GenParser Char JournalContext Day
ledgerdate = do
datestr <- many1 $ choice' [digit, datesepchar]
let dateparts = wordsBy (`elem` datesepchars) datestr
case dateparts of
[y,m,d] -> do
failIfInvalidYear y
failIfInvalidMonth m
failIfInvalidDay d
return $ fromGregorian (read y) (read m) (read d)
[m,d] -> do
y <- getYear
case y of Nothing -> fail "partial date found, but no default year specified"
Just y' -> do failIfInvalidYear $ show y'
failIfInvalidMonth m
failIfInvalidDay d
return $ fromGregorian y' (read m) (read d)
_ -> fail $ "bad date: " ++ datestr
<?> "full or partial date"
ledgerdatetime :: GenParser Char JournalContext LocalTime
ledgerdatetime = do
day <- ledgerdate
many1 spacenonewline
h <- many1 digit
char ':'
m <- many1 digit
s <- optionMaybe $ do
char ':'
many1 digit
let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)
return $ LocalTime day tod
ledgereffectivedate :: Day -> GenParser Char JournalContext Day
ledgereffectivedate actualdate = do
char '='
let withDefaultYear d p = do
y <- getYear
let (y',_,_) = toGregorian d in setYear y'
r <- p
when (isJust y) $ setYear $ fromJust y
return r
edate <- withDefaultYear actualdate ledgerdate
return edate
ledgerstatus :: GenParser Char JournalContext Bool
ledgerstatus = try (do { many spacenonewline; char '*' <?> "status"; return True } ) <|> return False
ledgercode :: GenParser Char JournalContext String
ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
ledgermetadata :: GenParser Char JournalContext [(String,String)]
ledgermetadata = many ledgermetadataline
ledgermetadataline :: GenParser Char JournalContext (String,String)
ledgermetadataline = do
many1 spacenonewline
many1 $ char ';'
many spacenonewline
name <- many1 $ noneOf ": \t"
char ':'
many spacenonewline
value <- many (noneOf "\n")
optional newline
return (name,value)
<?> "metadata line"
ledgerpostings :: GenParser Char JournalContext [Posting]
ledgerpostings = do
ctx <- getState
pos <- getPosition
ls <- many1 $ try linebeginningwithspaces
let parses p = isRight . parseWithCtx ctx p
postinglines = filter (not . (ledgercommentline `parses`)) ls
postinglinegroups :: [String] -> [String]
postinglinegroups [] = []
postinglinegroups (pline:ls) = (unlines $ pline:mdlines):postinglinegroups rest
where (mdlines,rest) = span (ledgermetadataline `parses`) ls
pstrs = postinglinegroups postinglines
when (null pstrs) $ fail "no postings"
return $ map (fromparse . parseWithCtx ctx (setPosition pos >> ledgerposting)) pstrs
<?> "postings"
linebeginningwithspaces :: GenParser Char JournalContext String
linebeginningwithspaces = do
sp <- many1 spacenonewline
c <- nonspace
cs <- restofline
return $ sp ++ (c:cs) ++ "\n"
ledgerposting :: GenParser Char JournalContext Posting
ledgerposting = do
many1 spacenonewline
status <- ledgerstatus
many spacenonewline
account <- transactionaccountname
let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
amount <- postingamount
many spacenonewline
comment <- ledgercomment <|> return ""
newline
md <- ledgermetadata
return (Posting status account' amount comment ptype md Nothing)
transactionaccountname :: GenParser Char JournalContext AccountName
transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
ledgeraccountname :: GenParser Char st AccountName
ledgeraccountname = do
a <- many1 (nonspace <|> singlespace)
let a' = striptrailingspace a
when (accountNameFromComponents (accountNameComponents a') /= a')
(fail $ "accountname seems ill-formed: "++a')
return a'
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
striptrailingspace s = if last s == ' ' then init s else s
postingamount :: GenParser Char JournalContext MixedAmount
postingamount =
try (do
many1 spacenonewline
someamount <|> return missingamt
) <|> return missingamt
someamount :: GenParser Char JournalContext MixedAmount
someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
leftsymbolamount :: GenParser Char JournalContext MixedAmount
leftsymbolamount = do
sign <- optionMaybe $ string "-"
let applysign = if isJust sign then negate else id
sym <- commoditysymbol
sp <- many spacenonewline
(q,p,comma) <- amountquantity
pri <- priceamount
let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p}
return $ applysign $ Mixed [Amount c q pri]
<?> "left-symbol amount"
rightsymbolamount :: GenParser Char JournalContext MixedAmount
rightsymbolamount = do
(q,p,comma) <- amountquantity
sp <- many spacenonewline
sym <- commoditysymbol
pri <- priceamount
let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p}
return $ Mixed [Amount c q pri]
<?> "right-symbol amount"
nosymbolamount :: GenParser Char JournalContext MixedAmount
nosymbolamount = do
(q,p,comma) <- amountquantity
pri <- priceamount
defc <- getCommodity
let c = fromMaybe Commodity{symbol="",side=L,spaced=False,comma=comma,precision=p} defc
return $ Mixed [Amount c q pri]
<?> "no-symbol amount"
commoditysymbol :: GenParser Char JournalContext String
commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol"
quotedcommoditysymbol :: GenParser Char JournalContext String
quotedcommoditysymbol = do
char '"'
s <- many1 $ noneOf ";\n\""
char '"'
return s
simplecommoditysymbol :: GenParser Char JournalContext String
simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars)
priceamount :: GenParser Char JournalContext (Maybe MixedAmount)
priceamount =
try (do
many spacenonewline
char '@'
many spacenonewline
a <- someamount
return $ Just a
) <|> return Nothing
amountquantity :: GenParser Char JournalContext (Double, Int, Bool)
amountquantity = do
sign <- optionMaybe $ string "-"
(intwithcommas,frac) <- numberparts
let comma = ',' `elem` intwithcommas
let precision = length frac
let int = filter (/= ',') intwithcommas
let int' = if null int then "0" else int
let frac' = if null frac then "0" else frac
let sign' = fromMaybe "" sign
let quantity = read $ sign'++int'++"."++frac'
return (quantity, precision, comma)
<?> "commodity quantity"
numberparts :: GenParser Char JournalContext (String,String)
numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint
numberpartsstartingwithdigit :: GenParser Char JournalContext (String,String)
numberpartsstartingwithdigit = do
let digitorcomma = digit <|> char ','
first <- digit
rest <- many digitorcomma
frac <- try (do {char '.'; many digit}) <|> return ""
return (first:rest,frac)
numberpartsstartingwithpoint :: GenParser Char JournalContext (String,String)
numberpartsstartingwithpoint = do
char '.'
frac <- many1 digit
return ("",frac)
tests_JournalReader = TestList [
"ledgerTransaction" ~: do
assertParseEqual (parseWithCtx nullctx ledgerTransaction entry1_str) entry1
assertBool "ledgerTransaction should not parse just a date"
$ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1\n"
assertBool "ledgerTransaction should require some postings"
$ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1 a\n"
let t = parseWithCtx nullctx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"
assertBool "ledgerTransaction should not include a comment in the description"
$ either (const False) ((== "a") . tdescription) t
,"ledgerModifierTransaction" ~: do
assertParse (parseWithCtx nullctx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n")
,"ledgerPeriodicTransaction" ~: do
assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n")
,"ledgerExclamationDirective" ~: do
assertParse (parseWithCtx nullctx ledgerExclamationDirective "!include /some/file.x\n")
assertParse (parseWithCtx nullctx ledgerExclamationDirective "!account some:account\n")
assertParse (parseWithCtx nullctx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n")
,"ledgercommentline" ~: do
assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n")
assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n")
assertParse (parseWithCtx nullctx ledgercommentline ";x")
,"ledgerDefaultYear" ~: do
assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n")
assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n")
,"ledgerHistoricalPrice" ~:
assertParseEqual (parseWithCtx nullctx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55])
,"ledgerIgnoredPriceCommodity" ~: do
assertParse (parseWithCtx nullctx ledgerIgnoredPriceCommodity "N $\n")
,"ledgerDefaultCommodity" ~: do
assertParse (parseWithCtx nullctx ledgerDefaultCommodity "D $1,000.0\n")
,"ledgerCommodityConversion" ~: do
assertParse (parseWithCtx nullctx ledgerCommodityConversion "C 1h = $50.00\n")
,"ledgerTagDirective" ~: do
assertParse (parseWithCtx nullctx ledgerTagDirective "tag foo \n")
,"ledgerEndTagDirective" ~: do
assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n")
,"ledgeraccountname" ~: do
assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")
assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")
assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")
assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")
,"ledgerposting" ~: do
assertParseEqual (parseWithCtx nullctx ledgerposting " expenses:food:dining $10.00\n")
(Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [] Nothing)
assertBool "ledgerposting parses a quoted commodity with numbers"
(isRight $ parseWithCtx nullctx ledgerposting " a 1 \"DE123\"\n")
,"someamount" ~: do
let
assertMixedAmountParse parseresult mixedamount =
(either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
assertMixedAmountParse (parseWithCtx nullctx someamount "1 @ $2")
(Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])])
,"postingamount" ~: do
assertParseEqual (parseWithCtx nullctx postingamount " $47.18") (Mixed [dollars 47.18])
assertParseEqual (parseWithCtx nullctx postingamount " $1.")
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
,"leftsymbolamount" ~: do
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])
assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1")
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (1) Nothing])
assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")
(Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (1) Nothing])
]
entry1_str = unlines
["2007/01/28 coopportunity"
," expenses:food:groceries $47.18"
," assets:checking $-47.18"
,""
]
entry1 =
txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting [] Nothing,
Posting False "assets:checking" (Mixed [dollars (47.18)]) "" RegularPosting [] Nothing] ""