module Ledger.Parse
where
import Prelude hiding (readFile, putStr, print)
import Control.Monad.Error
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Char
import Text.ParserCombinators.Parsec.Combinator
import System.Directory
import System.IO.UTF8
import System.IO (stdin)
import Ledger.Utils
import Ledger.Types
import Ledger.Dates
import Ledger.AccountName (accountNameFromComponents,accountNameComponents)
import Ledger.Amount
import Ledger.LedgerTransaction
import Ledger.Posting
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 items <- many ledgerItem
eof
return $ liftM (foldr (.) id) $ sequence items
where
ledgerItem = choice [ ledgerDirective
, liftM (return . addLedgerTransaction) ledgerTransaction
, liftM (return . addModifierTransaction) ledgerModifierTransaction
, liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction
, 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"
directive <- many nonspace
case directive of
"include" -> ledgerInclude
"account" -> ledgerAccountBegin
"end" -> ledgerAccountEnd
_ -> mzero
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 ';' <?> "comment") >> many (noneOf "\n")
newline
return ()
ledgercomment :: GenParser Char st String
ledgercomment =
try (do
char ';'
many spacenonewline
many (noneOf "\n")
)
<|> return "" <?> "comment"
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 <- ledgerdate
many spacenonewline
symbol1 <- commoditysymbol
many spacenonewline
(Mixed [Amount c q _]) <- someamount
restofline
return $ HistoricalPrice date symbol1 (symbol c) q
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
ledgerTransaction :: GenParser Char LedgerFileCtx LedgerTransaction
ledgerTransaction = do
date <- ledgerdate <?> "transaction"
status <- ledgerstatus
code <- ledgercode
description <- liftM rstrip (many1 (noneOf ";\n") <?> "description")
comment <- ledgercomment
restofline
postings <- ledgerpostings
let t = LedgerTransaction date status code description comment postings ""
case balanceLedgerTransaction t of
Right t' -> return t'
Left err -> fail 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) $ 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
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 '*' <?> "status"; many1 spacenonewline; return True } ) <|> return False
ledgercode :: GenParser Char st String
ledgercode = try (do { char '(' <?> "code"; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return ""
ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
ledgerpostings = many1 $ try ledgerposting
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
restofline
return (Posting status account' amount comment ptype)
transactionaccountname :: GenParser Char LedgerFileCtx AccountName
transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
ledgeraccountname :: GenParser Char st String
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
a <- someamount <|> return missingamt
return a
) <|> 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 = 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)
timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
timelogentry = do
code <- oneOf "bhioO"
many1 spacenonewline
datetime <- ledgerdatetime
comment <- liftM2 (++) getParentAccount restofline
return $ TimeLogEntry (read [code]) datetime comment
datedisplayexpr :: GenParser Char st (Transaction -> 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) . tdate
case op of
"<" -> test (<)
"<=" -> test (<=)
"=" -> test (==)
"==" -> test (==)
">=" -> test (>=)
">" -> test (>)
_ -> mzero
compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]