simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-09-20 02:37:12 +03:00
Code Issues Projects Releases Wiki Activity

New ledger parser with file inclusion

Browse Source
This commit is contained in:
nick 2008-12-08 01:49:31 +00:00
parent 157f47c592
commit ee4a2a1c1e
3 changed files with 139 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
Ledger/Parse.hs
View File

@ -6,6 +6,8 @@ Parsers for standard ledger and timelog files.
module Ledger.Parse module Ledger.Parse
where where
import Control.Monad
import Control.Monad.Error
import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Char import Text.ParserCombinators.Parsec.Char
import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec.Language
@ -20,51 +22,71 @@ import Ledger.Amount
import Ledger.Entry import Ledger.Entry
import Ledger.Commodity import Ledger.Commodity
import Ledger.TimeLog import Ledger.TimeLog
import Ledger.RawLedger
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Time.Calendar import Data.Time.Calendar
-- utils -- utils
parseLedgerFile :: String -> IO (Either ParseError RawLedger) parseLedgerFile :: FilePath -> ErrorT String IO RawLedger
parseLedgerFile "-" = fmap (parse ledgerfile "-") $ hGetContents stdin parseLedgerFile "-" = liftIO (hGetContents stdin) >>= parseLedger "-"
parseLedgerFile f = parseFromFile ledgerfile f parseLedgerFile f = liftIO (readFile f) >>= parseLedger f
printParseError :: (Show a) => a -> IO () printParseError :: (Show a) => a -> IO ()
printParseError e = do putStr "ledger parse error at "; print e printParseError e = do putStr "ledger parse error at "; print e
-- set up token parsing, though we're not yet using these much -- Default accounts "nest" hierarchically
ledgerLanguageDef = LanguageDef {
commentStart = "" data LedgerFileCtx = Ctx { ctxYear :: !(Maybe Integer)
, commentEnd = "" , ctxCommod :: !(Maybe String)
, commentLine = ";" , ctxAccount :: ![String]
, nestedComments = False } deriving (Read, Show)
, identStart = letter <|> char '_'
, identLetter = alphaNum <|> oneOf "_':" emptyCtx :: LedgerFileCtx
, opStart = opLetter emptyDef emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
, opLetter = oneOf "!#$%&*+./<=>?@\\^|-~"
, reservedOpNames= [] parseLedger :: FilePath -> String -> ErrorT String IO RawLedger
, reservedNames = [] parseLedger inname intxt = case runParser ledgerFile emptyCtx inname intxt of
, caseSensitive = False Right m -> m `ap` (return rawLedgerEmpty)
} Left err -> throwError $ show err
lexer = P.makeTokenParser ledgerLanguageDef
whiteSpace = P.whiteSpace lexer ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
lexeme = P.lexeme lexer ledgerFile = do entries <- many1 ledgerAnyEntry
--symbol = P.symbol lexer eof
natural = P.natural lexer return $ liftM (foldr1 (.)) $ sequence entries
parens = P.parens lexer where ledgerAnyEntry = choice [ ledgerInclude
semi = P.semi lexer , liftM (return . addEntry) ledgerEntry
identifier = P.identifier lexer , liftM (return . addModifierEntry) ledgerModifierEntry
reserved = P.reserved lexer , liftM (return . addPeriodicEntry) ledgerPeriodicEntry
reservedOp = P.reservedOp lexer , blankline >> return (return id)
, commentline >> return (return id)
]
ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
ledgerInclude = do string "!include"
many1 spacenonewline
filename <- restofline
outerState <- getState
outerPos <- getPosition
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
return $ do contents <- readFileE outerPos filename
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"
--ledgerEntry = return $ throwError "unimplemented"
-- parsers -- parsers
-- | Parse a RawLedger from either a ledger file or a timelog file. -- | Parse a RawLedger from either a ledger file or a timelog file.
-- It tries first the timelog parser then the ledger parser; this means -- It tries first the timelog parser then the ledger parser; this means
-- parse errors for ledgers are useful while those for timelogs are not. -- parse errors for ledgers are useful while those for timelogs are not.
ledgerfile :: Parser RawLedger
ledgerfile = try ledgerfromtimelog <|> ledger
{-| Parse a ledger file. Here is the ledger grammar from the ledger 2.5 manual: {-| Parse a ledger file. Here is the ledger grammar from the ledger 2.5 manual:
@ -166,38 +188,18 @@ i, o, b, h
See "Tests" for sample data. See "Tests" for sample data.
-} -}
ledger :: Parser RawLedger
ledger = do
-- we expect these to come first, unlike ledger
modifier_entries <- many ledgermodifierentry
periodic_entries <- many ledgerperiodicentry
entries <- (many $ try ledgerentry) <?> "entry" blankline :: GenParser Char st String
final_comment_lines <- ledgernondatalines blankline = (do { s <- many spacenonewline; newline; return s }) <?> "blank line"
eof
return $ RawLedger modifier_entries periodic_entries entries (unlines final_comment_lines)
ledgernondatalines :: Parser [String] commentline :: GenParser Char st String
ledgernondatalines = many (try ledgerdirective <|> -- treat as comments
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 commentline = do
many spacenonewline many spacenonewline
char ';' <?> "comment line" char ';' <?> "comment line"
l <- restofline l <- restofline
return $ ";" ++ l return $ ";" ++ l
ledgercomment :: Parser String ledgercomment :: GenParser Char st String
ledgercomment = ledgercomment =
try (do try (do
char ';' char ';'
@ -206,25 +208,24 @@ ledgercomment =
) )
<|> return "" <?> "comment" <|> return "" <?> "comment"
ledgermodifierentry :: Parser ModifierEntry ledgerModifierEntry :: GenParser Char LedgerFileCtx ModifierEntry
ledgermodifierentry = do ledgerModifierEntry = do
char '=' <?> "entry" char '=' <?> "modifier entry"
many spacenonewline many spacenonewline
valueexpr <- restofline valueexpr <- restofline
transactions <- ledgertransactions transactions <- ledgertransactions
return (ModifierEntry valueexpr transactions) return $ ModifierEntry valueexpr transactions
ledgerperiodicentry :: Parser PeriodicEntry ledgerPeriodicEntry :: GenParser Char LedgerFileCtx PeriodicEntry
ledgerperiodicentry = do ledgerPeriodicEntry = do
char '~' <?> "entry" char '~' <?> "entry"
many spacenonewline many spacenonewline
periodexpr <- restofline periodexpr <- restofline
transactions <- ledgertransactions transactions <- ledgertransactions
return (PeriodicEntry periodexpr transactions) return $ PeriodicEntry periodexpr transactions
ledgerentry :: Parser Entry ledgerEntry :: GenParser Char LedgerFileCtx Entry
ledgerentry = do ledgerEntry = do
preceding <- ledgernondatalines
date <- ledgerdate <?> "entry" date <- ledgerdate <?> "entry"
status <- ledgerstatus status <- ledgerstatus
code <- ledgercode code <- ledgercode
@ -235,9 +236,9 @@ ledgerentry = do
comment <- ledgercomment comment <- ledgercomment
restofline restofline
transactions <- ledgertransactions transactions <- ledgertransactions
return $ balanceEntry $ Entry date status code description comment transactions (unlines preceding) return $ balanceEntry $ Entry date status code description comment transactions ""
ledgerdate :: Parser Day ledgerdate :: GenParser Char st Day
ledgerdate = do ledgerdate = do
y <- many1 digit y <- many1 digit
char '/' char '/'
@ -247,7 +248,7 @@ ledgerdate = do
many spacenonewline many spacenonewline
return (fromGregorian (read y) (read m) (read d)) return (fromGregorian (read y) (read m) (read d))
ledgerdatetime :: Parser UTCTime ledgerdatetime :: GenParser Char st UTCTime
ledgerdatetime = do ledgerdatetime = do
day <- ledgerdate day <- ledgerdate
h <- many1 digit h <- many1 digit
@ -260,20 +261,20 @@ ledgerdatetime = do
return $ mkUTCTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)) return $ mkUTCTime day (TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s))
ledgerstatus :: Parser Bool ledgerstatus :: GenParser Char st Bool
ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False
ledgercode :: Parser String ledgercode :: GenParser Char st String
ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return "" ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return ""
ledgertransactions :: Parser [RawTransaction] ledgertransactions :: GenParser Char st [RawTransaction]
ledgertransactions = ledgertransactions = many $ try ledgertransaction
((try virtualtransaction <|> try balancedvirtualtransaction <|> ledgertransaction) <?> "transaction")
`manyTill` (do {newline <?> "blank line"; return ()} <|> eof)
ledgertransaction :: Parser RawTransaction ledgertransaction :: GenParser Char st RawTransaction
ledgertransaction = do ledgertransaction = many1 spacenonewline >> choice [ normaltransaction, virtualtransaction, balancedvirtualtransaction ]
many1 spacenonewline
normaltransaction :: GenParser Char st RawTransaction
normaltransaction = do
account <- ledgeraccountname account <- ledgeraccountname
amount <- transactionamount amount <- transactionamount
many spacenonewline many spacenonewline
@ -281,9 +282,8 @@ ledgertransaction = do
restofline restofline
return (RawTransaction account amount comment RegularTransaction) return (RawTransaction account amount comment RegularTransaction)
virtualtransaction :: Parser RawTransaction virtualtransaction :: GenParser Char st RawTransaction
virtualtransaction = do virtualtransaction = do
many1 spacenonewline
char '(' char '('
account <- ledgeraccountname account <- ledgeraccountname
char ')' char ')'
@ -293,9 +293,8 @@ virtualtransaction = do
restofline restofline
return (RawTransaction account amount comment VirtualTransaction) return (RawTransaction account amount comment VirtualTransaction)
balancedvirtualtransaction :: Parser RawTransaction balancedvirtualtransaction :: GenParser Char st RawTransaction
balancedvirtualtransaction = do balancedvirtualtransaction = do
many1 spacenonewline
char '[' char '['
account <- ledgeraccountname account <- ledgeraccountname
char ']' char ']'
@ -306,7 +305,7 @@ balancedvirtualtransaction = do
return (RawTransaction account amount comment BalancedVirtualTransaction) return (RawTransaction account amount comment BalancedVirtualTransaction)
-- | account names may have single spaces inside them, and are terminated by two or more spaces -- | account names may have single spaces inside them, and are terminated by two or more spaces
ledgeraccountname :: Parser String ledgeraccountname :: GenParser Char st String
ledgeraccountname = do ledgeraccountname = do
accountname <- many1 (accountnamechar <|> singlespace) accountname <- many1 (accountnamechar <|> singlespace)
return $ striptrailingspace accountname return $ striptrailingspace accountname
@ -318,7 +317,7 @@ ledgeraccountname = do
accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
<?> "account name character (non-bracket, non-parenthesis, non-whitespace)" <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
transactionamount :: Parser MixedAmount transactionamount :: GenParser Char st MixedAmount
transactionamount = transactionamount =
try (do try (do
many1 spacenonewline many1 spacenonewline
@ -328,7 +327,7 @@ transactionamount =
someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount
leftsymbolamount :: Parser MixedAmount leftsymbolamount :: GenParser Char st MixedAmount
leftsymbolamount = do leftsymbolamount = do
sym <- commoditysymbol sym <- commoditysymbol
sp <- many spacenonewline sp <- many spacenonewline
@ -338,7 +337,7 @@ leftsymbolamount = do
return $ Mixed [Amount c q pri] return $ Mixed [Amount c q pri]
<?> "left-symbol amount" <?> "left-symbol amount"
rightsymbolamount :: Parser MixedAmount rightsymbolamount :: GenParser Char st MixedAmount
rightsymbolamount = do rightsymbolamount = do
(q,p,comma) <- amountquantity (q,p,comma) <- amountquantity
sp <- many spacenonewline sp <- many spacenonewline
@ -348,7 +347,7 @@ rightsymbolamount = do
return $ Mixed [Amount c q pri] return $ Mixed [Amount c q pri]
<?> "right-symbol amount" <?> "right-symbol amount"
nosymbolamount :: Parser MixedAmount nosymbolamount :: GenParser Char st MixedAmount
nosymbolamount = do nosymbolamount = do
(q,p,comma) <- amountquantity (q,p,comma) <- amountquantity
pri <- priceamount pri <- priceamount
@ -356,10 +355,10 @@ nosymbolamount = do
return $ Mixed [Amount c q pri] return $ Mixed [Amount c q pri]
<?> "no-symbol amount" <?> "no-symbol amount"
commoditysymbol :: Parser String commoditysymbol :: GenParser Char st String
commoditysymbol = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol" commoditysymbol = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol"
priceamount :: Parser (Maybe MixedAmount) priceamount :: GenParser Char st (Maybe MixedAmount)
priceamount = priceamount =
try (do try (do
many spacenonewline many spacenonewline
@ -374,7 +373,7 @@ priceamount =
-- | parse a ledger-style numeric quantity and also return the number of -- | parse a ledger-style numeric quantity and also return the number of
-- digits to the right of the decimal point and whether thousands are -- digits to the right of the decimal point and whether thousands are
-- separated by comma. -- separated by comma.
amountquantity :: Parser (Double, Int, Bool) amountquantity :: GenParser Char st (Double, Int, Bool)
amountquantity = do amountquantity = do
sign <- optionMaybe $ string "-" sign <- optionMaybe $ string "-"
(intwithcommas,frac) <- numberparts (intwithcommas,frac) <- numberparts
@ -392,10 +391,10 @@ amountquantity = do
-- | parse the two strings of digits before and after a possible decimal -- | parse the two strings of digits before and after a possible decimal
-- point. The integer part may contain commas, or either part may be -- point. The integer part may contain commas, or either part may be
-- empty, or there may be no point. -- empty, or there may be no point.
numberparts :: Parser (String,String) numberparts :: GenParser Char st (String,String)
numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint
numberpartsstartingwithdigit :: Parser (String,String) numberpartsstartingwithdigit :: GenParser Char st (String,String)
numberpartsstartingwithdigit = do numberpartsstartingwithdigit = do
let digitorcomma = digit <|> char ',' let digitorcomma = digit <|> char ','
first <- digit first <- digit
@ -403,7 +402,7 @@ numberpartsstartingwithdigit = do
frac <- try (do {char '.'; many digit >>= return}) <|> return "" frac <- try (do {char '.'; many digit >>= return}) <|> return ""
return (first:rest,frac) return (first:rest,frac)
numberpartsstartingwithpoint :: Parser (String,String) numberpartsstartingwithpoint :: GenParser Char st (String,String)
numberpartsstartingwithpoint = do numberpartsstartingwithpoint = do
char '.' char '.'
frac <- many1 digit frac <- many1 digit
@ -446,13 +445,13 @@ i 2007/03/10 12:26:00 hledger
o 2007/03/10 17:26:02 o 2007/03/10 17:26:02
-} -}
timelog :: Parser TimeLog timelog :: GenParser Char st TimeLog
timelog = do timelog = do
entries <- many timelogentry <?> "timelog entry" entries <- many timelogentry <?> "timelog entry"
eof eof
return $ TimeLog entries return $ TimeLog entries
timelogentry :: Parser TimeLogEntry timelogentry :: GenParser Char st TimeLogEntry
timelogentry = do timelogentry = do
many (commentline <|> blankline) many (commentline <|> blankline)
code <- oneOf "bhioO" code <- oneOf "bhioO"
@ -461,17 +460,17 @@ timelogentry = do
comment <- restofline comment <- restofline
return $ TimeLogEntry code datetime comment return $ TimeLogEntry code datetime comment
ledgerfromtimelog :: Parser RawLedger --ledgerfromtimelog :: GenParser Char st RawLedger
ledgerfromtimelog = do --ledgerfromtimelog = do
tl <- timelog -- tl <- timelog
return $ ledgerFromTimeLog tl -- return $ ledgerFromTimeLog tl
-- misc parsing -- misc parsing
-- | Parse a --display expression which is a simple date predicate, like -- | Parse a --display expression which is a simple date predicate, like
-- "d>[DATE]" or "d<=[DATE]", and return a transaction-matching predicate. -- "d>[DATE]" or "d<=[DATE]", and return a transaction-matching predicate.
datedisplayexpr :: Parser (Transaction -> Bool) datedisplayexpr :: GenParser Char st (Transaction -> Bool)
datedisplayexpr = do datedisplayexpr = do
char 'd' char 'd'
op <- compareop op <- compareop

66
Tests.hs
View File

@ -55,10 +55,10 @@ misc_tests = TestList [
assertequal (Amount (comm "$") 0 Nothing) (sum [a1,a2,a3,-a3]) assertequal (Amount (comm "$") 0 Nothing) (sum [a1,a2,a3,-a3])
, ,
"ledgertransaction" ~: do "ledgertransaction" ~: do
assertparseequal rawtransaction1 (parsewith ledgertransaction rawtransaction1_str) assertparseequal rawtransaction1 (parseWithCtx ledgertransaction rawtransaction1_str)
, ,
"ledgerentry" ~: do "ledgerentry" ~: do
assertparseequal entry1 (parsewith ledgerentry entry1_str) assertparseequal entry1 (parseWithCtx ledgerEntry entry1_str)
, ,
"balanceEntry" ~: do "balanceEntry" ~: do
assertequal assertequal
@ -87,15 +87,15 @@ misc_tests = TestList [
assertequal 15 (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7) assertequal 15 (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7)
, ,
"transactionamount" ~: do "transactionamount" ~: do
assertparseequal (Mixed [dollars 47.18]) (parsewith transactionamount " $47.18") assertparseequal (Mixed [dollars 47.18]) (parseWithCtx transactionamount " $47.18")
assertparseequal (Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]) (parsewith transactionamount " $1.") assertparseequal (Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]) (parseWithCtx transactionamount " $1.")
, ,
"canonicaliseAmounts" ~: do "canonicaliseAmounts" ~: do
-- all amounts use the greatest precision -- all amounts use the greatest precision
assertequal [2,2] (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) assertequal [2,2] (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"])
, ,
"timeLog" ~: do "timeLog" ~: do
assertparseequal timelog1 (parsewith timelog timelog1_str) assertparseequal timelog1 (parseWithCtx timelog timelog1_str)
, ,
"smart dates" ~: do "smart dates" ~: do
let todaysdate = parsedate "2008/11/26" -- wednesday let todaysdate = parsedate "2008/11/26" -- wednesday
@ -238,7 +238,7 @@ balancereportacctnames_tests = TestList
,"balancereportacctnames8" ~: ("-s",["-e"]) `gives` [] ,"balancereportacctnames8" ~: ("-s",["-e"]) `gives` []
] where ] where
gives (opt,pats) e = do gives (opt,pats) e = do
let l = sampleledger l <- sampleledger
let t = pruneZeroBalanceLeaves $ ledgerAccountTree 999 l let t = pruneZeroBalanceLeaves $ ledgerAccountTree 999 l
assertequal e (balancereportacctnames l (opt=="-s") pats t) assertequal e (balancereportacctnames l (opt=="-s") pats t)
@ -375,15 +375,15 @@ balancecommand_tests = TestList [
"") "")
, ,
"balance report with cost basis" ~: do "balance report with cost basis" ~: do
let l = cacheLedger [] $ rawl <- rawledgerfromstring
filterRawLedger (DateSpan Nothing Nothing) [] False False $
canonicaliseAmounts True $ -- enable cost basis adjustment
rawledgerfromstring
("" ++ ("" ++
"2008/1/1 test \n" ++ "2008/1/1 test \n" ++
" a:b 10h @ $50\n" ++ " a:b 10h @ $50\n" ++
" c:d \n" ++ " c:d \n" ++
"\n") "\n")
let l = cacheLedger [] $
filterRawLedger (DateSpan Nothing Nothing) [] False False $
canonicaliseAmounts True rawl -- enable cost basis adjustment
assertequal assertequal
(" $500 a\n" ++ (" $500 a\n" ++
" $-500 c\n" ++ " $-500 c\n" ++
@ -392,14 +392,14 @@ balancecommand_tests = TestList [
(showBalanceReport [] [] l) (showBalanceReport [] [] l)
] where ] where
gives (opts,args) e = do gives (opts,args) e = do
let l = sampleledgerwithopts [] args l <- sampleledgerwithopts [] args
assertequal e (showBalanceReport opts args l) assertequal e (showBalanceReport opts args l)
printcommand_tests = TestList [ printcommand_tests = TestList [
"print with account patterns" ~: "print with account patterns" ~:
do do
let args = ["expenses"] let args = ["expenses"]
let l = sampleledgerwithopts [] args l <- sampleledgerwithopts [] args
assertequal ( assertequal (
"2008/06/03 * eat & shop\n" ++ "2008/06/03 * eat & shop\n" ++
" expenses:food $1\n" ++ " expenses:food $1\n" ++
@ -412,6 +412,7 @@ printcommand_tests = TestList [
registercommand_tests = TestList [ registercommand_tests = TestList [
"register report" ~: "register report" ~:
do do
l <- sampleledger
assertequal ( assertequal (
"2008/01/01 income assets:checking $1 $1\n" ++ "2008/01/01 income assets:checking $1 $1\n" ++
" income:salary $-1 0\n" ++ " income:salary $-1 0\n" ++
@ -425,17 +426,21 @@ registercommand_tests = TestList [
"2008/12/31 pay off liabilities:debts $1 $1\n" ++ "2008/12/31 pay off liabilities:debts $1 $1\n" ++
" assets:checking $-1 0\n" ++ " assets:checking $-1 0\n" ++
"") "")
$ showRegisterReport [] [] sampleledger $ showRegisterReport [] [] l
, ,
"register report with account pattern" ~: "register report with account pattern" ~:
do do
l <- sampleledger
assertequal ( assertequal (
"2008/06/03 eat & shop assets:cash $-2 $-2\n" ++ "2008/06/03 eat & shop assets:cash $-2 $-2\n" ++
"") "")
$ showRegisterReport [] ["cash"] sampleledger $ showRegisterReport [] ["cash"] l
, ,
"register report with display expression" ~: "register report with display expression" ~:
do do
l <- sampleledger
let expr `displayexprgives` dates = assertequal dates (datesfromregister r)
where r = showRegisterReport [Display expr] [] l
"d<[2008/6/2]" `displayexprgives` ["2008/01/01","2008/06/01"] "d<[2008/6/2]" `displayexprgives` ["2008/01/01","2008/06/01"]
"d<=[2008/6/2]" `displayexprgives` ["2008/01/01","2008/06/01","2008/06/02"] "d<=[2008/6/2]" `displayexprgives` ["2008/01/01","2008/06/01","2008/06/02"]
"d=[2008/6/2]" `displayexprgives` ["2008/06/02"] "d=[2008/6/2]" `displayexprgives` ["2008/06/02"]
@ -444,12 +449,14 @@ registercommand_tests = TestList [
, ,
"register report with period expression" ~: "register report with period expression" ~:
do do
l <- sampleledger
let expr `displayexprgives` dates = assertequal dates (datesfromregister r)
where r = showRegisterReport [Display expr] [] l
"" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
"2008" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
"2007" `periodexprgives` [] "2007" `periodexprgives` []
"june" `periodexprgives` ["2008/06/01","2008/06/02","2008/06/03"] "june" `periodexprgives` ["2008/06/01","2008/06/02","2008/06/03"]
"monthly" `periodexprgives` ["2008/01/01","2008/06/01","2008/12/01"] "monthly" `periodexprgives` ["2008/01/01","2008/06/01","2008/12/01"]
assertequal ( assertequal (
"2008/01/01 - 2008/12/31 assets:cash $-2 $-2\n" ++ "2008/01/01 - 2008/12/31 assets:cash $-2 $-2\n" ++
" assets:saving $1 $-1\n" ++ " assets:saving $1 $-1\n" ++
@ -459,25 +466,18 @@ registercommand_tests = TestList [
" income:salary $-1 $-1\n" ++ " income:salary $-1 $-1\n" ++
" liabilities:debts $1 0\n" ++ " liabilities:debts $1 0\n" ++
"") "")
(showRegisterReport [Period "yearly"] [] sampleledger) (showRegisterReport [Period "yearly"] [] l)
assertequal ["2008/01/01","2008/04/01","2008/10/01"] assertequal ["2008/01/01","2008/04/01","2008/10/01"]
(datesfromregister $ showRegisterReport [Period "quarterly"] [] sampleledger) (datesfromregister $ showRegisterReport [Period "quarterly"] [] l)
assertequal ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] assertequal ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]
(datesfromregister $ showRegisterReport [Period "quarterly",Empty] [] sampleledger) (datesfromregister $ showRegisterReport [Period "quarterly",Empty] [] l)
] ]
where where datesfromregister = filter (not . null) . map (strip . take 10) . lines
expr `displayexprgives` dates = expr `periodexprgives` dates = do lopts <- sampleledgerwithopts [Period expr] []
assertequal dates (datesfromregister r) let r = showRegisterReport [Period expr] [] lopts
where assertequal dates (datesfromregister r)
r = showRegisterReport [Display expr] [] sampleledger
expr `periodexprgives` dates =
assertequal dates (datesfromregister r)
where
r = showRegisterReport [Period expr] [] l
l = sampleledgerwithopts [Period expr] []
datesfromregister = filter (not . null) . map (strip . take 10) . lines
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -486,7 +486,7 @@ registercommand_tests = TestList [
refdate = parsedate "2008/11/26" refdate = parsedate "2008/11/26"
sampleledger = ledgerfromstringwithopts [] [] refdate sample_ledger_str sampleledger = ledgerfromstringwithopts [] [] refdate sample_ledger_str
sampleledgerwithopts opts args = ledgerfromstringwithopts opts args refdate sample_ledger_str sampleledgerwithopts opts args = ledgerfromstringwithopts opts args refdate sample_ledger_str
sampleledgerwithoptsanddate opts args date = ledgerfromstringwithopts opts args date sample_ledger_str --sampleledgerwithoptsanddate opts args date = unsafePerformIO $ ledgerfromstringwithopts opts args date sample_ledger_str
sample_ledger_str = ( sample_ledger_str = (
"; A sample ledger file.\n" ++ "; A sample ledger file.\n" ++
@ -816,6 +816,7 @@ rawledger7 = RawLedger
epreceding_comment_lines="" epreceding_comment_lines=""
} }
] ]
[]
"" ""
ledger7 = cacheLedger [] rawledger7 ledger7 = cacheLedger [] rawledger7
@ -878,6 +879,7 @@ rawLedgerWithAmounts as =
[] []
[] []
[nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as] [nullentry{edescription=a,etransactions=[nullrawtxn{tamount=parse a}]} | a <- as]
[]
"" ""
where parse = fromparse . parsewith transactionamount . (" "++) where parse = fromparse . parseWithCtx transactionamount . (" "++)

14
Utils.hs
View File

@ -6,6 +6,7 @@ Utilities for top-level modules and/or ghci. See also "Ledger.Utils".
module Utils module Utils
where where
import Control.Monad.Error
import qualified Data.Map as Map (lookup) import qualified Data.Map as Map (lookup)
import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec
import System.IO import System.IO
@ -26,18 +27,18 @@ prepareLedger opts args refdate rl =
cb = CostBasis `elem` opts cb = CostBasis `elem` opts
-- | Get a RawLedger from the given string, or raise an error. -- | Get a RawLedger from the given string, or raise an error.
rawledgerfromstring :: String -> RawLedger rawledgerfromstring :: String -> IO RawLedger
rawledgerfromstring = fromparse . parsewith ledgerfile rawledgerfromstring = liftM (either error id) . runErrorT . parseLedger "(string)"
-- | Get a Ledger from the given string and options, or raise an error. -- | Get a Ledger from the given string and options, or raise an error.
ledgerfromstringwithopts :: [Opt] -> [String] -> Day -> String -> Ledger ledgerfromstringwithopts :: [Opt] -> [String] -> Day -> String -> IO Ledger
ledgerfromstringwithopts opts args refdate s = ledgerfromstringwithopts opts args refdate s =
prepareLedger opts args refdate $ rawledgerfromstring s liftM (prepareLedger opts args refdate) $ rawledgerfromstring s
-- | Get a Ledger from the given file path and options, or raise an error. -- | Get a Ledger from the given file path and options, or raise an error.
ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger
ledgerfromfilewithopts opts args f = do ledgerfromfilewithopts opts args f = do
rl <- readFile f >>= return . rawledgerfromstring rl <- readFile f >>= rawledgerfromstring
refdate <- today refdate <- today
return $ prepareLedger opts args refdate rl return $ prepareLedger opts args refdate rl
@ -45,3 +46,6 @@ ledgerfromfilewithopts opts args f = do
-- Assumes no options. -- Assumes no options.
myledger :: IO Ledger myledger :: IO Ledger
myledger = ledgerFilePathFromOpts [] >>= ledgerfromfilewithopts [] [] myledger = ledgerFilePathFromOpts [] >>= ledgerfromfilewithopts [] []
parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a
parseWithCtx p ts = runParser p emptyCtx "" ts