module Hledger.Data.Parse
where
import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError)
import Text.ParserCombinators.Parsec
import System.Directory
#if __GLASGOW_HASKELL__ <= 610
import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
import System.IO.UTF8
#endif
import Hledger.Data.Utils
import Hledger.Data.Types
import Hledger.Data.Dates
import Hledger.Data.AccountName (accountNameFromComponents,accountNameComponents)
import Hledger.Data.Amount
import Hledger.Data.Transaction
import Hledger.Data.Posting
import Hledger.Data.Journal
import Hledger.Data.Commodity (dollars,dollar,unknown)
import System.FilePath(takeDirectory,combine)
import System.Time (getClockTime)
type JournalUpdate = ErrorT String IO (Journal -> Journal)
data LedgerFileCtx = Ctx {
ctxYear :: !(Maybe Integer)
, ctxCommod :: !(Maybe String)
, ctxAccount :: ![String]
} deriving (Read, Show)
emptyCtx :: LedgerFileCtx
emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
setYear :: Integer -> GenParser tok LedgerFileCtx ()
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
getYear = liftM ctxYear getState
pushParentAccount :: String -> GenParser tok LedgerFileCtx ()
pushParentAccount parent = updateState addParentAccount
where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }
normalize = (++ ":")
popParentAccount :: GenParser tok LedgerFileCtx ()
popParentAccount = do ctx0 <- getState
case ctxAccount ctx0 of
[] -> unexpected "End of account block with no beginning"
(_:rest) -> setState $ ctx0 { ctxAccount = rest }
getParentAccount :: GenParser tok LedgerFileCtx String
getParentAccount = liftM (concat . reverse . ctxAccount) getState
expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath
expandPath pos fp = liftM mkRelative (expandHome fp)
where
mkRelative = combine (takeDirectory (sourceName pos))
expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
return $ homedir ++ drop 1 inname
| otherwise = return inname
parseJournalFile :: FilePath -> ErrorT String IO Journal
parseJournalFile "-" = liftIO getContents >>= parseJournal "-"
parseJournalFile f = liftIO (readFile f) >>= parseJournal f
parseJournal :: FilePath -> String -> ErrorT String IO Journal
parseJournal f s = do
tc <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime
case runParser ledgerFile emptyCtx f s of
Right m -> liftM (journalFinalise tc tl f s) $ m `ap` return nulljournal
Left err -> throwError $ show err
ledgerFile :: GenParser Char LedgerFileCtx JournalUpdate
ledgerFile = do items <- many ledgerItem
eof
return $ liftM (foldr (.) id) $ sequence items
where
ledgerItem = choice [ ledgerExclamationDirective
, liftM (return . addTransaction) ledgerTransaction
, liftM (return . addModifierTransaction) ledgerModifierTransaction
, liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
, liftM (return . addHistoricalPrice) ledgerHistoricalPrice
, ledgerDefaultYear
, ledgerIgnoredPriceCommodity
, ledgerTagDirective
, ledgerEndTagDirective
, emptyLine >> return (return id)
, liftM (return . addTimeLogEntry) timelogentry
] <?> "ledger transaction, timelog entry, or directive"
emptyLine :: GenParser Char st ()
emptyLine = do many spacenonewline
optional $ (char ';' <?> "comment") >> many (noneOf "\n")
newline
return ()
ledgercomment :: GenParser Char st String
ledgercomment = do
many1 $ char ';'
many spacenonewline
many (noneOf "\n")
<?> "comment"
ledgercommentline :: GenParser Char st String
ledgercommentline = do
many spacenonewline
s <- ledgercomment
optional newline
eof
return s
<?> "comment"
ledgerExclamationDirective :: GenParser Char LedgerFileCtx JournalUpdate
ledgerExclamationDirective = do
char '!' <?> "directive"
directive <- many nonspace
case directive of
"include" -> ledgerInclude
"account" -> ledgerAccountBegin
"end" -> ledgerAccountEnd
_ -> mzero
ledgerInclude :: GenParser Char LedgerFileCtx JournalUpdate
ledgerInclude = do many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
return $ do contents <- expandPath outerPos filename >>= readFileE outerPos
case runParser ledgerFile outerState filename contents of
Right l -> l `catchError` (throwError . (inIncluded ++))
Left perr -> throwError $ inIncluded ++ show perr
where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError
where leftError err = return $ Left $ currentPos ++ whileReading ++ show err
currentPos = show outerPos
whileReading = " reading " ++ show filename ++ ":\n"
ledgerAccountBegin :: GenParser Char LedgerFileCtx JournalUpdate
ledgerAccountBegin = do many1 spacenonewline
parent <- ledgeraccountname
newline
pushParentAccount parent
return $ return id
ledgerAccountEnd :: GenParser Char LedgerFileCtx JournalUpdate
ledgerAccountEnd = popParentAccount >> return (return id)
ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction
ledgerModifierTransaction = do
char '=' <?> "modifier transaction"
many spacenonewline
valueexpr <- restofline
postings <- ledgerpostings
return $ ModifierTransaction valueexpr postings
ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction
ledgerPeriodicTransaction = do
char '~' <?> "periodic transaction"
many spacenonewline
periodexpr <- restofline
postings <- ledgerpostings
return $ PeriodicTransaction periodexpr postings
ledgerHistoricalPrice :: GenParser Char LedgerFileCtx 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 LedgerFileCtx JournalUpdate
ledgerIgnoredPriceCommodity = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
commoditysymbol
restofline
return $ return id
ledgerDefaultCommodity :: GenParser Char LedgerFileCtx JournalUpdate
ledgerDefaultCommodity = do
char 'D' <?> "default commodity"
many1 spacenonewline
someamount
restofline
return $ return id
ledgerCommodityConversion :: GenParser Char LedgerFileCtx JournalUpdate
ledgerCommodityConversion = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
someamount
many spacenonewline
char '='
many spacenonewline
someamount
restofline
return $ return id
ledgerTagDirective :: GenParser Char LedgerFileCtx JournalUpdate
ledgerTagDirective = do
string "tag" <?> "tag directive"
many1 spacenonewline
_ <- many1 nonspace
restofline
return $ return id
ledgerEndTagDirective :: GenParser Char LedgerFileCtx JournalUpdate
ledgerEndTagDirective = do
string "end tag" <?> "end tag directive"
restofline
return $ return id
ledgerDefaultYear :: GenParser Char LedgerFileCtx JournalUpdate
ledgerDefaultYear = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
let y' = read y
failIfInvalidYear y
setYear y'
return $ return id
ledgerTransaction :: GenParser Char LedgerFileCtx 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"
postings <- ledgerpostings
let t = txnTieKnot $ Transaction date edate status code description comment postings ""
case balanceTransaction t of
Right t' -> return t'
Left err -> fail err
ledgerdate :: GenParser Char LedgerFileCtx Day
ledgerdate = choice' [ledgerfulldate, ledgerpartialdate] <?> "full or partial date"
ledgerfulldate :: GenParser Char LedgerFileCtx Day
ledgerfulldate = do
(y,m,d) <- ymd
return $ fromGregorian (read y) (read m) (read d)
ledgerpartialdate :: GenParser Char LedgerFileCtx Day
ledgerpartialdate = do
(_,m,d) <- md
y <- getYear
when (isNothing y) $ fail "partial date found, but no default year specified"
return $ fromGregorian (fromJust y) (read m) (read d)
ledgerdatetime :: GenParser Char LedgerFileCtx 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 LedgerFileCtx 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 st Bool
ledgerstatus = try (do { many1 spacenonewline; char '*' <?> "status"; return True } ) <|> return False
ledgercode :: GenParser Char st String
ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
ledgerpostings = do
ctx <- getState
let parses p = isRight . parseWithCtx ctx p
ls <- many1 $ try linebeginningwithspaces
let ls' = filter (not . (ledgercommentline `parses`)) ls
when (null ls') $ fail "no postings"
return $ map (fromparse . parseWithCtx ctx ledgerposting) ls'
<?> "postings"
linebeginningwithspaces :: GenParser Char st String
linebeginningwithspaces = do
sp <- many1 spacenonewline
c <- nonspace
cs <- restofline
return $ sp ++ (c:cs) ++ "\n"
ledgerposting :: GenParser Char LedgerFileCtx Posting
ledgerposting = do
many1 spacenonewline
status <- ledgerstatus
account <- transactionaccountname
let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
amount <- postingamount
many spacenonewline
comment <- ledgercomment <|> return ""
newline
return (Posting status account' amount comment ptype Nothing)
transactionaccountname :: GenParser Char LedgerFileCtx 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 st MixedAmount
postingamount =
try (do
many1 spacenonewline
someamount <|> return missingamt
) <|> return missingamt
someamount :: GenParser Char st MixedAmount
someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
leftsymbolamount :: GenParser Char st MixedAmount
leftsymbolamount = do
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 $ Mixed [Amount c q pri]
<?> "left-symbol amount"
rightsymbolamount :: GenParser Char st 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 st MixedAmount
nosymbolamount = do
(q,p,comma) <- amountquantity
pri <- priceamount
let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p}
return $ Mixed [Amount c q pri]
<?> "no-symbol amount"
commoditysymbol :: GenParser Char st String
commoditysymbol = (quotedcommoditysymbol <|>
many1 (noneOf "0123456789-.@;\n \"")
) <?> "commodity symbol"
quotedcommoditysymbol :: GenParser Char st String
quotedcommoditysymbol = do
char '"'
s <- many1 $ noneOf "-.@;\n \""
char '"'
return s
priceamount :: GenParser Char st (Maybe MixedAmount)
priceamount =
try (do
many spacenonewline
char '@'
many spacenonewline
a <- someamount
return $ Just a
) <|> return Nothing
amountquantity :: GenParser Char st (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 st (String,String)
numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint
numberpartsstartingwithdigit :: GenParser Char st (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 st (String,String)
numberpartsstartingwithpoint = do
char '.'
frac <- many1 digit
return ("",frac)
timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
timelogentry = do
code <- oneOf "bhioO"
many1 spacenonewline
datetime <- ledgerdatetime
comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)
return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)
datedisplayexpr :: GenParser Char st (Posting -> Bool)
datedisplayexpr = do
char 'd'
op <- compareop
char '['
(y,m,d) <- smartdate
char ']'
let date = parsedate $ printf "%04s/%02s/%02s" y m d
test op = return $ (`op` date) . postingDate
case op of
"<" -> test (<)
"<=" -> test (<=)
"=" -> test (==)
"==" -> test (==)
">=" -> test (>=)
">" -> test (>)
_ -> mzero
compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
tests_Parse = TestList [
"ledgerTransaction" ~: do
assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1
assertBool "ledgerTransaction should not parse just a date"
$ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n"
assertBool "ledgerTransaction should require some postings"
$ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n"
let t = parseWithCtx emptyCtx 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 emptyCtx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n")
,"ledgerPeriodicTransaction" ~: do
assertParse (parseWithCtx emptyCtx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n")
,"ledgerExclamationDirective" ~: do
assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!include /some/file.x\n")
assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!account some:account\n")
assertParse (parseWithCtx emptyCtx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n")
,"ledgercommentline" ~: do
assertParse (parseWithCtx emptyCtx ledgercommentline "; some comment \n")
assertParse (parseWithCtx emptyCtx ledgercommentline " \t; x\n")
assertParse (parseWithCtx emptyCtx ledgercommentline ";x")
,"ledgerDefaultYear" ~: do
assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 2010\n")
assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 10001\n")
,"ledgerHistoricalPrice" ~:
assertParseEqual (parseWithCtx emptyCtx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55])
,"ledgerIgnoredPriceCommodity" ~: do
assertParse (parseWithCtx emptyCtx ledgerIgnoredPriceCommodity "N $\n")
,"ledgerDefaultCommodity" ~: do
assertParse (parseWithCtx emptyCtx ledgerDefaultCommodity "D $1,000.0\n")
,"ledgerCommodityConversion" ~: do
assertParse (parseWithCtx emptyCtx ledgerCommodityConversion "C 1h = $50.00\n")
,"ledgerTagDirective" ~: do
assertParse (parseWithCtx emptyCtx ledgerTagDirective "tag foo \n")
,"ledgerEndTagDirective" ~: do
assertParse (parseWithCtx emptyCtx 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 emptyCtx 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 emptyCtx ledgerposting " a 1 \"DE123\"\n")
,"someamount" ~: do
let
assertMixedAmountParse parseresult mixedamount =
(either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
assertMixedAmountParse (parsewith someamount "1 @ $2")
(Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])])
,"postingamount" ~: do
assertParseEqual (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18])
assertParseEqual (parseWithCtx emptyCtx postingamount " $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] ""