UMM-0.1.3: UMMParser.hs
{- Copyright 2009 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.34 2009/11/29 23:10:14 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
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
trimspace :: String -> String
trimspace str = f (f str)
where f = dropWhile isSpace . reverse
-- Hide parsec's spaces and substitute this one:
-- want "spaces" to mean an actual something there
spaces, parseString, parseOptionalString, parseXferID :: Parser String
escChar, currency_symbol, other_symbol :: 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
currency_symbol =
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
other_symbol = oneOf "!%&*+-/:<=>?@^_~"
parseName :: Parser Name
parseName =
do spaces
first <- letter <|> currency_symbol
rest <- many (letter <|> currency_symbol <|> digit <|> other_symbol)
return (Name (first:rest))
parseOptionalName :: Parser Name
parseOptionalName = option (Name "") (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 =
do ip <- many1 digit
fp <- option "" (char '.' >> many digit)
return (readAmt ip fp)
-- Parse second alternative for amounts: \.\d+
parseAmt2 = char '.' >> many1 digit >>= (\fp -> return (readAmt "0" fp))
-- 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)
-- 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 >> char '*' >> return True))
intErr :: String -> o
intErr loc = error ("internal error at " ++ loc ++ ", please report this")
-- The top-level record parsers
parseCCS, parseIE, parseAccount, parseGroup, parsePrice, parseXfer,
parseEBS, parseSplit, parseTodo, parseComment, parseBlank, parseRecord ::
Parser Record
parseCCS =
do string "ccs"
name <- parseName
desc <- parseOptionalString
ma <- option Nothing (TPCP.try (parseAmount >>=
return . Just . (CCSAmt noName)))
return (CCSRec name desc ma)
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 start_time (TPCP.try parseDate)
desc <- parseOptionalString
return (AccountRec name date desc)
parseGroup =
do string "group"
names <- many1 parseName
return (GroupRec (head names) (tail names))
parsePrice =
do string "price"
date <- parseDate
amt1 <- parseOptionalAmount
name1 <- parseName
amt2 <- parseAmount
name2 <- parseOptionalName
return (PriceRec date False (CCSAmt name1 amt1) (CCSAmt name2 amt2))
parseXfer =
do string "xfer"
rec <- parseReconcile
date <- parseDate
acc1 <- parseName
acc2 <- parseName
amt <- parseAmount
ccs <- parseOptionalName
memo <- parseOptionalString
ident <- option "" (TPCP.try parseXferID)
return (XferRec date rec acc1 acc2 (CCSAmt ccs amt) 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
amt2 <- parseAmount
name2 <- parseOptionalName
memo <- parseOptionalString
let et = case rtype of
"buy" -> B
"sell" -> S
"exch" -> E
_ -> intErr "parseEBS"
ccsa1 = CCSAmt name1 amt1
ccsa2 = CCSAmt name2 amt2
if et == S
then return (ExchRec et date rec acct ccsa2 ccsa1 memo)
else return (ExchRec et date rec acct ccsa1 ccsa2 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 (char '#')
many space
comment <- many anyChar
return (CommentRec (trimspace comment))
parseBlank = many space >> return (CommentRec "")
parseRecord =
do many space
record <- parsePrice
<|> parseXfer
<|> parseCCS
<|> (TPCP.try parseIE)
<|> (TPCP.try parseEBS)
<|> parseSplit
<|> parseTodo
<|> parseAccount
<|> parseGroup
<|> 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
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)
-- 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 start_time parseDate
if compare date2 date1 == LT
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 start_time (TPCP.try parseDate)
if compare date2 date1 == LT
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
<|> 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