From 11342db6623e72c3b065bdd02b7d026ac3132045 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 9 Oct 2008 13:02:26 +0000 Subject: [PATCH] simplify filtering, make cacheLedger store filtered data as well, make balance reports work a little better --- Ledger/Ledger.hs | 211 +++++++++++++++++++++++++++++++---------------- Ledger/Types.hs | 5 +- Tests.hs | 7 +- hledger.hs | 6 +- 4 files changed, 150 insertions(+), 79 deletions(-) diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs index 3da90a1a1..c77dcd8e4 100644 --- a/Ledger/Ledger.hs +++ b/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 l = +cacheLedger :: Regex -> RawLedger -> Ledger +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]) - txns = (tmap !) - subaccts a = filter (isAccountNamePrefixOf a) ans - subtxns a = concat [txns a | a <- [a] ++ subaccts a] - bmap = Map.union - (Map.fromList [(a, (sumTransactions $ subtxns a){precision=lprecision}) | a <- ans]) - (Map.fromList [(a,nullamt) | a <- ans]) - amap = Map.fromList [(a, Account a (tmap ! a) (bmap ! a)) | a <- ans] - in - Ledger l ant amap lprecision + (Map.fromList [(a,[]) | a <- anames]) + txnsof = (txnmap !) + subacctsof a = filter (isAccountNamePrefixOf a) anames + subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a] + balmap = Map.union + (Map.fromList [(a, (sumTransactions $ subtxnsof a){precision=maxprecision}) | a <- anames]) + (Map.fromList [(a,nullamt) | a <- anames]) + amap = Map.fromList [(a, Account a (txnmap ! a) (balmap ! a)) | a <- anames] + -- the same again, considering only accounts and transactions matching the account pattern + 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 - --- keep only those which fall between the begin and end dates and match the --- account and description patterns. -filterLedger :: String -> String -> Regex -> Regex -> RawLedger -> RawLedger -filterLedger begin end acctpat descpat = - filterEmptyLedgerEntries . - filterLedgerTransactions acctpat . + maxprecision = maximum $ map (precision . amount) ts + in + Ledger l ant amap maxprecision acctpat filteredant filteredamap + +-- | Remove ledger entries we are not interested in. +-- Keep only those which fall between the begin and end dates, match the +-- 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. -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 --- 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 +-- | Keep only entries which have at least one transaction with an account +-- whose (leaf) name matches the pattern. +filterLedgerEntriesByTransactionAccount :: Regex -> RawLedger -> RawLedger +filterLedgerEntriesByTransactionAccount acctpat l@(RawLedger _ _ es _) = + l{entries=filter matchentry es} where - filterentrytxns l@(Entry _ _ _ _ _ ts _) = l{etransactions=filter matchtxn ts} - matchtxn t = case matchRegex acctpat (taccount t) of - Nothing -> False - otherwise -> True + matchentry = any matchtxn . etransactions + matchtxn = containsRegex acctpat . accountLeafName . taccount + +-- -- | 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 l depth = - addDataToAccountNameTree l $ treeprune depth $ accountnametree l +ledgerAccountTree :: Int -> Ledger -> Tree Account +ledgerAccountTree depth 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 - total = sum $ map (abalance . root) bs + acctbranches = branches $ ledgerAccountTree maxdepth l + 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 l = showAccountTree' l 0 . pruneBoringBranches +showAccountTree :: Ledger -> Int -> Tree Account -> String +showAccountTree l maxdepth = showAccountTree' l maxdepth 0 "" -showAccountTree' :: Ledger -> Int -> Tree Account -> String -showAccountTree' l indentlevel t - -- skip a boring inner account - | length subs > 0 && isBoringInnerAccount l acct = subsindented 0 - -- otherwise show normal indented account name with balance, - -- prefixing the names of any boring parents - | otherwise = - bal ++ " " ++ indent ++ prefix ++ leafname ++ "\n" ++ (subsindented 1) +showAccountTree' :: Ledger -> Int -> Int -> String -> Tree Account -> String +showAccountTree' l maxdepth indentlevel prefix t + -- prefix boring inner account names to the next line + | isBoringInnerAccount l maxdepth acct = subsindented 0 (fullname++":") + -- ditto with unmatched parent accounts when filtering by account + | filtering && doesnotmatch = subsindented 0 (fullname++":") + -- otherwise show this account's name & balance + | 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 - boringparents = takeWhile (isBoringInnerAccountName l) $ parentAccountNames $ aname acct - leafname = accountLeafName $ aname acct + fullname = aname acct + leafname = accountLeafName fullname + 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. -isBoringInnerAccount :: Ledger -> Account -> Bool -isBoringInnerAccount l a +-- Boring inner accounts have no transactions, one subaccount, +-- and depth less than the maximum display depth. +-- 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 - subs = subAccountNamesFrom (accountnames l) name + depth = accountNameLevel 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 l = isBoringInnerAccount l . ledgerAccount l +isBoringInnerAccountName :: Ledger -> Int -> AccountName -> Bool +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 = - treefilter hastxns . treefilter hasbalance - where - hasbalance = (/= 0) . abalance - hastxns = (> 0) . length . atransactions +-- pruneBoringBranches :: Tree Account -> Tree Account +-- pruneBoringBranches = +-- treefilter hastxns . treefilter hasbalance +-- where +-- hasbalance = (/= 0) . abalance +-- hastxns = (> 0) . length . atransactions diff --git a/Ledger/Types.hs b/Ledger/Types.hs index 7082f5b62..069fc91a2 100644 --- a/Ledger/Types.hs +++ b/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 } diff --git a/Tests.hs b/Tests.hs index d19034f14..7231d9ea0 100644 --- a/Tests.hs +++ b/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) diff --git a/hledger.hs b/hledger.hs index af666f289..4c4099459 100644 --- a/hledger.hs +++ b/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