simplify filtering, make cacheLedger store filtered data as well, make balance reports work a little better

Ledger/Ledger.hs

@@ -5,11 +5,13 @@ names, a map from account names to 'Account's, and the display precision.
 Typically it has also has had the uninteresting 'Entry's and
 'Transaction's filtered out.
 
+Also, the account filter pattern is stored.
+
 -}
 
 module Ledger.Ledger (
 cacheLedger,
-filterLedger,
+filterLedgerEntries,
 accountnames,
 ledgerAccount,
 ledgerTransactions,
@@ -21,7 +23,7 @@ showLedgerAccountBalances,
 showAccountTree,
 isBoringInnerAccount,
 isBoringInnerAccountName,
-pruneBoringBranches,
+-- pruneBoringBranches,
 )
 where
 import qualified Data.Map as Map
@@ -47,35 +49,56 @@ instance Show Ledger where
              ++ "\n" ++ (showtree $ filteredaccountnametree l)
 
 -- | Convert a raw ledger to a more efficient cached type, described above.  
-cacheLedger :: RawLedger -> Ledger
+cacheLedger :: Regex -> RawLedger -> Ledger
-cacheLedger l = 
+cacheLedger acctpat l = 
     let 
-        lprecision = maximum $ map (precision . amount) $ rawLedgerTransactions l
         ant = rawLedgerAccountNameTree l
-        ans = flatten ant
+        anames = flatten ant
         ts = rawLedgerTransactions l
         sortedts = sortBy (comparing account) ts
         groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts
-        tmap = Map.union 
+        txnmap = Map.union 
                (Map.fromList [(account $ head g, g) | g <- groupedts])
-               (Map.fromList [(a,[]) | a <- ans])
+               (Map.fromList [(a,[]) | a <- anames])
-        txns = (tmap !)
+        txnsof = (txnmap !)
-        subaccts a = filter (isAccountNamePrefixOf a) ans
+        subacctsof a = filter (isAccountNamePrefixOf a) anames
-        subtxns a = concat [txns a | a <- [a] ++ subaccts a]
+        subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a]
-        bmap = Map.union 
+        balmap = Map.union 
-               (Map.fromList [(a, (sumTransactions $ subtxns a){precision=lprecision}) | a <- ans])
+               (Map.fromList [(a, (sumTransactions $ subtxnsof a){precision=maxprecision}) | a <- anames])
-               (Map.fromList [(a,nullamt) | a <- ans])
+               (Map.fromList [(a,nullamt) | a <- anames])
-        amap = Map.fromList [(a, Account a (tmap ! a) (bmap ! a)) | a <- ans]
+        amap = Map.fromList [(a, Account a (txnmap ! a) (balmap ! a)) | a <- anames]
-    in
+        -- the same again, considering only accounts and transactions matching the account pattern
-      Ledger l ant amap lprecision
+        matchacct :: AccountName -> Bool
+        matchacct = containsRegex acctpat . accountLeafName
+        filteredant = treefilter matchacct ant
+        -- rebuild the tree after filtering to include all parents
+        filteredanames = flatten $ accountNameTreeFrom $ filter matchacct anames
+        filteredts = filter (matchacct . account) ts
+        filteredsortedts = sortBy (comparing account) filteredts
+        filteredgroupedts = groupBy (\t1 t2 -> account t1 == account t2) filteredsortedts
+        filteredtxnmap = Map.union 
+               (Map.fromList [(account $ head g, g) | g <- filteredgroupedts])
+               (Map.fromList [(a,[]) | a <- filteredanames])
+        filteredtxnsof = (filteredtxnmap !)
+        filteredsubacctsof a = filter (isAccountNamePrefixOf a) filteredanames
+        filteredsubtxnsof a = concat [filteredtxnsof a | a <- [a] ++ filteredsubacctsof a]
+        filteredbalmap = Map.union 
+               (Map.fromList [(a, (sumTransactions $ filteredsubtxnsof a){precision=maxprecision}) | a <- filteredanames])
+               (Map.fromList [(a,nullamt) | a <- filteredanames])
+        filteredamap = Map.fromList [(a, Account a (filteredtxnmap ! a) (filteredbalmap ! a)) | a <- filteredanames]
 
--- | Remove ledger entries and transactions we are not interested in - 
+        maxprecision = maximum $ map (precision . amount) ts
--- keep only those which fall between the begin and end dates and match the
+    in
--- account and description patterns.
+      Ledger l ant amap maxprecision acctpat filteredant filteredamap
-filterLedger :: String -> String -> Regex -> Regex -> RawLedger -> RawLedger
+
-filterLedger begin end acctpat descpat = 
+-- | Remove ledger entries we are not interested in.
-    filterEmptyLedgerEntries .
+-- Keep only those which fall between the begin and end dates, match the
-    filterLedgerTransactions acctpat .
+-- description patterns, or transact with an account matching the account
+-- patterns.
+filterLedgerEntries :: String -> String -> Regex -> Regex -> RawLedger -> RawLedger
+filterLedgerEntries begin end acctpat descpat = 
+--    strace .
+--    filterLedgerEntriesByTransactionAccount acctpat .
     filterLedgerEntriesByDate begin end .
     filterLedgerEntriesByDescription descpat
 
@@ -104,30 +127,54 @@ filterLedgerEntriesByDate begin end (RawLedger ms ps es f) =
                       enddate   = parsedate end
                       entrydate = parsedate $ edate e
 
--- | Remove entries which have no transactions.
+-- | Keep only entries which have at least one transaction with an account
-filterEmptyLedgerEntries :: RawLedger -> RawLedger
+-- whose (leaf) name matches the pattern.
-filterEmptyLedgerEntries (RawLedger ms ps es f) =
+filterLedgerEntriesByTransactionAccount :: Regex -> RawLedger -> RawLedger
-    RawLedger ms ps (filter (not . null . etransactions) es) f
+filterLedgerEntriesByTransactionAccount acctpat l@(RawLedger _ _ es _) = 
-
+    l{entries=filter matchentry es}
--- | In each ledger entry, filter out transactions which do not match the
--- account pattern. Entries are no longer balanced after this.
-filterLedgerTransactions :: Regex -> RawLedger -> RawLedger
-filterLedgerTransactions acctpat (RawLedger ms ps es f) = 
-    RawLedger ms ps (map filterentrytxns es) f
     where
-      filterentrytxns l@(Entry _ _ _ _ _ ts _) = l{etransactions=filter matchtxn ts}
+      matchentry = any matchtxn . etransactions
-      matchtxn t = case matchRegex acctpat (taccount t) of
+      matchtxn = containsRegex acctpat . accountLeafName . taccount
-                     Nothing -> False
+
-                     otherwise -> True
+-- -- | Remove entries which have no transactions.
+-- filterEmptyLedgerEntries :: RawLedger -> RawLedger
+-- filterEmptyLedgerEntries (RawLedger ms ps es f) =
+--     RawLedger ms ps (filter (not . null . etransactions) es) f
+
+-- -- | In each ledger entry, filter out transactions which do not match the
+-- -- matcher. Entries are no longer balanced after this.
+-- filterLedgerTransactionsBy :: (RawTransaction -> Bool) -> RawLedger -> RawLedger
+-- filterLedgerTransactionsBy matcher (RawLedger ms ps es f) = 
+--     RawLedger ms ps (map filterentrytxns es) f
+--     where
+--       filterentrytxns e@(Entry _ _ _ _ _ ts _) = e{etransactions=filter matcher ts}
+
+matchtxnacctname :: Regex -> RawTransaction -> Bool
+matchtxnacctname acctpat t = case matchRegex acctpat (taccount t) of
+                       Nothing -> False
+                       otherwise -> True
+
+matchtxnleafname :: Regex -> RawTransaction -> Bool
+matchtxnleafname acctpat t = case matchRegex acctpat (accountLeafName $ taccount t) of
+                       Nothing -> False
+                       otherwise -> True
 
 -- | List a 'Ledger' 's account names.
 accountnames :: Ledger -> [AccountName]
 accountnames l = drop 1 $ flatten $ accountnametree l
 
+-- | List a 'Ledger' 's account names filtered by the account match pattern.
+filteredaccountnames :: Ledger -> [AccountName]
+filteredaccountnames l = filter (containsRegex (acctpat l) . accountLeafName) $ accountnames l
+
 -- | Get the named account from a ledger.
 ledgerAccount :: Ledger -> AccountName -> Account
 ledgerAccount l a = (accounts l) ! a
 
+-- | Get the named filtered account from a ledger.
+ledgerFilteredAccount :: Ledger -> AccountName -> Account
+ledgerFilteredAccount l a = (filteredaccounts l) ! a
+
 -- | List a ledger's transactions.
 --
 -- NB this sets the amount precisions to that of the highest-precision
@@ -141,15 +188,29 @@ ledgerTransactions l =
       setprecisions = map (transactionSetPrecision (lprecision l))
 
 -- | Get a ledger's tree of accounts to the specified depth.
-ledgerAccountTree :: Ledger -> Int -> Tree Account
+ledgerAccountTree :: Int -> Ledger -> Tree Account
-ledgerAccountTree l depth = 
+ledgerAccountTree depth l = 
-    addDataToAccountNameTree l $ treeprune depth $ accountnametree l
+    addDataToAccountNameTree l depthpruned
+    where
+      nametree = filteredaccountnametree l --
+      depthpruned = treeprune depth nametree
+
+-- | Get a ledger's tree of accounts to the specified depth, filtered by
+-- the account pattern.
+ledgerFilteredAccountTree :: Int -> Regex -> Ledger -> Tree Account
+ledgerFilteredAccountTree depth acctpat l = 
+    addFilteredDataToAccountNameTree l $ treeprune depth $ filteredaccountnametree l
 
 -- | Convert a tree of account names into a tree of accounts, using their
 -- parent ledger.
 addDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account
 addDataToAccountNameTree = treemap . ledgerAccount
 
+-- | Convert a tree of account names into a tree of accounts, using their
+-- parent ledger's filtered account data.
+addFilteredDataToAccountNameTree :: Ledger -> Tree AccountName -> Tree Account
+addFilteredDataToAccountNameTree l = treemap (ledgerFilteredAccount l)
+
 -- | Print a print report.
 printentries :: Ledger -> IO ()
 printentries l = putStr $ showEntries $ setprecisions $ entries $ rawledger l
@@ -261,62 +322,68 @@ Here are some rules for account balance display, as seen above:
 -}
 showLedgerAccountBalances :: Ledger -> Int -> String
 showLedgerAccountBalances l maxdepth = 
-    concatMap (showAccountTree l) bs
+    concatMap (showAccountTree l maxdepth) acctbranches
     ++
     if isZeroAmount total 
     then ""
     else printf "--------------------\n%20s\n" $ showAmountRounded total
     where 
-      bs = branches $ ledgerAccountTree l maxdepth
+      acctbranches = branches $ ledgerAccountTree maxdepth l
-      total = sum $ map (abalance . root) bs
+      filteredacctbranches = branches $ ledgerFilteredAccountTree maxdepth (acctpat l) l
+      total = sum $ map (abalance . root) filteredacctbranches
 
 -- | Get the string representation of a tree of accounts.
 -- The ledger from which the accounts come is also required, so that
 -- we can check for boring accounts.
-showAccountTree :: Ledger -> Tree Account -> String
+showAccountTree :: Ledger -> Int -> Tree Account -> String
-showAccountTree l = showAccountTree' l 0 . pruneBoringBranches
+showAccountTree l maxdepth = showAccountTree' l maxdepth 0 ""
 
-showAccountTree' :: Ledger -> Int -> Tree Account -> String
+showAccountTree' :: Ledger -> Int -> Int -> String -> Tree Account -> String
-showAccountTree' l indentlevel t
+showAccountTree' l maxdepth indentlevel prefix t
-    -- skip a boring inner account
+    -- prefix boring inner account names to the next line
-    | length subs > 0 && isBoringInnerAccount l acct = subsindented 0
+    | isBoringInnerAccount l maxdepth acct = subsindented 0 (fullname++":")
-    -- otherwise show normal indented account name with balance, 
+    -- ditto with unmatched parent accounts when filtering by account
-    -- prefixing the names of any boring parents
+    |  filtering && doesnotmatch = subsindented 0 (fullname++":")
-    | otherwise = 
+    -- otherwise show this account's name & balance
-        bal ++ "  " ++ indent ++ prefix ++ leafname ++ "\n" ++ (subsindented 1)
+    | otherwise = bal ++ "  " ++ indent ++ prefix ++ leafname ++ "\n" ++ (subsindented 1 "")
     where
       acct = root t
       subs = branches t
-      subsindented i = concatMap (showAccountTree' l (indentlevel+i)) subs
+      subsindented i p = concatMap (showAccountTree' l maxdepth (indentlevel+i) p) subs
       bal = printf "%20s" $ show $ abalance $ acct
       indent = replicate (indentlevel * 2) ' '
-      prefix = concatMap (++ ":") $ map accountLeafName $ reverse boringparents
+      fullname = aname acct
-      boringparents = takeWhile (isBoringInnerAccountName l) $ parentAccountNames $ aname acct
+      leafname = accountLeafName fullname
-      leafname = accountLeafName $ aname acct
+      filtering = filteredaccountnames l /= (accountnames l)
+      doesnotmatch = not (containsRegex (acctpat l) leafname)
 
 -- | Is this account a boring inner account in this ledger ? 
--- Boring inner accounts have no transactions and one subaccount.
+-- Boring inner accounts have no transactions, one subaccount,
-isBoringInnerAccount :: Ledger -> Account -> Bool
+-- and depth less than the maximum display depth.
-isBoringInnerAccount l a
+-- Also, they are unmatched parent accounts when account matching is in effect.
+isBoringInnerAccount :: Ledger -> Int -> Account -> Bool
+isBoringInnerAccount l maxdepth a
     | name == "top" = False
-    | (length txns == 0) && ((length subs) == 1) = True
+    | depth < maxdepth && numtxns == 0 && numsubs == 1 = True
     | otherwise = False
     where      
       name = aname a
-      txns = atransactions a
+      depth = accountNameLevel name
-      subs = subAccountNamesFrom (accountnames l) name
+      numtxns = length $ atransactions a
+      -- how many (filter-matching) subaccounts has this account ?
+      numsubs = length $ subAccountNamesFrom (filteredaccountnames l) name
 
 -- | Is the named account a boring inner account in this ledger ?
-isBoringInnerAccountName :: Ledger -> AccountName -> Bool
+isBoringInnerAccountName :: Ledger -> Int -> AccountName -> Bool
-isBoringInnerAccountName l = isBoringInnerAccount l . ledgerAccount l
+isBoringInnerAccountName l maxdepth = isBoringInnerAccount l maxdepth . ledgerAccount l
 
 -- | Remove boring branches (and leaves) from a tree of accounts.
 -- A boring branch contains only accounts which have a 0 balance or no
 -- transactions.
-pruneBoringBranches :: Tree Account -> Tree Account
+-- pruneBoringBranches :: Tree Account -> Tree Account
-pruneBoringBranches =
+-- pruneBoringBranches =
-    treefilter hastxns . treefilter hasbalance
+--     treefilter hastxns . treefilter hasbalance
-    where 
+--     where 
-      hasbalance = (/= 0) . abalance
+--       hasbalance = (/= 0) . abalance
-      hastxns = (> 0) . length . atransactions
+--       hastxns = (> 0) . length . atransactions
 

Ledger/Types.hs

@@ -90,6 +90,9 @@ data Ledger = Ledger {
       rawledger :: RawLedger,
       accountnametree :: Tree AccountName,
       accounts :: Map.Map AccountName Account,
-      lprecision :: Int
+      lprecision :: Int, -- the preferred display precision
+      acctpat :: Regex,  -- the account patterns used to filter this ledger
+      filteredaccountnametree :: Tree AccountName, -- account name tree filtered by acctpat
+      filteredaccounts :: Map.Map AccountName Account -- accounts filtered by acctpat
     }
 

Tests.hs

@@ -19,7 +19,8 @@ assertParseEqual :: (Show a, Eq a) => a -> (Either ParseError a) -> Assertion
 assertParseEqual expected parsed = either printParseError (assertEqual " " expected) parsed
 
 -- find tests with template haskell
---
+-- import Language.Haskell.Parser
+-- 
 -- {-# OPTIONS_GHC -fno-warn-unused-imports -no-recomp -fth #-}
 -- {- ghc --make Unit.hs -main-is Unit.runTests -o unit -}
 -- runTests :: IO ()
@@ -282,7 +283,7 @@ ledger7 = RawLedger
           ]
           ""
 
-l7 = cacheLedger ledger7
+l7 = cacheLedger wildcard ledger7 
 
 timelogentry1_str  = "i 2007/03/11 16:19:00 hledger\n"
 timelogentry1 = TimeLogEntry 'i' "2007/03/11 16:19:00" "hledger"
@@ -373,7 +374,7 @@ test_ledgerAccountNames =
     (accountnames l7)
 
 test_cacheLedger =
-    assertEqual' 15 (length $ Map.keys $ accounts $ cacheLedger ledger7)
+    assertEqual' 15 (length $ Map.keys $ accounts $ cacheLedger wildcard ledger7 )
 
 test_showLedgerAccounts = 
     assertEqual' 4 (length $ lines $ showLedgerAccountBalances l7 1)

hledger.hs

@@ -75,7 +75,7 @@ balance opts args = parseLedgerAndDo opts args printbalance
       printbalance l = putStr $ showLedgerAccountBalances l depth
           where 
             showsubs = (ShowSubs `elem` opts)
-            pats = parseAccountDescriptionArgs args
+            pats@(acctpats,descpats) = parseAccountDescriptionArgs args
             depth = case (pats, showsubs) of
                       -- when there is no -s or pattern args, show with depth 1
                       (([],[]), False) -> 1
@@ -87,7 +87,7 @@ parseLedgerAndDo :: [Opt] -> [String] -> (Ledger -> IO ()) -> IO ()
 parseLedgerAndDo opts args cmd = 
     ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runthecommand
     where
-      runthecommand = cmd . cacheLedger . filterLedger begin end aregex dregex
+      runthecommand = cmd . cacheLedger aregex . filterLedgerEntries begin end aregex dregex
       begin = beginDateFromOpts opts
       end = endDateFromOpts opts
       aregex = regexFor acctpats
@@ -107,7 +107,7 @@ rawledger = do
 ledger :: IO Ledger
 ledger = do
   l <- rawledger
-  return $ cacheLedger $ filterLedger "" "" wildcard wildcard l
+  return $ cacheLedger wildcard $ filterLedgerEntries "" "" wildcard wildcard l
 
 -- | get a Ledger from the given file path
 rawledgerfromfile :: String -> IO RawLedger