From 600582184c01e5ba55a7a36e7baa7ce6a63c6245 Mon Sep 17 00:00:00 2001 From: nick Date: Mon, 8 Dec 2008 07:21:33 +0000 Subject: [PATCH] Support for !account directives, and tests --- Ledger/Parse.hs | 62 +++++++++++++++++++++++++++++++++++++++---------- Tests.hs | 28 ++++++++++++++++++++++ 2 files changed, 78 insertions(+), 12 deletions(-) diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index e8e8189f7..60d7bf4d9 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -46,16 +46,34 @@ data LedgerFileCtx = Ctx { ctxYear :: !(Maybe Integer) 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 + parseLedger :: FilePath -> String -> ErrorT String IO RawLedger parseLedger inname intxt = case runParser ledgerFile emptyCtx inname intxt of Right m -> liftM rawLedgerConvertTimeLog $ m `ap` (return rawLedgerEmpty) Left err -> throwError $ show err +-- As all ledger line types can be distinguished by the first +-- character, excepting transactions versus empty (blank or +-- comment-only) lines, can use choice w/o try + ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) ledgerFile = do entries <- many1 ledgerAnyEntry eof return $ liftM (foldr1 (.)) $ sequence entries - where ledgerAnyEntry = choice [ ledgerInclude + where ledgerAnyEntry = choice [ ledgerDirective , liftM (return . addEntry) ledgerEntry , liftM (return . addModifierEntry) ledgerModifierEntry , liftM (return . addPeriodicEntry) ledgerPeriodicEntry @@ -64,9 +82,16 @@ ledgerFile = do entries <- many1 ledgerAnyEntry , liftM (return . addTimeLogEntry) timelogentry ] +ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerDirective = do char '!' + directive <- many nonspace + case directive of + "include" -> ledgerInclude + "account" -> ledgerAccountBegin + "end" -> ledgerAccountEnd + ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) -ledgerInclude = do string "!include" - many1 spacenonewline +ledgerInclude = do many1 spacenonewline filename <- restofline outerState <- getState outerPos <- getPosition @@ -80,8 +105,15 @@ ledgerInclude = do string "!include" currentPos = show outerPos whileReading = " reading " ++ show filename ++ ":\n" +ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerAccountBegin = do many1 spacenonewline + parent <- ledgeraccountname + newline + pushParentAccount parent + return $ return id ---ledgerEntry = return $ throwError "unimplemented" +ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) +ledgerAccountEnd = popParentAccount >> return (return id) -- parsers @@ -276,36 +308,38 @@ ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> ret ledgercode :: GenParser Char st String ledgercode = try (do { char '('; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return "" -ledgertransactions :: GenParser Char st [RawTransaction] +ledgertransactions :: GenParser Char LedgerFileCtx [RawTransaction] ledgertransactions = many $ try ledgertransaction -ledgertransaction :: GenParser Char st RawTransaction +ledgertransaction :: GenParser Char LedgerFileCtx RawTransaction ledgertransaction = many1 spacenonewline >> choice [ normaltransaction, virtualtransaction, balancedvirtualtransaction ] -normaltransaction :: GenParser Char st RawTransaction +normaltransaction :: GenParser Char LedgerFileCtx RawTransaction normaltransaction = do - account <- ledgeraccountname + account <- transactionaccountname amount <- transactionamount many spacenonewline comment <- ledgercomment restofline + parent <- getParentAccount return (RawTransaction account amount comment RegularTransaction) -virtualtransaction :: GenParser Char st RawTransaction +virtualtransaction :: GenParser Char LedgerFileCtx RawTransaction virtualtransaction = do char '(' - account <- ledgeraccountname + account <- transactionaccountname char ')' amount <- transactionamount many spacenonewline comment <- ledgercomment restofline + parent <- getParentAccount return (RawTransaction account amount comment VirtualTransaction) -balancedvirtualtransaction :: GenParser Char st RawTransaction +balancedvirtualtransaction :: GenParser Char LedgerFileCtx RawTransaction balancedvirtualtransaction = do char '[' - account <- ledgeraccountname + account <- transactionaccountname char ']' amount <- transactionamount many spacenonewline @@ -313,6 +347,10 @@ balancedvirtualtransaction = do restofline return (RawTransaction account amount comment BalancedVirtualTransaction) +-- Qualify with the parent account from parsing context +transactionaccountname :: GenParser Char LedgerFileCtx AccountName +transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname + -- | account names may have single spaces inside them, and are terminated by two or more spaces ledgeraccountname :: GenParser Char st String ledgeraccountname = do diff --git a/Tests.hs b/Tests.hs index e2e609112..5e54ea7b7 100644 --- a/Tests.hs +++ b/Tests.hs @@ -31,6 +31,7 @@ runtests opts args = do tests = [TestList [] ,misc_tests + ,newparse_tests ,balancereportacctnames_tests ,balancecommand_tests ,printcommand_tests @@ -229,6 +230,33 @@ misc_tests = TestList [ assertparseequal price1 (parseWithCtx ledgerHistoricalPrice price1_str) ] +newparse_tests = TestList [ sameParseTests ] + where sameParseTests = TestList $ map sameParse [ account1, account2, account3, account4 ] + sameParse (str1, str2) + = TestCase $ do l1 <- rawledgerfromstring str1 + l2 <- rawledgerfromstring str2 + (l1 @=? l2) + account1 = ( "2008/12/07 One\n test:from $-1\n test:to $1\n" + , "!account test\n2008/12/07 One\n from $-1\n to $1\n" + ) + account2 = ( "2008/12/07 One\n test:foo:from $-1\n test:foo:to $1\n" + , "!account test\n!account foo\n2008/12/07 One\n from $-1\n to $1\n" + ) + account3 = ( "2008/12/07 One\n test:from $-1\n test:to $1\n" + , "!account test\n!account foo\n!end\n2008/12/07 One\n from $-1\n to $1\n" + ) + account4 = ( "2008/12/07 One\n alpha $-1\n beta $1\n" ++ + "!account outer\n2008/12/07 Two\n aigh $-2\n bee $2\n" ++ + "!account inner\n2008/12/07 Three\n gamma $-3\n delta $3\n" ++ + "!end\n2008/12/07 Four\n why $-4\n zed $4\n" ++ + "!end\n2008/12/07 Five\n foo $-5\n bar $5\n" + , "2008/12/07 One\n alpha $-1\n beta $1\n" ++ + "2008/12/07 Two\n outer:aigh $-2\n outer:bee $2\n" ++ + "2008/12/07 Three\n outer:inner:gamma $-3\n outer:inner:delta $3\n" ++ + "2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" ++ + "2008/12/07 Five\n foo $-5\n bar $5\n" + ) + balancereportacctnames_tests = TestList [ "balancereportacctnames0" ~: ("-s",[]) `gives` ["assets","assets:cash","assets:checking","assets:saving",