speed, cleanup

Account.hs

@@ -17,163 +17,3 @@ instance Show Account where
 
 nullacct = Account "" [] nullamt
 
--- XXX SLOW
-rawLedgerAccount :: RawLedger -> AccountName -> Account
-rawLedgerAccount l a = 
-    Account 
-    a 
-    (transactionsInAccountNamed l a) 
-    (aggregateBalanceInAccountNamed l a)
-
--- queries
-
-balanceInAccountNamed :: RawLedger -> AccountName -> Amount
-balanceInAccountNamed l a = 
-    sumEntryTransactions (transactionsInAccountNamed l a)
-
-aggregateBalanceInAccountNamed :: RawLedger -> AccountName -> Amount
-aggregateBalanceInAccountNamed l a = 
-    sumEntryTransactions (aggregateTransactionsInAccountNamed l a)
-
-transactionsInAccountNamed :: RawLedger -> AccountName -> [EntryTransaction]
-transactionsInAccountNamed l a =
-    rawLedgerTransactionsMatching (["^" ++ a ++ "$"], []) l
-
-aggregateTransactionsInAccountNamed :: RawLedger -> AccountName -> [EntryTransaction]
-aggregateTransactionsInAccountNamed l a = 
-    rawLedgerTransactionsMatching (["^" ++ a ++ "(:.+)?$"], []) l
-
--- build a tree of Accounts
-addDataToAccountNameTree :: RawLedger -> Tree AccountName -> Tree Account
-addDataToAccountNameTree l ant = 
-    Node 
-    (rawLedgerAccount l $ root ant) 
-    (map (addDataToAccountNameTree l) $ branches ant)
-
--- balance report support
---
--- examples, ignoring the issue of eliding boring accounts:
--- here is a sample account tree:
---
--- assets
---  cash
---  checking
---  saving
--- equity
--- expenses
---  food
---  shelter
--- income
---  salary
--- liabilities
---  debts
---
--- standard balance command shows all top-level accounts:
---
--- > ledger bal
--- $ assets      
--- $ equity
--- $ expenses    
--- $ income      
--- $ liabilities 
---
--- with an account pattern, show only the ones with matching names:
---
--- > ledger bal asset
--- $ assets      
---
--- with -s, show all subaccounts of matched accounts:
---
--- > ledger -s bal asset
--- $ assets      
--- $  cash       
--- $  checking   
--- $  saving
-
-showRawLedgerAccounts :: RawLedger -> [String] -> Bool -> Int -> String
-showRawLedgerAccounts l acctpats showsubs maxdepth = 
-    concatMap 
-    (showAccountTree l) 
-    (branches (rawLedgerAccountTreeMatching l acctpats showsubs maxdepth))
-
-rawLedgerAccountTreeMatching :: RawLedger -> [String] -> Bool -> Int -> Tree Account
-rawLedgerAccountTreeMatching l [] showsubs maxdepth = 
-    rawLedgerAccountTreeMatching l [".*"] showsubs maxdepth
-rawLedgerAccountTreeMatching l acctpats showsubs maxdepth = 
-    addDataToAccountNameTree l $ 
-    filterAccountNameTree acctpats showsubs maxdepth $ 
-    rawLedgerAccountNameTree l
-
--- when displaying an account tree, we elide boring accounts.
--- 1. leaf accounts and branches with 0 balance or 0 transactions are omitted
--- 2. inner accounts with 0 transactions and 1 subaccount are displayed as
---    a prefix of the sub
---
--- example:
---
--- a (0 txns)
---   b (0 txns)
---     c
---       d
--- e (0 txns)
---   f
---   g
--- h (0 txns)
---   i (0 balance)
---
--- displays as:
---
--- a:b:c
---   d
--- e
---   f
---   g
-showAccountTree :: RawLedger -> Tree Account -> String
-showAccountTree l = showAccountTree' l 0 . interestingAccountsFrom
-
-showAccountTree' :: RawLedger -> Int -> Tree Account -> String
-showAccountTree' l indentlevel t
-    -- if this acct is boring, don't show it
-    | isBoringInnerAccount l acct = subacctsindented 0
-    -- otherwise show normal indented account name with balance, 
-    -- prefixing the names of any boring parents
-    | otherwise = 
-        bal ++ "  " ++ indent ++ prefix ++ leafname ++ "\n" ++ (subacctsindented 1)
-    where
-      acct = root t
-      subacctsindented i = concatMap (showAccountTree' l (indentlevel+i)) $ branches t
-      bal = printf "%20s" $ show $ abalance $ acct
-      indent = replicate (indentlevel * 2) ' '
-      prefix = concatMap (++ ":") $ map accountLeafName boringparents
-      boringparents = takeWhile (isBoringInnerAccountName l) $ parentAccountNames $ aname acct
-      leafname = accountLeafName $ aname acct
-
-isBoringInnerAccount :: RawLedger -> Account -> Bool
-isBoringInnerAccount l a
-    | name == "top" = False
-    | (length txns == 0) && ((length subs) == 1) = True
-    | otherwise = False
-    where
-      name = aname a
-      txns = atransactions a
-      subs = subAccountNamesFrom (rawLedgerAccountNames l) name
-
--- darnit, still need this
-isBoringInnerAccountName :: RawLedger -> AccountName -> Bool
-isBoringInnerAccountName l name
-    | name == "top" = False
-    | (length txns == 0) && ((length subs) == 1) = True
-    | otherwise = False
-    where
-      txns = transactionsInAccountNamed l name
-      subs = subAccountNamesFrom (rawLedgerAccountNames l) name
-
-interestingAccountsFrom :: Tree Account -> Tree Account
-interestingAccountsFrom =
-    treefilter hastxns . treefilter hasbalance
-    where 
-      hasbalance = (/= 0) . abalance
-      hastxns = (> 0) . length . atransactions
-
-rawLedgerAccountTree :: RawLedger -> Tree Account
-rawLedgerAccountTree l = addDataToAccountNameTree l (rawLedgerAccountNameTree l)

AccountName.hs

@@ -3,17 +3,20 @@ where
 import Utils
 import Types
 
+sepchar = ':'
+
 accountNameComponents :: AccountName -> [String]
-accountNameComponents = splitAtElement ':'
+accountNameComponents = splitAtElement sepchar
 
 accountNameFromComponents :: [String] -> AccountName
-accountNameFromComponents = concat . intersperse ":"
+accountNameFromComponents = concat . intersperse [sepchar]
 
 accountLeafName :: AccountName -> String
 accountLeafName = last . accountNameComponents
 
 accountNameLevel :: AccountName -> Int
-accountNameLevel = length . accountNameComponents
+accountNameLevel "" = 0
+accountNameLevel a = (length $ filter (==sepchar) a) + 1
 
 -- ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
 expandAccountNames :: [AccountName] -> [AccountName]
@@ -33,17 +36,19 @@ parentAccountNames a = parentAccountNames' $ parentAccountName a
       parentAccountNames' "" = []
       parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a)
 
-p `isAccountNamePrefixOf` s = ((p ++ ":") `isPrefixOf` s)
-    
+isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
+p `isAccountNamePrefixOf` s = ((p ++ [sepchar]) `isPrefixOf` s)
+
+isSubAccountNameOf :: AccountName -> AccountName -> Bool
 s `isSubAccountNameOf` p = 
     (p `isAccountNamePrefixOf` 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
+matchAccountName :: Regex -> AccountName -> Bool
+matchAccountName r a =
+    case matchRegex r a of
       Nothing -> False
       otherwise -> True
 
@@ -76,10 +81,10 @@ accountNameTreeFrom accts =
 
 filterAccountNameTree :: [String] -> Bool -> Int -> Tree AccountName -> Tree AccountName
 filterAccountNameTree pats keepsubs maxdepth =
-    treefilter (\a -> matchpats a || (keepsubs && issubofmatch a)) .
-    treeprune maxdepth
+    treefilter (\a -> matchany a || (keepsubs && issubofmatch a)) . treeprune maxdepth
     where
-      matchpats a = any (match a) pats
-      match a pat = matchAccountName pat $ accountLeafName a
-      issubofmatch a = any matchpats $ parentAccountNames a
+      regexes = map mkRegex pats
+      matchany a = any (match a) regexes
+      match a r = matchAccountName r $ accountLeafName a
+      issubofmatch a = any matchany $ parentAccountNames a
 

EntryTransaction.hs

@@ -32,15 +32,15 @@ sumEntryTransactions :: [EntryTransaction] -> Amount
 sumEntryTransactions ets = 
     sumTransactions $ map transaction ets
 
-matchTransactionAccount :: String -> EntryTransaction -> Bool
-matchTransactionAccount s t =
-    case matchRegex (mkRegex s) (account t) of
+matchTransactionAccount :: Regex -> EntryTransaction -> Bool
+matchTransactionAccount r t =
+    case matchRegex r (account t) of
       Nothing -> False
       otherwise -> True
 
-matchTransactionDescription :: String -> EntryTransaction -> Bool
-matchTransactionDescription s t =
-    case matchRegex (mkRegex s) (description t) of
+matchTransactionDescription :: Regex -> EntryTransaction -> Bool
+matchTransactionDescription r t =
+    case matchRegex r (description t) of
       Nothing -> False
       otherwise -> True
 
@@ -69,15 +69,6 @@ showTransactionAndBalance t b =
 showBalance :: Amount -> String
 showBalance b = printf " %12s" (showAmountRoundedOrZero b)
 
-transactionsMatching :: ([String],[String]) -> [EntryTransaction] -> [EntryTransaction]
-transactionsMatching ([],[]) ts = transactionsMatching ([".*"],[".*"]) ts
-transactionsMatching (rs,[]) ts = transactionsMatching (rs,[".*"]) ts
-transactionsMatching ([],rs) ts = transactionsMatching ([".*"],rs) ts
-transactionsMatching (acctregexps,descregexps) ts =
-    intersect 
-    (concat [filter (matchTransactionAccount r) ts | r <- acctregexps])
-    (concat [filter (matchTransactionDescription r) ts | r <- descregexps])
-
 transactionsWithAccountName :: AccountName -> [EntryTransaction] -> [EntryTransaction]
 transactionsWithAccountName a ts = [t | t <- ts, account t == a]
     

Ledger.hs

@@ -34,44 +34,129 @@ cacheLedger l =
     in
       Ledger l ant amap
 
+accountnames :: Ledger -> [AccountName]
+accountnames l = flatten $ accountnametree l
+
 ledgerAccount :: Ledger -> AccountName -> Account
--- wtf  ledgerAccount l = ((accounts l) (!))
-ledgerAccount l aname = head [a | (n,a) <- Map.toList $ accounts l, n == aname]
+ledgerAccount l a = (accounts l) ! a
 
 ledgerTransactions :: Ledger -> [EntryTransaction]
 ledgerTransactions l = concatMap atransactions $ Map.elems $ accounts l
 
 ledgerTransactionsMatching :: ([String],[String]) -> Ledger -> [EntryTransaction]
-ledgerTransactionsMatching pats l = rawLedgerTransactionsMatching pats $ rawledger l
+ledgerTransactionsMatching ([],[]) l = ledgerTransactionsMatching ([".*"],[".*"]) l
+ledgerTransactionsMatching (rs,[]) l = ledgerTransactionsMatching (rs,[".*"]) l
+ledgerTransactionsMatching ([],rs) l = ledgerTransactionsMatching ([".*"],rs) l
+ledgerTransactionsMatching (acctpats,descpats) l =
+    intersect 
+    (concat [filter (matchTransactionAccount r) ts | r <- acctregexps])
+    (concat [filter (matchTransactionDescription r) ts | r <- descregexps])
+    where 
+      ts = ledgerTransactions l
+      acctregexps = map mkRegex acctpats
+      descregexps = map mkRegex descpats
+
+ledgerAccountTreeMatching :: Ledger -> [String] -> Bool -> Int -> Tree Account
+ledgerAccountTreeMatching l [] showsubs maxdepth = 
+    ledgerAccountTreeMatching l [".*"] showsubs maxdepth
+ledgerAccountTreeMatching l acctpats showsubs maxdepth = 
+    addDataToAccountNameTree l $ 
+    filterAccountNameTree acctpats showsubs maxdepth $ 
+    accountnametree l
+
+addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account
+addDataToAccountNameTree = treemap . ledgerAccount
+
+-- balance report support
+--
+-- examples: here is a sample account tree:
+--
+-- assets
+--  cash
+--  checking
+--  saving
+-- equity
+-- expenses
+--  food
+--  shelter
+-- income
+--  salary
+-- liabilities
+--  debts
+--
+-- standard balance command shows all top-level accounts:
+--
+-- > ledger bal
+-- $ assets      
+-- $ equity
+-- $ expenses    
+-- $ income      
+-- $ liabilities 
+--
+-- with an account pattern, show only the ones with matching names:
+--
+-- > ledger bal asset
+-- $ assets      
+--
+-- with -s, show all subaccounts of matched accounts:
+--
+-- > ledger -s bal asset
+-- $ assets      
+-- $  cash       
+-- $  checking   
+-- $  saving
+--
+-- we elide boring accounts in two ways:
+-- - leaf accounts and branches with 0 balance or 0 transactions are omitted
+-- - inner accounts with 0 transactions and 1 subaccount are displayed inline
+-- so this:
+--
+-- a (0 txns)
+--   b (0 txns)
+--     c
+--       d
+-- e (0 txns)
+--   f
+--   g
+-- h (0 txns)
+--   i (0 balance)
+--
+-- is displayed like:
+--
+-- a:b:c
+--   d
+-- e
+--   f
+--   g
 
 showLedgerAccounts :: Ledger -> [String] -> Bool -> Int -> String
 showLedgerAccounts l acctpats showsubs maxdepth = 
     concatMap 
-    (showAccountTree2 l) 
+    (showAccountTree l) 
     (branches (ledgerAccountTreeMatching l acctpats showsubs maxdepth))
 
-showAccountTree2 :: Ledger -> Tree Account -> String
-showAccountTree2 l = showAccountTree'2 l 0 . interestingAccountsFrom
+showAccountTree :: Ledger -> Tree Account -> String
+showAccountTree l = showAccountTree' l 0 . interestingAccountsFrom
 
-showAccountTree'2 :: Ledger -> Int -> Tree Account -> String
-showAccountTree'2 l indentlevel t
+showAccountTree' :: Ledger -> Int -> Tree Account -> String
+showAccountTree' l indentlevel t
     -- if this acct is boring, don't show it
-    | isBoringInnerAccount2 l acct = subacctsindented 0
+    | isBoringAccount l acct = subacctsindented 0
     -- otherwise show normal indented account name with balance, 
     -- prefixing the names of any boring parents
     | otherwise = 
         bal ++ "  " ++ indent ++ prefix ++ leafname ++ "\n" ++ (subacctsindented 1)
     where
       acct = root t
-      subacctsindented i = concatMap (showAccountTree'2 l (indentlevel+i)) $ branches t
+      subacctsindented i = concatMap (showAccountTree' l (indentlevel+i)) $ branches t
       bal = printf "%20s" $ show $ abalance $ acct
       indent = replicate (indentlevel * 2) ' '
       prefix = concatMap (++ ":") $ map accountLeafName boringparents
-      boringparents = takeWhile (isBoringInnerAccountName2 l) $ parentAccountNames $ aname acct
+      boringparents = takeWhile (isBoringAccountName l) $ parentAccountNames $ aname acct
       leafname = accountLeafName $ aname acct
 
-isBoringInnerAccount2 :: Ledger -> Account -> Bool
-isBoringInnerAccount2 l a
+isBoringAccount :: Ledger -> Account -> Bool
+isBoringAccount l a
     | name == "top" = False
     | (length txns == 0) && ((length subs) == 1) = True
     | otherwise = False
@@ -80,37 +165,12 @@ isBoringInnerAccount2 l a
       txns = atransactions a
       subs = subAccountNamesFrom (accountnames l) name
 
-accountnames :: Ledger -> [AccountName]
-accountnames l = flatten $ accountnametree l
-
-isBoringInnerAccountName2 :: Ledger -> AccountName -> Bool
-isBoringInnerAccountName2 l name
-    | name == "top" = False
-    | (length txns == 0) && ((length subs) == 1) = True
-    | otherwise = False
-    where
-      txns = atransactions $ ledgerAccount l name
-      subs = subAccountNamesFrom (accountnames l) name
-
-transactionsInAccountNamed2 :: Ledger -> AccountName -> [EntryTransaction]
-transactionsInAccountNamed2 l a = atransactions $ ledgerAccount l a
-
-----
-
-ledgerAccountTreeMatching :: Ledger -> [String] -> Bool -> Int -> Tree Account
-ledgerAccountTreeMatching l [] showsubs maxdepth = 
-    ledgerAccountTreeMatching l [".*"] showsubs maxdepth
-ledgerAccountTreeMatching l acctpats showsubs maxdepth = 
-    addDataToAccountNameTree2 l $ 
-    filterAccountNameTree acctpats showsubs maxdepth $ 
-    accountnametree l
-
-addDataToAccountNameTree2 :: Ledger -> Tree AccountName -> Tree Account
-addDataToAccountNameTree2 l ant = 
-    Node 
-    (ledgerAccount l $ root ant) 
-    (map (addDataToAccountNameTree2 l) $ branches ant)
-
--- ledgerAccountNames :: Ledger -> [AccountName]
--- ledgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed
+isBoringAccountName :: Ledger -> AccountName -> Bool
+isBoringAccountName l = isBoringAccount l . ledgerAccount l
 
+interestingAccountsFrom :: Tree Account -> Tree Account
+interestingAccountsFrom =
+    treefilter hastxns . treefilter hasbalance
+    where 
+      hasbalance = (/= 0) . abalance
+      hastxns = (> 0) . length . atransactions

RawLedger.hs

@@ -18,34 +18,12 @@ instance Show RawLedger where
 rawLedgerTransactions :: RawLedger -> [EntryTransaction]
 rawLedgerTransactions l = entryTransactionsFrom $ entries l
 
-rawLedgerTransactionsMatching :: ([String],[String]) -> RawLedger -> [EntryTransaction]
-rawLedgerTransactionsMatching ([],[]) l = rawLedgerTransactionsMatching ([".*"],[".*"]) l
-rawLedgerTransactionsMatching (rs,[]) l = rawLedgerTransactionsMatching (rs,[".*"]) l
-rawLedgerTransactionsMatching ([],rs) l = rawLedgerTransactionsMatching ([".*"],rs) l
-rawLedgerTransactionsMatching (acctregexps,descregexps) l =
-    intersect 
-    (concat [filter (matchTransactionAccount r) ts | r <- acctregexps])
-    (concat [filter (matchTransactionDescription r) ts | r <- descregexps])
-    where ts = rawLedgerTransactions l
-
-rawLedgerAccountTransactions :: RawLedger -> AccountName -> [EntryTransaction]
-rawLedgerAccountTransactions l a = rawLedgerTransactionsMatching (["^" ++ a ++ "$"], []) l
-           
 rawLedgerAccountNamesUsed :: RawLedger -> [AccountName]
 rawLedgerAccountNamesUsed l = accountNamesFromTransactions $ entryTransactionsFrom $ entries l
 
 rawLedgerAccountNames :: RawLedger -> [AccountName]
 rawLedgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed
 
-rawLedgerTopAccountNames :: RawLedger -> [AccountName]
-rawLedgerTopAccountNames l = filter (notElem ':') (rawLedgerAccountNames l)
-
-rawLedgerAccountNamesMatching :: [String] -> RawLedger -> [AccountName]
-rawLedgerAccountNamesMatching [] l = rawLedgerAccountNamesMatching [".*"] l
-rawLedgerAccountNamesMatching acctregexps l =
-    concat [filter (matchAccountName r) accountNames | r <- acctregexps]
-        where accountNames = rawLedgerTopAccountNames l
-
 rawLedgerAccountNameTree :: RawLedger -> Tree AccountName
 rawLedgerAccountNameTree l = accountNameTreeFrom $ rawLedgerAccountNames l
 

Tests.hs

@@ -291,7 +291,7 @@ test_ledgerAccountNames =
     (rawLedgerAccountNames ledger7)
 
 test_cacheLedger =
-    assertEqual' 14 (length $ Map.keys $ accounts $ cacheLedger ledger7)
+    assertEqual' 15 (length $ Map.keys $ accounts $ cacheLedger ledger7)
     
 
 -- quickcheck properties

Transaction.hs

@@ -29,5 +29,5 @@ autofillTransactions ts =
       otherwise -> error "too many blank transactions in this entry"
 
 sumTransactions :: [Transaction] -> Amount
-sumTransactions ts = sum [tamount t | t <- ts]
+sumTransactions = sum . map tamount
 

hledger.hs

@@ -71,11 +71,3 @@ doWithParsed :: (Ledger -> IO ()) -> (Either ParseError RawLedger) -> IO ()
 doWithParsed cmd parsed = do
   case parsed of Left e -> parseError e
                  Right l -> cmd $ cacheLedger l
-
--- interactive testing:
---
--- p <- ledgerFilePath [] >>= parseLedgerFile
--- let l = either (\_ -> RawLedger [] [] []) id p
--- let ant = rawLedgerAccountNameTree l
--- let at = rawLedgerAccountTreeMatching l [] True 999
--- putStr $ drawTree $ treemap show $ rawLedgerAccountTreeMatching l ["a"] False 999