Support for !account directives, and tests

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"
+ledgerInclude = do many1 spacenonewline
-                   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

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",