UMM-0.2.0: UMMParser.hs
{- Copyright 2009-2010 Uwe Hollerbach <uh@alumni.caltech.edu>
This file is part of umm, Uwe's Money Manager.
umm is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3 of the License, or (at your
option) any later version.
umm is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
License for more details.
You should have received a copy of the GNU General Public License
along with umm; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
$Id: UMMParser.hs,v 1.43 2010/05/02 00:37:26 uwe Exp $ -}
-- TODO: template := <to be determined>
module UMMParser (parseURecord, parseUDate, parseUCommand) where
import Prelude
import Data.Char
import Data.Ratio
import Text.ParserCombinators.Parsec as TPCP hiding (spaces)
import UMMData
intErr :: String -> o
intErr loc = error ("internal error at " ++ loc ++ ", please report this")
readInt :: String -> Integer
readInt s = foldl ma 0 s
where ma v1 v2 = 10*v1 + toInteger (digitToInt v2)
readAmt :: String -> String -> Rational
readAmt ip fp =
let l = length fp
e = 10^l
iv = readInt ip
fv = readInt fp
in (e*iv + fv) % e
-- Hide parsec's spaces and substitute this one:
-- want "spaces" to mean an actual something there
spaces, parseString, parseOptionalString, parseXferID :: Parser String
escChar, currencySymbol, otherSymbol :: Parser Char
spaces = many1 space
escChar =
do char '\\'
c <- anyChar
return (case c of
'a' -> chr 7
'b' -> chr 8
't' -> '\t'
'n' -> '\n'
'v' -> chr 11
'f' -> chr 12
'r' -> '\r'
_ -> c)
-- The usual quoted-string with escaped quotes inside
parseString =
do spaces
char '"'
str <- many (escChar <|> noneOf "\"")
char '"'
return str
parseOptionalString = option "" (TPCP.try parseString)
-- TODO: are there some here that we need to add or remove?
-- Currency symbols: do allow these as the first char of a name
-- gathered from various places on the web, mainly unicode.org
currencySymbol =
oneOf ['\x24', -- dollar
'\xa2', -- cent
'\xa3', -- pound
'\xa4', -- generic currency symbol
'\xa5', -- yen
'\x192', -- florin
'\x9f2', -- Bengali rupee 1
'\x9f3', -- Bengali rupee 2
'\xaf1', -- gujarati rupee
'\xbf9', -- Tamil rupee
'\xe2f', -- Thai baht
'\x17db', -- Khmer currency symbol
'\x20a0', -- euro-currency (not euro)
'\x20a1', -- colon
'\x20a2', -- Brazilian cruzeiro
'\x20a3', -- French franc
'\x20a4', -- Italian lira
'\x20a5', -- mill
'\x20a6', -- Nigerian naira
'\x20a7', -- Spanish peseta
'\x20a8', -- Indian rupee
'\x20a9', -- Korean won
'\x20aa', -- Israeli new sheqel
'\x20ab', -- Vietnamese dong
'\x20ac', -- European euro
'\x20ad', -- Laotian kip
'\x20ae', -- Mongolian tugrik
'\x20af', -- Greek drachma
'\x20b0', -- German pfennig
'\x20b1', -- Phillipine peso
'\x20b2', -- Paraguayan guarani ???
'\x20b3', -- austral ???
'\x20b4', -- Ukrainian hryvnia ???
'\x20b5', -- Ghanaian cedi ???
'\x20b6', -- livre tournois ???
'\x20b7', -- spesmilo ???
'\x20b8', -- tenge ???
'\x3350', -- yuan 1
'\x5143', -- Chinese yuan
'\x5186', -- yen 2
'\x5706', -- yen/yuan variant
'\x570e', -- yen/yuan variant
'\x5713', -- yuan variant
'\x571c', -- yuan variant
'\xa838', -- North Indic rupee ???
'\xfdfc'] -- Iranian rial
-- Non-currency symbols: don't allow these as the first character of a name
otherSymbol = oneOf "!%&*+-/:<=>?@^_~"
parseName :: Parser Name
parseName =
do many space
first <- letter <|> currencySymbol
rest <- many (letter <|> currencySymbol <|> digit <|> otherSymbol)
return (Name (first:rest))
parseOptionalName :: Parser Name
parseOptionalName = option noName (TPCP.try parseName)
parseInt :: Parser Integer
parseInt = many1 digit >>= return . readInt
parseXferID = spaces >> many1 (digit <|> letter <|> oneOf "-/_@")
-- Parse first alternative for amounts: \d+(\.\d*)?
parseAmt1, parseAmt2, parseAmt3 :: Parser Rational
parseAmt1 =
many1 digit >>=
(\ip -> option "" (char '.' >> many digit) >>= return . readAmt ip)
-- Parse second alternative for amounts: \.\d+
parseAmt2 = char '.' >> many1 digit >>= return . readAmt "0"
-- Parse third alternative for amounts: \d+/\d+: this is how rationals
-- get displayed if they're not integers scaled by a power of 10, so
-- we'd better be able to handle them...
parseAmt3 = parseInt >>= (\n -> char '/' >> parseInt >>= (\d -> return (n%d)))
-- Parse a floating-point-formatted number as either \d+(\.\d*)? or \.\d+
parseAmount, parseOptionalAmount :: Parser Amount
parseAmount =
do many space
s <- option '+' (oneOf "+-")
v <- TPCP.try parseAmt3 <|> parseAmt1 <|> parseAmt2
return (Amount (if s == '+' then v else negate v))
parseOptionalAmount = option (Amount 1) (TPCP.try parseAmount)
parseCCSAmt :: Parser CCSAmt
parseCCSAmt =
do amt <- parseAmount
ccs <- parseOptionalName
return (CCSAmt ccs amt)
parseOneTo, parseManyTo :: Parser [(Name, CCSAmt)]
parseOneTo =
do to <- parseName
ca <- parseCCSAmt
return [(to, ca)]
parseManyTo =
do spaces
char '{'
tos <- sepBy1 (parseOneTo >>= (\t -> many space >> return t)) (char ',')
char '}'
return (concat tos)
-- A date: three groups of digits separated by '/' or '-' (but not mixed)
-- where the first group of digits is the year, the second the month, and
-- the third the day: YYYY/MM/DD or YYYY-MM-DD: no messing around with
-- whether days come first or months, and also no implicit 19xx or 20xx
-- or whatever.
parseDate :: Parser Date
parseDate =
do spaces
y <- parseInt
m <- pMS '/' <|> pMS '-'
d <- parseInt
return (Date (fromInteger y) (fromInteger m) (fromInteger d))
where pMS s = char s >> parseInt >>= (\m -> char s >> return m)
parseReconcile :: Parser Bool
parseReconcile =
option False (TPCP.try (many space >> oneOf "*!" >> return True))
parsePeriod :: Parser Period
parsePeriod =
spaces >> (pPG <|>
pPS "daily" (PND 1) <|>
pPS "weekly" (PNW 1) <|>
pPS "monthly" (PNM 1) <|>
pPS "quarterly" (PNM 3) <|>
pPS "annually" (PNY 1) <|>
TPCP.try (pPS "biweekly" (PNW 2)) <|>
TPCP.try (pPS "bimonthly" (PNM 2)) <|>
pPS "biannually" (PNY 2) <|>
TPCP.try (pPS "semiweekly" PSW) <|>
TPCP.try (pPS "semimonthly" PSM) <|>
pPS "semiannually" (PNM 6))
where pPS s p = string s >> return p
pPG = do n <- parseInt
spaces
p <- parsePrefixOf 1 "days" <|>
parsePrefixOf 1 "weeks" <|>
parsePrefixOf 1 "months" <|>
parsePrefixOf 1 "years"
let ni = fromInteger n
return (case p of
"days" -> PND ni
"weeks" -> PNW ni
"months" -> PNM ni
"years" -> PNY ni
_ -> intErr "parsePeriod")
-- The top-level record parsers
parseCCS, parseIE, parseAccount, parseGroup, parsePrice, parseXfer, parseEBS,
parseSplit, parseTodo, parseRecur, parseComment, parseBlank, parseRecord ::
Parser Record
parseCCS =
do string "ccs"
name <- parseName
desc <- parseOptionalString
ma <- option Nothing (TPCP.try (parseAmount >>= return . Just))
bname <- parseOptionalName
return (CCSRec name desc ma bname)
parseIE =
do rtype <- string "income" <|> string "expense"
name <- parseName
desc <- parseOptionalString
return (case rtype of
"income" -> IncomeRec name desc
"expense" -> ExpenseRec name desc
_ -> intErr "parseIE")
parseAccount =
do string "account"
name <- parseName
date <- option startTime (TPCP.try parseDate)
desc <- parseOptionalString
ival <- option Nothing (TPCP.try (parseCCSAmt >>= return . Just))
return (AccountRec name date desc ival)
parseGroup =
do string "group"
names <- many1 parseName
return (GroupRec (head names) (tail names))
parsePrice =
do string "price"
date <- parseDate
amt1 <- parseOptionalAmount
name1 <- parseName
ca2 <- parseCCSAmt
return (PriceRec date False (CCSAmt name1 amt1) ca2)
parseXfer =
do string "xfer"
rec <- parseReconcile
date <- parseDate
from <- parseName
to <- TPCP.try parseOneTo <|> parseManyTo
memo <- parseOptionalString
ident <- option "" (TPCP.try parseXferID)
return (XferRec date rec from to memo ident)
-- 'buy' and 'sell' are purely syntactic sugar for 'exch': 'buy' is
-- exactly the same, and 'sell' is the same as if {amt1,ccs1} and
-- {amt2,ccs2} were swapped in an exch
parseEBS =
do rtype <- string "buy" <|> string "sell" <|> string "exch"
rec <- parseReconcile
date <- parseDate
acct <- parseName
amt1 <- parseAmount
name1 <- parseName
ca2 <- parseCCSAmt
memo <- parseOptionalString
let et = case rtype of
"buy" -> B
"sell" -> S
"exch" -> E
_ -> intErr "parseEBS"
ca1 = CCSAmt name1 amt1
if et == S
then return (ExchRec et date rec acct ca2 ca1 memo)
else return (ExchRec et date rec acct ca1 ca2 memo)
parseSplit =
do string "split"
date <- parseDate
name <- parseName
amt1 <- parseAmount
amt2 <- parseAmount
return (SplitRec date name amt1 amt2)
parseTodo =
do string "todo"
rec <- parseReconcile
date <- parseDate
spaces
memo <- many anyChar
return (ToDoRec date rec (trimspace memo))
parseComment =
do many1 (oneOf "#;")
many space
comment <- many anyChar
return (CommentRec (trimspace comment))
parseRecur =
do string "recurring"
period <- parsePeriod
spaces -- TODO: keep this syntactic sugar?
string "until" -- it kinda reads better...?
dl <- parseDate
spaces
dr <- option startTime
(TPCP.try (parsePrefixOf 3 "reconciled" >> parseDate))
many space
record <- parseEBS <|> parseXfer
return (RecurRec period dl dr record)
parseBlank = many space >> return (CommentRec "")
parseRecord =
do many space
record <- parsePrice
<|> parseXfer
<|> parseCCS
<|> TPCP.try parseIE
<|> TPCP.try parseEBS
<|> parseSplit
<|> parseTodo
<|> parseAccount
<|> parseGroup
<|> parseRecur
<|> parseComment
<|> parseBlank -- this must be last, as it can match nothing
many space
eof
return record
parseURecord :: String -> Record
parseURecord input =
case parse parseRecord "umm record" input of
Left _ -> ErrorRec input
Right val -> val
parseUDate :: String -> Either ParseError Date
parseUDate input = parse parseDate "umm date" (' ' : input)
parsePrefixOf :: Int -> String -> Parser String
parsePrefixOf n str =
string (take n str) >> opts (drop n str) >> return str
where opts [] = return ()
opts (c:cs) = optional (char c >> opts cs)
parseCmdBalance, parseCmdBasis, parseCmdChange, parseCmdPrice,
parseCmdReconcile, parseCmdRegister, parseCmdToDo, parseCommand ::
Date -> Parser Command
parseCmdExport, parseCmdList :: Parser Command
parseCmdBalance now =
do parsePrefixOf 3 "balance"
name <- parseOptionalName
date <- option now (TPCP.try parseDate)
return (BalanceCmd name date)
parseCmdBasis now =
do parsePrefixOf 3 "basis"
name <- parseName
date <- option now (TPCP.try parseDate)
return (BasisCmd name date)
parseCmdExport = parsePrefixOf 1 "export" >> return ExportCmd
-- TODO: make verbose/nonverbose work... somehow add optional verbosity
-- ok, this is really cheesy! make it better!
parseCmdChange now =
do parsePrefixOf 1 "change"
name <- parseName
date1 <- option now parseDate
date2 <- option startTime parseDate
if date2 < date1
then return (ChangeCmd True name date2 date1)
else return (ChangeCmd False name date1 date2)
parseCmdList =
do parsePrefixOf 1 "list"
many space
w <- option "all" (parsePrefixOf 1 "ccs" <|>
parsePrefixOf 1 "groups" <|>
parsePrefixOf 1 "incomes" <|>
parsePrefixOf 1 "expenses" <|>
TPCP.try (parsePrefixOf 2 "all") <|>
parsePrefixOf 2 "accounts")
return (ListDataCmd (case w of
"all" -> COLAll
"ccs" -> COLCCS
"accounts" -> COLAccs
"groups" -> COLGrps
"incomes" -> COLIncs
"expenses" -> COLExps
_ -> intErr "parseListCmd"))
parseCmdPrice now =
do parsePrefixOf 1 "price"
name <- parseName
date <- option now (TPCP.try parseDate)
return (PriceCmd name date)
parseCmdReconcile now =
do parsePrefixOf 3 "reconcile"
name <- parseOptionalName
date <- option now (TPCP.try parseDate)
return (ReconcileCmd name date)
parseCmdRegister now =
do parsePrefixOf 3 "register"
name <- parseName
date1 <- option now (TPCP.try parseDate)
date2 <- option startTime (TPCP.try parseDate)
if date2 < date1
then return (RegisterCmd name date2 date1)
else return (RegisterCmd name date1 date2)
parseCmdToDo now =
do parsePrefixOf 1 "todo"
date <- option now (TPCP.try parseDate)
return (ToDoCmd date)
parseCommand date =
do cmd <- parseCmdChange date
<|> parseCmdExport
<|> parseCmdList
<|> parseCmdPrice date
<|> parseCmdToDo date
<|> TPCP.try (parseCmdBalance date)
<|> parseCmdBasis date
<|> TPCP.try (parseCmdRegister date)
<|> parseCmdReconcile date
eof
return cmd
parseUCommand :: Date -> String -> Command
parseUCommand now input =
case parse (parseCommand now) "umm command" input of
Left err -> error (show err)
Right val -> val