diff --git a/Account.hs b/Account.hs index e94bd7865..c016d1ec9 100644 --- a/Account.hs +++ b/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) diff --git a/AccountName.hs b/AccountName.hs index e86277e4a..93adeedb4 100644 --- a/AccountName.hs +++ b/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 diff --git a/EntryTransaction.hs b/EntryTransaction.hs index dc37c0fd1..7f49d5d1d 100644 --- a/EntryTransaction.hs +++ b/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] diff --git a/Ledger.hs b/Ledger.hs index aa6b8eec1..3532d4719 100644 --- a/Ledger.hs +++ b/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 diff --git a/RawLedger.hs b/RawLedger.hs index d1c986a55..ca50c6821 100644 --- a/RawLedger.hs +++ b/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 diff --git a/Tests.hs b/Tests.hs index 05d95b506..36f155ad0 100644 --- a/Tests.hs +++ b/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 diff --git a/Transaction.hs b/Transaction.hs index 70e7794eb..580da2a5d 100644 --- a/Transaction.hs +++ b/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 diff --git a/hledger.hs b/hledger.hs index d79d49c1e..3292536e4 100644 --- a/hledger.hs +++ b/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