module Ledger.Parse
where
import Control.Monad
import Control.Monad.Error
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Char
import Text.ParserCombinators.Parsec.Language
import Text.ParserCombinators.Parsec.Combinator
import qualified Text.ParserCombinators.Parsec.Token as P
import System.Directory
import System.IO
import qualified Data.Map as Map
import Ledger.Utils
import Ledger.Types
import Ledger.Dates
import Ledger.Amount
import Ledger.Entry
import Ledger.Commodity
import Ledger.TimeLog
import Ledger.RawLedger
import Data.Time.LocalTime
import Data.Time.Calendar
parseLedgerFile :: FilePath -> ErrorT String IO RawLedger
parseLedgerFile "-" = liftIO (hGetContents stdin) >>= parseLedger "-"
parseLedgerFile f = liftIO (readFile f) >>= parseLedger f
printParseError :: (Show a) => a -> IO ()
printParseError e = do putStr "ledger parse error at "; print e
data LedgerFileCtx = Ctx { ctxYear :: !(Maybe Integer)
, ctxCommod :: !(Maybe String)
, ctxAccount :: ![String]
} deriving (Read, Show)
emptyCtx :: LedgerFileCtx
emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
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
parseLedger :: FilePath -> String -> ErrorT String IO RawLedger
parseLedger inname intxt = case runParser ledgerFile emptyCtx inname intxt of
Right m -> liftM rawLedgerConvertTimeLog $ m `ap` (return rawLedgerEmpty)
Left err -> throwError $ show err
ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerFile = do entries <- many1 ledgerAnyEntry
eof
return $ liftM (foldr1 (.)) $ sequence entries
where ledgerAnyEntry = choice [ ledgerDirective
, liftM (return . addEntry) ledgerEntry
, liftM (return . addModifierEntry) ledgerModifierEntry
, liftM (return . addPeriodicEntry) ledgerPeriodicEntry
, liftM (return . addHistoricalPrice) ledgerHistoricalPrice
, emptyLine >> return (return id)
, liftM (return . addTimeLogEntry) timelogentry
]
ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerDirective = do char '!'
directive <- many nonspace
case directive of
"include" -> ledgerInclude
"account" -> ledgerAccountBegin
"end" -> ledgerAccountEnd
ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerInclude = do many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
return $ do contents <- expandPath filename >>= readFileE outerPos
case runParser ledgerFile outerState filename contents of
Right l -> l `catchError` (\err -> throwError $ inIncluded ++ err)
Left perr -> throwError $ inIncluded ++ show perr
where readFileE outerPos filename = ErrorT $ do (liftM Right $ readFile filename) `catch` leftError
where leftError err = return $ Left $ currentPos ++ whileReading ++ show err
currentPos = show outerPos
whileReading = " reading " ++ show filename ++ ":\n"
expandPath :: (MonadIO m) => FilePath -> m FilePath
expandPath inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
return $ homedir ++ drop 1 inname
| otherwise = return inname
ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerAccountBegin = do many1 spacenonewline
parent <- ledgeraccountname
newline
pushParentAccount parent
return $ return id
ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerAccountEnd = popParentAccount >> return (return id)
emptyLine :: GenParser Char st ()
emptyLine = do many spacenonewline
optional $ char ';' >> many (noneOf "\n")
newline
return ()
ledgercomment :: GenParser Char st String
ledgercomment =
try (do
char ';'
many spacenonewline
many (noneOf "\n")
)
<|> return "" <?> "comment"
ledgerModifierEntry :: GenParser Char LedgerFileCtx ModifierEntry
ledgerModifierEntry = do
char '=' <?> "modifier entry"
many spacenonewline
valueexpr <- restofline
transactions <- ledgertransactions
return $ ModifierEntry valueexpr transactions
ledgerPeriodicEntry :: GenParser Char LedgerFileCtx PeriodicEntry
ledgerPeriodicEntry = do
char '~' <?> "entry"
many spacenonewline
periodexpr <- restofline
transactions <- ledgertransactions
return $ PeriodicEntry periodexpr transactions
ledgerHistoricalPrice :: GenParser Char LedgerFileCtx HistoricalPrice
ledgerHistoricalPrice = do
char 'P' <?> "hprice"
many spacenonewline
date <- ledgerdate
many spacenonewline
symbol1 <- commoditysymbol
many spacenonewline
(Mixed [Amount c price pri]) <- someamount
restofline
return $ HistoricalPrice date symbol1 (symbol c) price
ledgerEntry :: GenParser Char LedgerFileCtx Entry
ledgerEntry = do
date <- ledgerdate <?> "entry"
status <- ledgerstatus
code <- ledgercode
description <- many (noneOf "\n") <?> "description"
comment <- ledgercomment
restofline
transactions <- ledgertransactions
return $ balanceEntry $ Entry date status code description comment transactions ""
ledgerdate :: GenParser Char st Day
ledgerdate = do
y <- many1 digit
char '/'
m <- many1 digit
char '/'
d <- many1 digit
many spacenonewline
return (fromGregorian (read y) (read m) (read d))
ledgerdatetime :: GenParser Char st UTCTime
ledgerdatetime = do
day <- ledgerdate
h <- many1 digit
char ':'
m <- many1 digit
s <- optionMaybe $ do
char ':'
many1 digit
many spacenonewline
return $ mkUTCTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s))
ledgerstatus :: GenParser Char st Bool
ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False
ledgercode :: GenParser Char st String
ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return ""
ledgertransactions :: GenParser Char LedgerFileCtx [RawTransaction]
ledgertransactions = many $ try ledgertransaction
ledgertransaction :: GenParser Char LedgerFileCtx RawTransaction
ledgertransaction = many1 spacenonewline >> choice [ normaltransaction, virtualtransaction, balancedvirtualtransaction ]
normaltransaction :: GenParser Char LedgerFileCtx RawTransaction
normaltransaction = do
account <- transactionaccountname
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
parent <- getParentAccount
return (RawTransaction account amount comment RegularTransaction)
virtualtransaction :: GenParser Char LedgerFileCtx RawTransaction
virtualtransaction = do
char '('
account <- transactionaccountname
char ')'
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
parent <- getParentAccount
return (RawTransaction account amount comment VirtualTransaction)
balancedvirtualtransaction :: GenParser Char LedgerFileCtx RawTransaction
balancedvirtualtransaction = do
char '['
account <- transactionaccountname
char ']'
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
return (RawTransaction account amount comment BalancedVirtualTransaction)
transactionaccountname :: GenParser Char LedgerFileCtx AccountName
transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
ledgeraccountname :: GenParser Char st String
ledgeraccountname = do
accountname <- many1 (accountnamechar <|> singlespace)
return $ striptrailingspace accountname
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
striptrailingspace s = if last s == ' ' then init s else s
accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
<?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
transactionamount :: GenParser Char st MixedAmount
transactionamount =
try (do
many1 spacenonewline
a <- someamount <|> return missingamt
return a
) <|> return missingamt
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 = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol"
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 ""
return (first:rest,frac)
numberpartsstartingwithpoint :: GenParser Char st (String,String)
numberpartsstartingwithpoint = do
char '.'
frac <- many1 digit
return ("",frac)
timelog :: GenParser Char LedgerFileCtx TimeLog
timelog = do
entries <- many timelogentry <?> "timelog entry"
eof
return $ TimeLog entries
timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
timelogentry = do
code <- oneOf "bhioO"
many1 spacenonewline
datetime <- ledgerdatetime
comment <- liftM2 (++) getParentAccount restofline
return $ TimeLogEntry code datetime comment
datedisplayexpr :: GenParser Char st (Transaction -> Bool)
datedisplayexpr = do
char 'd'
op <- compareop
char '['
(y,m,d) <- smartdate
char ']'
let edate = parsedate $ printf "%04s/%02s/%02s" y m d
let matcher = \(Transaction{date=tdate}) ->
case op of
"<" -> tdate < edate
"<=" -> tdate <= edate
"=" -> tdate == edate
"==" -> tdate == edate
">=" -> tdate >= edate
">" -> tdate > edate
return matcher
compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]