refactor, fix balance report

Account.hs

@@ -1,17 +1,11 @@
 
 module Account
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
+import BasicTypes
 
 -- AccountNames are strings like "assets:cash:petty"; from these we build
--- the chart of accounts, which should be a simple hierarchy. We could
+-- the chart of accounts, which should be a simple hierarchy. 
--- almost get by with just these, but see below.
 type AccountName = String
 
 accountNameComponents :: AccountName -> [String]
@@ -53,50 +47,43 @@ matchAccountName s a =
       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)
 
 
+-- We could almost get by with just the above, but we need smarter
+-- structures to eg display the account tree with boring accounts elided.
+-- first, here is a tree of AccountNames; Account and Account tree are
+-- defined later.
+
+antacctname = fst . node
+antsubs = snd . node
+
+accountNameTreeFrom_props =
+    [
+     accountNameTreeFrom ["a"] == Tree ("top", [Tree ("a",[])]),
+     accountNameTreeFrom ["a","b"] == Tree ("top", [Tree ("a", []), Tree ("b", [])]),
+     accountNameTreeFrom ["a","a:b"] == Tree ("top", [Tree ("a", [Tree ("a:b", [])])]),
+     accountNameTreeFrom ["a:b"] == Tree ("top", [Tree ("a", [Tree ("a:b", [])])])
+    ]
+accountNameTreeFrom :: [AccountName] -> Tree AccountName
+accountNameTreeFrom accts = 
+    Tree ("top", accountsFrom (topAccountNames accts))
+        where
+          accountsFrom :: [AccountName] -> [Tree AccountName]
+          accountsFrom [] = []
+          accountsFrom as = [Tree (a, accountsFrom $ subs a) | a <- as]
+          subs = (subAccountNamesFrom accts)
+
+showAccountNameTree :: Tree AccountName -> String
+showAccountNameTree at = showAccountNameTrees $ antsubs at
+
+showAccountNameTrees :: [Tree AccountName] -> String
+showAccountNameTrees ats =
+    concatMap showAccountNameBranch ats
+        where
+          showAccountNameBranch at = topacct ++ "\n" ++ subs
+              where
+                topacct = indentAccountName $ antacctname at
+                subs = showAccountNameTrees $ antsubs at
+

BasicTypes.hs

@@ -1,12 +1,6 @@
 
 module BasicTypes
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
 
 
@@ -42,3 +36,8 @@ amountRoundedOrZero (Amount cur qty) =
       "-0.00"   -> "0"
       otherwise -> cur ++ rounded
 
+-- generic tree. each node is a tuple of the node type and a
+-- list of subtrees
+newtype Tree a = Tree { node :: (a, [Tree a]) } deriving (Show,Eq)
+branches = snd . node
+

Entry.hs

@@ -1,12 +1,6 @@
 
 module Entry
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
 import BasicTypes
 import Transaction

EntryTransaction.hs

@@ -1,15 +1,8 @@
 
 module EntryTransaction
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
 import BasicTypes
-import Account
 import Entry
 import Transaction
 
@@ -40,9 +33,6 @@ sumEntryTransactions :: [EntryTransaction] -> Amount
 sumEntryTransactions ets = 
     sumTransactions $ map transaction ets
 
-accountNamesFromTransactions :: [EntryTransaction] -> [AccountName]
-accountNamesFromTransactions ts = nub $ map account ts
-
 matchTransactionAccount :: String -> EntryTransaction -> Bool
 matchTransactionAccount s t =
     case matchRegex (mkRegex s) (account t) of

Ledger.hs

@@ -1,13 +1,8 @@
 module Ledger
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
 import Account
+import BasicTypes
 import Entry
 import EntryTransaction
 
@@ -37,6 +32,9 @@ ledgerTransactionsMatching (acctregexps,descregexps) l =
     (concat [filter (matchTransactionDescription r) ts | r <- descregexps])
     where ts = ledgerTransactions l
 
+accountNamesFromTransactions :: [EntryTransaction] -> [AccountName]
+accountNamesFromTransactions ts = nub $ map account ts
+
 ledgerAccountNamesUsed :: Ledger -> [AccountName]
 ledgerAccountNamesUsed l = accountNamesFromTransactions $ entryTransactionsFrom $ entries l
 
@@ -52,18 +50,8 @@ ledgerAccountNamesMatching acctregexps l =
     concat [filter (matchAccountName r) accountNames | r <- acctregexps]
         where accountNames = ledgerTopAccountNames l
 
-ledgerAccounts :: Ledger -> Tree AccountName
+ledgerAccountNameTree :: Ledger -> Tree AccountName
-ledgerAccounts l = accountFrom $ ledgerAccountNames l
+ledgerAccountNameTree l = accountNameTreeFrom $ ledgerAccountNames l
 
-showLedgerAccounts :: Ledger -> [String] -> Int -> String
-showLedgerAccounts l acctpats depth = 
-    showAccountsWithBalances l accounts depth
-        where
-          accounts = ledgerAccountsMatching l acctpats
 
-showAccountsWithBalances :: Ledger -> [Account] -> Int -> String
-showAccountsWithBalances l accts depth =
-    ""
 
-ledgerAccountsMatching :: Ledger -> [String] -> [Account]
-ledgerAccountsMatching l acctpats = []

Models.hs

@@ -9,12 +9,6 @@ module Models (
                module BasicTypes,
               )
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
 import BasicTypes
 import Account
@@ -24,9 +18,30 @@ import EntryTransaction
 import Ledger
 
 
--- any top-level stuff that mixed up the other types
+-- top-level stuff that mixes types
 
 
+-- an Account caches an account's name, balance and transactions for convenience
+type Account = (AccountName,[EntryTransaction],Amount)
+aname (a,_,_) = a
+atxns (_,ts,_) = ts
+abal (_,_,b) = b
+
+mkAccount :: Ledger -> AccountName -> Account
+mkAccount l a = (a, accountNameTransactionsNoSubs l a, accountNameBalance l a)
+
+accountNameBalance :: Ledger -> AccountName -> Amount
+accountNameBalance l a = sumEntryTransactions (accountNameTransactions l a)
+
+accountNameTransactions :: Ledger -> AccountName -> [EntryTransaction]
+accountNameTransactions l a = ledgerTransactionsMatching (["^" ++ a ++ "(:.+)?$"], []) l
+
+accountNameBalanceNoSubs :: Ledger -> AccountName -> Amount
+accountNameBalanceNoSubs l a = sumEntryTransactions (accountNameTransactionsNoSubs l a)
+
+accountNameTransactionsNoSubs :: Ledger -> AccountName -> [EntryTransaction]
+accountNameTransactionsNoSubs l a = ledgerTransactionsMatching (["^" ++ a ++ "$"], []) l
+
 -- showAccountNamesWithBalances :: [(AccountName,String)] -> Ledger -> String
 -- showAccountNamesWithBalances as l =
 --     unlines $ map (showAccountNameAndBalance l) as
@@ -35,40 +50,42 @@ import Ledger
 -- 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]
+-- a tree of Accounts
-accountTransactions l a = ledgerTransactionsMatching (["^" ++ a ++ "(:.+)?$"], []) l
 
-accountBalanceNoSubs :: Ledger -> AccountName -> Amount
+atacct = fst . node
-accountBalanceNoSubs l a =
-    sumEntryTransactions (accountTransactionsNoSubs l a)
 
-accountTransactionsNoSubs :: Ledger -> AccountName -> [EntryTransaction]
+addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account
-accountTransactionsNoSubs l a = ledgerTransactionsMatching (["^" ++ a ++ "$"], []) l
+addDataToAccountNameTree l ant = 
-
+    Tree (mkAccount l aname, map (addDataToAccountNameTree l) (antsubs ant))
-addDataToAccounts :: Ledger -> (Tree AccountName) -> (Tree AccountData)
-addDataToAccounts l acct = 
-    Tree (acctdata, map (addDataToAccounts l) (atsubs acct))
         where 
-          acctdata = (aname, atxns, abal)
+          aname = antacctname ant
-          aname = atacct acct
-          atxns = accountTransactionsNoSubs l aname
-          abal = accountBalance l aname
 
--- an AccountData tree adds some other things we want to cache for
+showAccountTreeWithBalances :: Ledger -> Int -> Tree Account -> String
--- convenience, like the account's balance and transactions.
+showAccountTreeWithBalances l depth at = (showAccountTreesWithBalances l depth) (branches at)
-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
 
+showAccountTreesWithBalances :: Ledger -> Int -> [Tree Account] -> String
+showAccountTreesWithBalances _ 0 _ = ""
+showAccountTreesWithBalances l depth ats =
+    concatMap showAccountBranch ats
+        where
+          showAccountBranch :: Tree Account -> String
+          showAccountBranch at = 
+              topacct ++ "\n" ++ subaccts
+--               case boring of
+--                 True  -> 
+--                 False -> 
+              where
+                topacct = (showAmount bal) ++ "  " ++ (indentAccountName name)
+                showAmount amt = printf "%20s" (show amt)
+                name = aname $ atacct at
+                txns = atxns $ atacct at
+                bal = abal $ atacct at
+                subaccts = (showAccountTreesWithBalances l (depth - 1)) $ branches at
+                boring = (length txns == 0) && ((length subaccts) == 1)
+
+-- we want to elide boring accounts in the account tree
+--
 -- a (2 txns)
 --   b (boring acct - 0 txns, exactly 1 sub)
 --     c (5 txns)
@@ -78,46 +95,18 @@ adamt (_,_,amt) = amt
 --   b:c (5 txns)
 --     d
 
--- elideAccount adt = adt
+-- elideAccountTree at = at
 
--- elideAccount :: Tree AccountData -> Tree AccountData
+elideAccountTree :: Tree Account -> Tree Account
--- elideAccount adt = adt
+elideAccountTree = id
-    
 
--- a
+ledgerAccountTree :: Ledger -> Tree Account
---   b
+ledgerAccountTree l = elideAccountTree $ addDataToAccountNameTree l (ledgerAccountNameTree l)
---     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
+ledgerAccountsMatching :: Ledger -> [String] -> [Account]
-showAccountsWithBalance l adts =
+ledgerAccountsMatching l acctpats = undefined
-    concatMap showAccountDataBranch adts
-        where
-          showAccountDataBranch :: Tree AccountData -> String
-          showAccountDataBranch adt = 
-              topacct ++ "\n" ++ subs
---               case boring of
---                 True  -> 
---                 False -> 
-              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)
 
-ledgerAccountsData :: Ledger -> Tree AccountData
+showLedgerAccounts :: Ledger -> Int -> String
-ledgerAccountsData l = addDataToAccounts l (ledgerAccounts l)
+showLedgerAccounts l depth = 
+    showAccountTreeWithBalances l depth (ledgerAccountTree l)
 
-showLedgerAccountsWithBalances :: Ledger -> Tree AccountData -> String
-showLedgerAccountsWithBalances l adt =
-    showAccountWithBalances l adt

Options.hs

@@ -1,21 +1,21 @@
 
 module Options (module Options, usageInfo)
 where
-    
 import System.Console.GetOpt
-import Data.Maybe ( fromMaybe )
 import System.Environment (getEnv)
+import Data.Maybe (fromMaybe)
     
 import Utils
 
-data Flag = Version | File String | ShowSubs 
+
+data Flag = Version | File String | ShowSubs
             deriving (Show,Eq)
     
 options :: [OptDescr Flag]
 options = [
             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; register: show subtotals"
+          , Option ['s'] ["subtotal"] (NoArg ShowSubs)     "balance: show sub-accounts" --; register: show subtotals"
           ]
 
 inp :: Maybe String -> Flag
@@ -47,5 +47,8 @@ ledgerPatternArgs args =
       True -> ((takeWhile (/= "--") args), tail $ (dropWhile (/= "--") args))
       False -> (args,[])
 
-depthOption :: [Flag] -> Int
+getDepth :: [Flag] -> Int
-depthOption opts = 1
+getDepth opts = 
+    maximum $ [1] ++ map depthval opts where
+        depthval (ShowSubs) = 9999
+        depthval _ = 1

Parse.hs

@@ -1,12 +1,11 @@
 
 module Parse
 where
-
 import Text.ParserCombinators.Parsec
 import Text.ParserCombinators.Parsec.Language
 import qualified Text.ParserCombinators.Parsec.Token as P
-import Text.Printf
 
+import Utils
 import Models
 
 {-

TODO

@@ -1,4 +1,6 @@
 cleanup/reorganize
+ Entry/Transaction/EntryTransaction
+
 hledger
  Options
  Tests
@@ -14,8 +16,8 @@ hledger
 
 basic features
  balance
-  show balances with new tree structures
+  elide boring accounts
-  elide empty accounts
+ handle mixed amounts and currencies
  print
  entry
  -j and -J graph data output
@@ -26,7 +28,7 @@ make it fast
  profile
 
 more features
- svn-style elision
+ 3.0-style elision
  -p period expressions
  -d display expressions
  read gnucash files
@@ -37,6 +39,7 @@ new features
  smart data entry
  incorporate timeclock features
  timelog simple amount entries
+ better layout
 
 tests
  better use of quickcheck/smallcheck

Tests.hs

@@ -1,7 +1,6 @@
 
 module Tests
 where
-
 import Text.ParserCombinators.Parsec
 import Test.QuickCheck
 import Test.HUnit
@@ -273,7 +272,9 @@ test_expandAccountNames =
 
 test_ledgerAccountNames =
     assertEqual'
-    ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
+    ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances",
+    "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",
+     "liabilities","liabilities:credit cards","liabilities:credit cards:discover"]
     (ledgerAccountNames ledger7)
 
 -- quickcheck properties
@@ -284,7 +285,10 @@ props =
      (Transaction "expenses:food:dining" (Amount "$" 10))
     ,
      ledgerAccountNames ledger7 == 
-     ["assets","assets:cash","assets:checking","equity","equity:opening balances","expenses","expenses:vacation"]
+     ["assets","assets:cash","assets:checking","assets:saving","equity",
+      "equity:opening balances","expenses","expenses:food","expenses:food:dining",
+      "expenses:phone","expenses:vacation","liabilities","liabilities:credit cards",
+      "liabilities:credit cards:discover"]
     ,
      ledgerPatternArgs [] == ([],[])
     ,ledgerPatternArgs ["a"] == (["a"],[])

Transaction.hs

@@ -1,12 +1,6 @@
 
 module Transaction
 where
-
-import Debug.Trace
-import Text.Printf
-import Text.Regex
-import Data.List
-
 import Utils
 import BasicTypes
 import Account

Utils.hs

@@ -1,9 +1,19 @@
-
+module Utils (
-module Utils
+              module Utils,
+              module Data.List,
+              module Debug.Trace,
+              module Text.Printf,
+              module Text.Regex,
+              quickCheck,
+             )
 where
-
-import Data.List
 import System.Directory
+import Data.List
+import Debug.Trace
+import Test.QuickCheck (quickCheck)
+import Text.Printf
+import Text.Regex
+
 
 rhead = head . reverse 
 rtail = reverse . tail . reverse 

hledger.hs

@@ -1,22 +1,22 @@
 #!/usr/bin/env runhaskell
 -- hledger - ledger-compatible money management utilities (& haskell study)
 -- GPLv3, (c) Simon Michael & contributors, 
--- John Wiegley's ledger is at http://newartisans.com/ledger.html .
+-- John Wiegley's ledger is at http://newartisans.com/ledger.html
 
-module Main -- application logic & most IO
+-- application logic & most IO
+module Main
 where
-
-import System.Environment (withArgs) -- for testing in old hugs
 import System
-import Data.List
+import System.Environment (withArgs) -- for testing in old hugs
 import Test.HUnit (runTestTT)
 import Test.QuickCheck (quickCheck)
-import Text.ParserCombinators.Parsec (parseFromFile, ParseError)
+import Text.ParserCombinators.Parsec (ParseError)
 
 import Options
 import Models
 import Parse
 import Tests
+import Utils
 
 main :: IO ()
 main = do
@@ -67,13 +67,16 @@ printRegister opts args ledger = do
 
 printBalance :: [Flag] -> [String] -> Ledger -> IO ()
 printBalance opts args ledger = do
---   putStr $ showAccountWithBalances ledger (ledgerAccountsData l)
+--   putStr $ showLedgerAccounts ledger acctpats depth
-  putStr $ showLedgerAccounts ledger acctpats depth
+--       where 
-      where 
+--         (acctpats,_) = ledgerPatternArgs args
-        (acctpats,_) = ledgerPatternArgs args
-        depth = depthOption opts
-
 --         showsubs = (ShowSubs `elem` opts)
---         accounts = case showsubs of
+--         depth = case showsubs of
---                      True -> expandAccountNamesMostly ledger (ledgerTopAccountNames ledger)
+--                   True -> 999
---                      False -> [(a,indentAccountName a) | a <- ledgerAccountNamesMatching acctpats ledger]
+--                   False -> depthOption opts
+  putStr $ case showsubs of
+             True -> showLedgerAccounts ledger 999
+             False -> showLedgerAccounts ledger (getDepth opts)
+      where 
+        showsubs = (ShowSubs `elem` opts)
+        (acctpats,_) = ledgerPatternArgs args