balance report, refactoring .. not finished but feeling paranoid about systems today\!

Account.hs

@@ -0,0 +1,102 @@
+
+module Account -- 
+where
+
+import Debug.Trace
+import Text.Printf
+import Text.Regex
+import Data.List
+
+import Utils
+
+-- AccountNames are strings like "assets:cash:petty"; from these we build
+-- the chart of accounts, which should be a simple hierarchy. We could
+-- almost get by with just these, but see below.
+type AccountName = String
+
+accountNameComponents :: AccountName -> [String]
+accountNameComponents = splitAtElement ':'
+
+accountNameFromComponents :: [String] -> AccountName
+accountNameFromComponents = concat . intersperse ":"
+
+accountLeafName :: AccountName -> String
+accountLeafName = rhead . accountNameComponents
+
+accountNameLevel :: AccountName -> Int
+accountNameLevel = length . accountNameComponents
+
+-- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
+expandAccountNames :: [AccountName] -> [AccountName]
+expandAccountNames as = nub $ concat $ map expand as
+    where expand as = map accountNameFromComponents (tail $ inits $ accountNameComponents as)
+
+-- ["a:b:c","d:e"] -> ["a","d"]
+topAccountNames :: [AccountName] -> [AccountName]
+topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
+
+parentAccountName :: AccountName -> Maybe AccountName
+parentAccountName a = 
+    case accountNameLevel a > 1 of
+      True -> Just $ accountNameFromComponents $ rtail $ accountNameComponents a
+      False -> Nothing
+
+s `isSubAccountNameOf` p = 
+    ((p ++ ":") `isPrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))
+
+subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]
+subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts
+
+matchAccountName :: String -> AccountName -> Bool
+matchAccountName s a =
+    case matchRegex (mkRegex s) a of
+      Nothing -> False
+      otherwise -> True
+
+-- We need structures smart enough to eg display the account tree with
+-- boring accounts elided.
+
+-- simple polymorphic tree. each node is a tuple of the node type and a
+-- list of subtrees
+newtype Tree a = Tree { unTree :: (a, [Tree a]) } deriving (Show,Eq)
+
+-- an Account has a name and a list of sub-accounts - ie a tree of
+-- AccountNames.
+type Account = Tree AccountName
+atacct = fst . unTree
+atsubs = snd . unTree
+nullacct = Tree ("", [])
+
+accountFrom :: [AccountName] -> Account
+accountFrom_props =
+    [
+     accountFrom [] == nullacct,
+     accountFrom ["a"] == Tree ("", [Tree ("a",[])]),
+     accountFrom ["a","b"] == Tree ("", [Tree ("a", []), Tree ("b", [])]),
+     accountFrom ["a","a:b"] == Tree ("", [Tree ("a", [Tree ("a:b", [])])]),
+     accountFrom ["a:b"] == Tree ("", [Tree ("a", [Tree ("a:b", [])])])
+    ]
+accountFrom accts = 
+    Tree ("top", accountsFrom (topAccountNames accts))
+        where
+          accountsFrom :: [AccountName] -> [Account]
+          accountsFrom [] = []
+          accountsFrom as = [Tree (a, accountsFrom $ subs a) | a <- as]
+          subs = (subAccountNamesFrom accts)
+
+showAccount :: Account -> String
+showAccount at = showAccounts $ atsubs at
+
+showAccounts :: [Account] -> String
+showAccounts ats =
+    concatMap showAccountBranch ats
+        where
+          showAccountBranch at = topacct ++ "\n" ++ subs
+              where
+                topacct = indentAccountName $ atacct at
+                subs = showAccounts $ atsubs at
+
+indentAccountName :: AccountName -> String
+indentAccountName a = replicate (((accountNameLevel a) - 1) * 2) ' ' ++ (accountLeafName a)
+
+

Models.hs

@@ -2,17 +2,18 @@
 module Models -- data types & behaviours
 where
 
+import Debug.Trace
 import Text.Printf
 import Text.Regex
 import Data.List
 
 import Utils
+import Account
 
 -- basic types
 
 type Date = String
 type Status = Bool
-type Account = String
 
 -- amounts
 -- amount arithmetic currently ignores currency conversion
@@ -98,15 +99,15 @@ autofillEntry e =
 -- transactions
 
 data Transaction = Transaction {
-                                taccount :: Account,
+                                taccount :: AccountName,
                                 tamount :: Amount
                                } deriving (Eq,Ord)
 
 instance Show Transaction where show = showTransaction
 
-showTransaction t = (showAccount $ taccount t) ++ "  " ++ (showAmount $ tamount t) 
+showTransaction t = (showAccountName $ taccount t) ++ "  " ++ (showAmount $ tamount t) 
 showAmount amt = printf "%11s" (show amt)
-showAccount s = printf "%-22s" (elideRight 22 s)
+showAccountName s = printf "%-22s" (elideRight 22 s)
 
 elideRight width s =
     case length s > width of
@@ -158,6 +159,10 @@ flattenEntry e = [(e,t) | t <- etransactions e]
 entryTransactionsFrom :: [Entry] -> [EntryTransaction]
 entryTransactionsFrom es = concat $ map flattenEntry es
 
+sumEntryTransactions :: [EntryTransaction] -> Amount
+sumEntryTransactions ets = 
+    sumTransactions $ map transaction ets
+
 matchTransactionAccount :: String -> EntryTransaction -> Bool
 matchTransactionAccount s t =
     case matchRegex (mkRegex s) (account t) of
@@ -192,18 +197,127 @@ showTransactionAndBalance :: EntryTransaction -> Amount -> String
 showTransactionAndBalance t b =
     (replicate 32 ' ') ++ (showTransaction $ transaction t) ++ (showBalance b)
 
+showBalance :: Amount -> String
 showBalance b = printf " %12s" (amountRoundedOrZero b)
 
--- accounts
+-- more account functions
+
+accountNamesFromTransactions :: [EntryTransaction] -> [AccountName]
+accountNamesFromTransactions ts = nub $ map account ts
+
+-- like expandAccountNames, but goes from the top down and elides accountNames
+-- with only one child and no transactions. Returns accountNames paired with
+-- the appropriate indented name. Eg
+-- [("assets","assets"),("assets:cash:gifts","  cash:gifts"),("assets:checking","  checking")]
+expandAccountNamesMostly :: Ledger -> [AccountName] -> [(AccountName, String)]
+expandAccountNamesMostly l as = concat $ map (expandAccountNameMostly l) as
+    where 
+      expandAccountNameMostly :: Ledger -> AccountName -> [(AccountName, String)]
+      expandAccountNameMostly l a =
+          [(acct, acctname)] ++ (concat $ map (expandAccountNameMostly l) subs)
+              where 
+                subs = subAccountNames l a
+                txns = accountTransactionsNoSubs l a
+                (acct, acctname) = 
+                    case (length subs == 1) && (length txns == 0) of
+                      False -> (a, indentAccountName a)
+                      True -> (a, indentAccountName a ++ ":" ++ subname)
+                        where 
+                          sub = head subs
+                          subname = (reverse . takeWhile (/= ':') . reverse) sub
+
+subAccountNames :: Ledger -> AccountName -> [AccountName]
+subAccountNames l a = [a' | a' <- ledgerAccountNames l, a `isSubAccountNameOf` a']
+
+showAccountNamesWithBalances :: [(AccountName,String)] -> Ledger -> String
+showAccountNamesWithBalances as l =
+    unlines $ map (showAccountNameAndBalance l) as
+
+showAccountNameAndBalance :: Ledger -> (AccountName, String) -> String
+showAccountNameAndBalance l (a, adisplay) =
+    printf "%20s  %s" (showBalance $ accountBalance l a) adisplay
+
+accountBalance :: Ledger -> AccountName -> Amount
+accountBalance l a =
+    sumEntryTransactions (accountTransactions l a)
+
+accountTransactions :: Ledger -> AccountName -> [EntryTransaction]
+accountTransactions l a = ledgerTransactionsMatching (["^" ++ a ++ "(:.+)?$"], []) l
+
+accountBalanceNoSubs :: Ledger -> AccountName -> Amount
+accountBalanceNoSubs l a =
+    sumEntryTransactions (accountTransactionsNoSubs l a)
+
+accountTransactionsNoSubs :: Ledger -> AccountName -> [EntryTransaction]
+accountTransactionsNoSubs l a = ledgerTransactionsMatching (["^" ++ a ++ "$"], []) l
+
+addDataToAccounts :: Ledger -> (Tree AccountName) -> (Tree AccountData)
+addDataToAccounts l acct = 
+    Tree (acctdata, map (addDataToAccounts l) (atsubs acct))
+        where 
+          aname = atacct acct
+          atxns = accountTransactionsNoSubs l aname
+          abal = accountBalance l aname
+          acctdata = (aname, atxns, abal)
+
+-- an AccountData tree adds some other things we want to cache for
+-- convenience, like the account's balance and transactions.
+type AccountData = (AccountName,[EntryTransaction],Amount)
+type AccountDataTree = Tree AccountData
+adtdata = fst . unTree
+adtsubs = snd . unTree
+nullad = Tree (("", [], 0), [])
+adname (a,_,_) = a
+adtxns (_,ts,_) = ts
+adamt (_,_,amt) = amt
+
+-- a (2 txns)
+--   b (boring acct - 0 txns, exactly 1 sub)
+--     c (5 txns)
+--       d
+-- to:
+-- a (2 txns)
+--   b:c (5 txns)
+--     d
+
+-- elideAccount adt = adt
+
+-- elideAccount :: Tree AccountData -> Tree AccountData
+-- elideAccount adt = adt
+    
+
+-- a
+--   b
+--     c
+-- d
+-- to:
+-- $7  a
+-- $5    b
+-- $5      c
+-- $0  d
+showAccountWithBalances :: Ledger -> (Tree AccountData) -> String
+showAccountWithBalances l adt = (showAccountsWithBalance l) (adtsubs adt)
+
+showAccountsWithBalance :: Ledger -> [Tree AccountData] -> String
+showAccountsWithBalance l adts =
+    concatMap showAccountDataBranch adts
+        where
+          showAccountDataBranch :: Tree AccountData -> String
+          showAccountDataBranch adt = 
+              case boring of
+                True  -> 
+                False -> topacct ++ "\n" ++ subs
+              where
+                topacct = (showAmount abal) ++ "  " ++ (indentAccountName aname)
+                showAmount amt = printf "%11s" (show amt)
+                aname = adname $ adtdata adt
+                atxns = adtxns $ adtdata adt
+                abal = adamt $ adtdata adt
+                subs = (showAccountsWithBalance l) $ adtsubs adt
+                boring = (length atxns == 0) && ((length subs) == 1)
+
     
-accountsFromTransactions :: [EntryTransaction] -> [Account]
-accountsFromTransactions ts = nub $ map account ts
 
--- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
-expandAccounts :: [Account] -> [Account]
-expandAccounts l = nub $ concat $ map expand l
-                where
-                  expand l' = map (concat . intersperse ":") (tail $ inits $ splitAtElement ':' l')
 
 -- ledger
 
@@ -223,12 +337,6 @@ instance Show Ledger where
                        p = show $ length $ periodic_entries l
                        e = show $ length $ entries l
 
-ledgerAccountsUsed :: Ledger -> [Account]
-ledgerAccountsUsed l = accountsFromTransactions $ entryTransactionsFrom $ entries l
-
-ledgerAccountTree :: Ledger -> [Account]
-ledgerAccountTree = sort . expandAccounts . ledgerAccountsUsed
-
 ledgerTransactions :: Ledger -> [EntryTransaction]
 ledgerTransactions l = entryTransactionsFrom $ entries l
 
@@ -241,3 +349,28 @@ ledgerTransactionsMatching (acctregexps,descregexps) l =
     (concat [filter (matchTransactionAccount r) ts | r <- acctregexps])
     (concat [filter (matchTransactionDescription r) ts | r <- descregexps])
     where ts = ledgerTransactions l
+
+ledgerAccountNamesUsed :: Ledger -> [AccountName]
+ledgerAccountNamesUsed l = accountNamesFromTransactions $ entryTransactionsFrom $ entries l
+
+ledgerAccountNames :: Ledger -> [AccountName]
+ledgerAccountNames = sort . expandAccountNames . ledgerAccountNamesUsed
+
+ledgerTopAccountNames :: Ledger -> [AccountName]
+ledgerTopAccountNames l = filter (notElem ':') (ledgerAccountNames l)
+
+ledgerAccountNamesMatching :: [String] -> Ledger -> [AccountName]
+ledgerAccountNamesMatching [] l = ledgerAccountNamesMatching [".*"] l
+ledgerAccountNamesMatching acctregexps l =
+    concat [filter (matchAccountName r) accountNames | r <- acctregexps]
+        where accountNames = ledgerTopAccountNames l
+
+ledgerAccounts :: Ledger -> Tree AccountName
+ledgerAccounts l = accountFrom $ ledgerAccountNames l
+
+ledgerAccountsData :: Ledger -> Tree AccountData
+ledgerAccountsData l = addDataToAccounts l (ledgerAccounts l)
+
+showLedgerAccountsWithBalances :: Ledger -> String
+showLedgerAccountsWithBalances l =
+    showAccountWithBalances l (ledgerAccountsData l)

Options.hs

@@ -8,12 +8,14 @@ import System.Environment (getEnv)
     
 import Utils
 
-data Flag = File String | Version deriving Show
+data Flag = Version | File String | ShowSubs 
+            deriving (Show,Eq)
     
 options :: [OptDescr Flag]
 options = [
-            Option ['f'] ["file"]    (OptArg inp "FILE") "ledger file, or - to read stdin"
+            Option ['v'] ["version"] (NoArg Version)     "show version number"
-          , Option ['v'] ["version"] (NoArg Version)     "show version number"
+          , Option ['f'] ["file"]    (OptArg inp "FILE") "ledger file, or - to read stdin"
+          , Option ['s'] ["subtotal"] (NoArg ShowSubs)     "balance: show sub-accounts; other: show subtotals"
           ]
 
 inp :: Maybe String -> Flag

TODO

@@ -1,13 +1,18 @@
-features
+basic features
  balance
-  show top-level acct balances
+  show balances with new tree structures
-  show all account balances
+  elide empty accounts
  print
  entry
  -j and -J graph data output
- svn-style elision
  !include
  read timelog files
+
+make it fast
+ profile
+
+more features
+ svn-style elision
  -p period expressions
  -d display expressions
  read gnucash files
@@ -18,7 +23,7 @@ new features
  smart data entry
 
 tests
- better use of quickcheck
+ better use of quickcheck/smallcheck
  ledger compatibility tests
 
 docs

Tests.hs

@@ -11,6 +11,7 @@ import Test.HUnit
 
 import Options
 import Models
+import Account
 import Parse
 
 -- sample data
@@ -203,8 +204,8 @@ tests = let t l f = TestLabel l $ TestCase f in TestList
           t "test_ledgertransaction" test_ledgertransaction
         , t "test_ledgerentry" test_ledgerentry
         , t "test_autofillEntry" test_autofillEntry
-        , t "test_expandAccounts" test_expandAccounts
+        , t "test_expandAccountNames" test_expandAccountNames
-        , t "test_accountTree" test_accountTree
+        , t "test_ledgerAccountNames" test_ledgerAccountNames
         ]
 
 tests2 = Test.HUnit.test 
@@ -224,15 +225,15 @@ test_autofillEntry =
     (Amount "$" (-47.18))
     (tamount $ last $ etransactions $ autofillEntry entry1)
 
-test_expandAccounts =
+test_expandAccountNames =
     assertEqual'
     ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
-    (expandAccounts ["assets:cash","assets:checking","expenses:vacation"])
+    (expandAccountNames ["assets:cash","assets:checking","expenses:vacation"])
 
-test_accountTree =
+test_ledgerAccountNames =
     assertEqual'
     ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
-    (ledgerAccountTree ledger7)
+    (ledgerAccountNames ledger7)
 
 -- quickcheck properties
 
@@ -241,7 +242,7 @@ props =
      parse' ledgertransaction transaction1_str `parseEquals`
      (Transaction "expenses:food:dining" (Amount "$" 10))
     ,
-     ledgerAccountTree ledger7 == 
+     ledgerAccountNames ledger7 == 
      ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
     ,
      ledgerPatternArgs [] == ([],[])

hledger.hs

@@ -14,6 +14,7 @@ import Text.ParserCombinators.Parsec (parseFromFile, ParseError)
 
 import Options
 import Models
+import Account
 import Parse
 import Tests
 
@@ -21,11 +22,11 @@ main :: IO ()
 main = do
   (opts, args) <- (getArgs >>= getOptions)
   if args == []
-    then register []
+    then register [] []
     else
       let (command, args') = (head args, tail args) in
-      if "reg" `isPrefixOf` command then (register args')
+      if "reg" `isPrefixOf` command then (register opts args')
-      else if "bal" `isPrefixOf` command then balance args'
+      else if "bal" `isPrefixOf` command then balance opts args'
            else if "test" `isPrefixOf` command then test
                 else error "could not recognise your command"
 
@@ -35,19 +36,17 @@ test :: IO ()
 test = do
   hcounts <- runTestTT tests
   qcounts <- mapM quickCheck props
-  --print $ "hunit: " ++ (showHunitCounts hcounts)
-  --print $ "quickcheck: " ++ (concat $ intersperse " " $ map show qcounts)
   return ()
     where showHunitCounts c =
               reverse $ tail $ reverse ("passed " ++ (unwords $ drop 5 $ words (show c)))
 
-register :: [String] -> IO ()
+register :: [Flag] -> [String] -> IO ()
-register args = do 
+register opts args = do 
-  getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister args)
+  getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printRegister opts args)
 
-balance :: [String] -> IO ()
+balance :: [Flag] -> [String] -> IO ()
-balance args = 
+balance opts args = do
-    return ()
+  getLedgerFilePath >>= parseLedgerFile >>= doWithParsed (printBalance opts args)
 
 -- utils
 
@@ -55,13 +54,23 @@ balance args =
 --     getLedgerFilePath >>= parseLedgerFile >>= doWithParsed
 
 doWithParsed :: (a -> IO ()) -> (Either ParseError a) -> IO ()
-doWithParsed a p = 
+doWithParsed a p = do
   case p of Left e -> parseError e
             Right v -> a v
 
-printRegister :: [String] -> Ledger -> IO ()
+printRegister :: [Flag] -> [String] -> Ledger -> IO ()
-printRegister args ledger =
+printRegister opts args ledger = do
-    putStr $ showTransactionsWithBalances 
+  putStr $ showTransactionsWithBalances 
-               (ledgerTransactionsMatching (acctpats,descpats) ledger)
+             (ledgerTransactionsMatching (acctpats,descpats) ledger)
-               0
+             0
-        where (acctpats,descpats) = ledgerPatternArgs args
+      where (acctpats,descpats) = ledgerPatternArgs args
+
+printBalance :: [Flag] -> [String] -> Ledger -> IO ()
+printBalance opts args ledger = do
+  putStr $ showLedgerAccountsWithBalances ledger
+      where 
+        (acctpats,_) = ledgerPatternArgs args
+        showsubs = (ShowSubs `elem` opts)
+        accounts = case showsubs of
+                     True -> expandAccountNamesMostly ledger (ledgerTopAccountNames ledger)
+                     False -> [(a,indentAccountName a) | a <- ledgerAccountNamesMatching acctpats ledger]