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 Data.Time.LocalTime
import Data.Time.Calendar
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 System.FilePath(takeDirectory,combine)
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
setYear :: Integer -> GenParser tok LedgerFileCtx ()
setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
getYear = liftM ctxYear getState
printParseError :: (Show a) => a -> IO ()
printParseError e = do putStr "ledger parse error at "; print e
parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger
parseLedgerFile t "-" = liftIO (hGetContents stdin) >>= parseLedger t "-"
parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f
parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO RawLedger
parseLedger reftime inname intxt = do
case runParser ledgerFile emptyCtx inname intxt of
Right m -> liftM (rawLedgerConvertTimeLog reftime) $ 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
, ledgerDefaultYear
, 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 outerPos 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) => 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
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
ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerDefaultYear = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
let y' = read y
guard (y' >= 1000)
setYear y'
return $ return id
ledgerEntry :: GenParser Char LedgerFileCtx Entry
ledgerEntry = do
date <- ledgerdate <?> "entry"
status <- ledgerstatus
code <- ledgercode
description <- many (noneOf "\n") <?> "description"
comment <- ledgercomment
restofline
transactions <- ledgertransactions
let e = Entry date status code description comment transactions ""
case balanceEntry e of
Right e' -> return e'
Left err -> error err
ledgerdate :: GenParser Char LedgerFileCtx Day
ledgerdate = try ledgerfulldate <|> ledgerpartialdate
ledgerfulldate :: GenParser Char LedgerFileCtx Day
ledgerfulldate = do
(y,m,d) <- ymd
many spacenonewline
return $ fromGregorian (read y) (read m) (read d)
ledgerpartialdate :: GenParser Char LedgerFileCtx Day
ledgerpartialdate = do
(_,m,d) <- md
many spacenonewline
y <- getYear
when (y==Nothing) $ error "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
h <- many1 digit
char ':'
m <- many1 digit
s <- optionMaybe $ do
char ':'
many1 digit
many spacenonewline
let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)
return $ LocalTime day tod
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
status <- ledgerstatus
account <- transactionaccountname
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
parent <- getParentAccount
return (RawTransaction status account amount comment RegularTransaction)
virtualtransaction :: GenParser Char LedgerFileCtx RawTransaction
virtualtransaction = do
status <- ledgerstatus
char '('
account <- transactionaccountname
char ')'
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
parent <- getParentAccount
return (RawTransaction status account amount comment VirtualTransaction)
balancedvirtualtransaction :: GenParser Char LedgerFileCtx RawTransaction
balancedvirtualtransaction = do
status <- ledgerstatus
char '['
account <- transactionaccountname
char ']'
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
return (RawTransaction status 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) ["<=",">=","==","<","=",">"]