module Ledger.Parse
where
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.IO
import qualified Data.Map as Map
import Ledger.Utils
import Ledger.Types
import Ledger.Amount
import Ledger.Entry
import Ledger.Commodity
import Ledger.TimeLog
import Data.Time.LocalTime
import Data.Time.Calendar
parseLedgerFile :: String -> IO (Either ParseError RawLedger)
parseLedgerFile "-" = fmap (parse ledgerfile "-") $ hGetContents stdin
parseLedgerFile f = parseFromFile ledgerfile f
printParseError :: (Show a) => a -> IO ()
printParseError e = do putStr "ledger parse error at "; print e
ledgerLanguageDef = LanguageDef {
commentStart = ""
, commentEnd = ""
, commentLine = ";"
, nestedComments = False
, identStart = letter <|> char '_'
, identLetter = alphaNum <|> oneOf "_':"
, opStart = opLetter emptyDef
, opLetter = oneOf "!#$%&*+./<=>?@\\^|-~"
, reservedOpNames= []
, reservedNames = []
, caseSensitive = False
}
lexer = P.makeTokenParser ledgerLanguageDef
whiteSpace = P.whiteSpace lexer
lexeme = P.lexeme lexer
natural = P.natural lexer
parens = P.parens lexer
semi = P.semi lexer
identifier = P.identifier lexer
reserved = P.reserved lexer
reservedOp = P.reservedOp lexer
ledgerfile :: Parser RawLedger
ledgerfile = try ledgerfromtimelog <|> ledger
ledger :: Parser RawLedger
ledger = do
modifier_entries <- many ledgermodifierentry
periodic_entries <- many ledgerperiodicentry
entries <- (many $ try ledgerentry) <?> "entry"
final_comment_lines <- ledgernondatalines
eof
return $ RawLedger modifier_entries periodic_entries entries (unlines final_comment_lines)
ledgernondatalines :: Parser [String]
ledgernondatalines = many (try ledgerdirective <|>
try commentline <|>
blankline)
ledgerdirective :: Parser String
ledgerdirective = char '!' >> restofline <?> "directive"
blankline :: Parser String
blankline =
do {s <- many1 spacenonewline; newline; return s} <|>
do {newline; return ""} <?> "blank line"
commentline :: Parser String
commentline = do
many spacenonewline
char ';' <?> "comment line"
l <- restofline
return $ ";" ++ l
ledgercomment :: Parser String
ledgercomment =
try (do
char ';'
many spacenonewline
many (noneOf "\n")
)
<|> return "" <?> "comment"
ledgermodifierentry :: Parser ModifierEntry
ledgermodifierentry = do
char '=' <?> "entry"
many spacenonewline
valueexpr <- restofline
transactions <- ledgertransactions
return (ModifierEntry valueexpr transactions)
ledgerperiodicentry :: Parser PeriodicEntry
ledgerperiodicentry = do
char '~' <?> "entry"
many spacenonewline
periodexpr <- restofline
transactions <- ledgertransactions
return (PeriodicEntry periodexpr transactions)
ledgerentry :: Parser Entry
ledgerentry = do
preceding <- ledgernondatalines
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 (unlines preceding)
ledgerday :: Parser Day
ledgerday = do
y <- many1 digit
char '/'
m <- many1 digit
char '/'
d <- many1 digit
many spacenonewline
return (fromGregorian (read y) (read m) (read d))
ledgerdate :: Parser Date
ledgerdate = fmap mkDate ledgerday
ledgerdatetime :: Parser DateTime
ledgerdatetime = do
day <- ledgerday
h <- many1 digit
char ':'
m <- many1 digit
s <- optionMaybe $ do
char ':'
many1 digit
many spacenonewline
return (mkDateTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)))
ledgerstatus :: Parser Bool
ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False
ledgercode :: Parser String
ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return ""
ledgertransactions :: Parser [RawTransaction]
ledgertransactions =
((try virtualtransaction <|> try balancedvirtualtransaction <|> ledgertransaction) <?> "transaction")
`manyTill` (do {newline <?> "blank line"; return ()} <|> eof)
ledgertransaction :: Parser RawTransaction
ledgertransaction = do
many1 spacenonewline
account <- ledgeraccountname
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
return (RawTransaction account amount comment RegularTransaction)
virtualtransaction :: Parser RawTransaction
virtualtransaction = do
many1 spacenonewline
char '('
account <- ledgeraccountname
char ')'
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
return (RawTransaction account amount comment VirtualTransaction)
balancedvirtualtransaction :: Parser RawTransaction
balancedvirtualtransaction = do
many1 spacenonewline
char '['
account <- ledgeraccountname
char ']'
amount <- transactionamount
many spacenonewline
comment <- ledgercomment
restofline
return (RawTransaction account amount comment BalancedVirtualTransaction)
ledgeraccountname :: Parser 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 :: Parser MixedAmount
transactionamount =
try (do
many1 spacenonewline
a <- someamount <|> return missingamt
return a
) <|> return missingamt
someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
leftsymbolamount :: Parser 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 :: Parser 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 :: Parser 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 :: Parser String
commoditysymbol = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol"
priceamount :: Parser (Maybe MixedAmount)
priceamount =
try (do
many spacenonewline
char '@'
many spacenonewline
a <- someamount
return $ Just a
) <|> return Nothing
amountquantity :: Parser (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 :: Parser (String,String)
numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint
numberpartsstartingwithdigit :: Parser (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 :: Parser (String,String)
numberpartsstartingwithpoint = do
char '.'
frac <- many1 digit
return ("",frac)
spacenonewline :: Parser Char
spacenonewline = satisfy (\c -> c `elem` " \v\f\t")
restofline :: Parser String
restofline = anyChar `manyTill` newline
whiteSpace1 :: Parser ()
whiteSpace1 = do space; whiteSpace
nonspace = satisfy (not . isSpace)
timelog :: Parser TimeLog
timelog = do
entries <- many timelogentry <?> "timelog entry"
eof
return $ TimeLog entries
timelogentry :: Parser TimeLogEntry
timelogentry = do
many (commentline <|> blankline)
code <- oneOf "bhioO"
many1 spacenonewline
datetime <- ledgerdatetime
comment <- restofline
return $ TimeLogEntry code datetime comment
ledgerfromtimelog :: Parser RawLedger
ledgerfromtimelog = do
tl <- timelog
return $ ledgerFromTimeLog tl
smartdate :: Parser (String,String,String)
smartdate = do
(y,m,d) <- (
try ymd
<|> try ym
<|> try y
)
return $ (y,m,d)
datesep = oneOf "/-."
ymd :: Parser (String,String,String)
ymd = do
y <- many digit
datesep
m <- many digit
datesep
d <- many digit
return (y,m,d)
ym :: Parser (String,String,String)
ym = do
y <- many digit
datesep
m <- many digit
return (y,m,"1")
y :: Parser (String,String,String)
y = do
y <- many digit
return (y,"1","1")
smartparsedate :: String -> Date
smartparsedate s = parsedate $ printf "%04s/%02s/%02s" y m d
where (y,m,d) = fromparse $ parsewith smartdate s