From 00f22819ae2ca407a25be2710e4056f8fc524c9d Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sun, 21 Oct 2012 17:18:18 +0000 Subject: [PATCH] balance report speedup This refactoring fixes an O(n^2) slowdown in the balance command with large numbers of accounts. It's now speedy, and the implementation is clearer. To facilitate this, the Account type now represents a tree of accounts which can easily be traversed up or down (and/or flattened into a list). Benchmark on a 2010 macbook: +-------------------------------------------++--------------+------------+--------+ | || before: | after: | | | || hledger-0.18 | hledgeropt | ledger | +===========================================++==============+============+========+ | -f data/100x100x10.journal balance || 0.21 | 0.07 | 0.09 | | -f data/1000x1000x10.journal balance || 10.13 | 0.47 | 0.62 | | -f data/1000x10000x10.journal balance || 40.67 | 0.67 | 1.01 | | -f data/10000x1000x10.journal balance || 15.01 | 3.22 | 2.36 | | -f data/10000x1000x10.journal balance aa || 4.77 | 4.40 | 2.33 | +-------------------------------------------++--------------+------------+--------+ --- hledger-lib/Hledger/Data/Account.hs | 153 +++++- hledger-lib/Hledger/Data/AccountName.hs | 91 +--- hledger-lib/Hledger/Data/Journal.hs | 213 +------- hledger-lib/Hledger/Data/Ledger.hs | 106 ++-- hledger-lib/Hledger/Data/Types.hs | 49 +- hledger-lib/Hledger/Reports.hs | 628 ++++++++++++------------ hledger-lib/Hledger/Utils.hs | 22 + hledger-web/Hledger/Web/Handlers.hs | 2 +- hledger/Hledger/Cli.hs | 7 +- hledger/Hledger/Cli/Add.hs | 5 +- hledger/Hledger/Cli/Stats.hs | 4 +- 11 files changed, 558 insertions(+), 722 deletions(-) diff --git a/hledger-lib/Hledger/Data/Account.hs b/hledger-lib/Hledger/Data/Account.hs index fb7095857..9aee1913a 100644 --- a/hledger-lib/Hledger/Data/Account.hs +++ b/hledger-lib/Hledger/Data/Account.hs @@ -1,31 +1,166 @@ +{-# LANGUAGE RecordWildCards, StandaloneDeriving #-} {-| -An 'Account' stores -- an 'AccountName', - -- all 'Posting's in the account, excluding subaccounts - -- a 'MixedAmount' representing the account balance, including subaccounts. +An 'Account' has a name, a list of subaccounts, an optional parent +account, and subaccounting-excluding and -including balances. -} module Hledger.Data.Account where +import Data.List +import qualified Data.Map as M +import Safe (headMay, lookupJustDef) import Test.HUnit import Text.Printf +import Hledger.Data.AccountName import Hledger.Data.Amount +import Hledger.Data.Posting() import Hledger.Data.Types +import Hledger.Utils +-- deriving instance Show Account instance Show Account where - show (Account a ps b) = printf "Account %s with %d postings and %s balance" a (length ps) (showMixedAmountDebug b) + show Account{..} = printf "Account %s (boring:%s, ebalance:%s, ibalance:%s)" + aname + (if aboring then "y" else "n") + (showMixedAmount aebalance) + (showMixedAmount aibalance) instance Eq Account where - (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2 + (==) a b = aname a == aname b -- quick equality test for speed + -- and + -- [ aname a == aname b + -- -- , aparent a == aparent b -- avoid infinite recursion + -- , asubs a == asubs b + -- , aebalance a == aebalance b + -- , aibalance a == aibalance b + -- ] + +nullacct = Account + { aname = "" + , aparent = Nothing + , asubs = [] + , aebalance = nullmixedamt + , aibalance = nullmixedamt + , aboring = False + } + +-- | Derive an account tree with balances from a set of postings. +-- (*ledger's core feature.) The accounts are returned in a list, but +-- retain their tree structure; the first one is the root of the tree. +accountsFromPostings :: [Posting] -> [Account] +accountsFromPostings ps = + let + acctamts = [(paccount p,pamount p) | p <- ps] + grouped = groupBy (\a b -> fst a == fst b) $ sort $ acctamts + summed = map (\as@((aname,_):_) -> (aname, sum $ map snd as)) grouped -- always non-empty + setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} + nametree = treeFromPaths $ map (expandAccountName . fst) summed + acctswithnames = nameTreeToAccount "root" nametree + acctswithebals = mapAccounts setebalance acctswithnames + acctswithibals = sumAccounts acctswithebals + acctswithparents = tieAccountParents acctswithibals + acctsflattened = flattenAccounts acctswithparents + in + acctsflattened + +-- | Convert an AccountName tree to an Account tree +nameTreeToAccount :: AccountName -> FastTree AccountName -> Account +nameTreeToAccount rootname (T m) = + nullacct{ aname=rootname, asubs=map (uncurry nameTreeToAccount) $ M.assocs m } + +-- | Tie the knot so all subaccounts' parents are set correctly. +tieAccountParents :: Account -> Account +tieAccountParents = tie Nothing + where + tie parent a@Account{..} = a' + where + a' = a{aparent=parent, asubs=map (tie (Just a')) asubs} + +-- | Get this account's parent accounts, from the nearest up to the root. +parentAccounts :: Account -> [Account] +parentAccounts Account{aparent=Nothing} = [] +parentAccounts Account{aparent=Just a} = a:parentAccounts a + +-- | List the accounts at each level of the account tree. +accountsLevels :: Account -> [[Account]] +accountsLevels = takeWhile (not . null) . iterate (concatMap asubs) . (:[]) + +-- | Map a (non-tree-structure-modifying) function over this and sub accounts. +mapAccounts :: (Account -> Account) -> Account -> Account +mapAccounts f a = f a{asubs = map (mapAccounts f) $ asubs a} + +-- | Is the predicate true on any of this account or its subaccounts ? +anyAccounts :: (Account -> Bool) -> Account -> Bool +anyAccounts p a + | p a = True + | otherwise = any (anyAccounts p) $ asubs a + +-- | Add subaccount-inclusive balances to an account tree. +-- -- , also noting +-- -- whether it has an interesting balance or interesting subs to help +-- -- with eliding later. +sumAccounts :: Account -> Account +sumAccounts a + | null $ asubs a = a{aibalance=aebalance a} + | otherwise = a{aibalance=ibal, asubs=subs} + where + subs = map sumAccounts $ asubs a + ibal = sum $ aebalance a : map aibalance subs + +-- | Remove all subaccounts below a certain depth. +clipAccounts :: Int -> Account -> Account +clipAccounts 0 a = a{asubs=[]} +clipAccounts d a = a{asubs=subs} + where + subs = map (clipAccounts (d-1)) $ asubs a + +-- | Remove all leaf accounts and subtrees matching a predicate. +pruneAccounts :: (Account -> Bool) -> Account -> Maybe Account +pruneAccounts p = headMay . prune + where + prune a + | null prunedsubs = if p a then [] else [a] + | otherwise = [a{asubs=prunedsubs}] + where + prunedsubs = concatMap prune $ asubs a + +-- | Flatten an account tree into a list, which is sometimes +-- convenient. Note since accounts link to their parents/subs, the +-- account tree remains intact and can still be used. It's a tree/list! +flattenAccounts :: Account -> [Account] +flattenAccounts a = squish a [] + where squish a as = a:Prelude.foldr squish as (asubs a) + +-- | Filter an account tree (to a list). +filterAccounts :: (Account -> Bool) -> Account -> [Account] +filterAccounts p a + | p a = a : concatMap (filterAccounts p) (asubs a) + | otherwise = concatMap (filterAccounts p) (asubs a) + +-- | Search an account list by name. +lookupAccount :: AccountName -> [Account] -> Maybe Account +lookupAccount a = find ((==a).aname) + +-- debug helpers + +printAccounts :: Account -> IO () +printAccounts = putStrLn . showAccounts + +showAccounts = unlines . map showAccountDebug . flattenAccounts + +showAccountsBoringFlag = unlines . map (show . aboring) . flattenAccounts + +showAccountDebug a = printf "%-25s %4s %4s %s" + (aname a) + (showMixedAmount $ aebalance a) + (showMixedAmount $ aibalance a) + (if aboring a then "b" else " ") -nullacct = Account "" [] nullmixedamt tests_Hledger_Data_Account = TestList [ ] diff --git a/hledger-lib/Hledger/Data/AccountName.hs b/hledger-lib/Hledger/Data/AccountName.hs index 905a09da8..44bd3199c 100644 --- a/hledger-lib/Hledger/Data/AccountName.hs +++ b/hledger-lib/Hledger/Data/AccountName.hs @@ -10,11 +10,9 @@ hierarchy. module Hledger.Data.AccountName where import Data.List -import Data.Map (Map) import Data.Tree import Test.HUnit import Text.Printf -import qualified Data.Map as M import Hledger.Data.Types import Hledger.Utils @@ -42,8 +40,11 @@ accountNameDrop n = accountNameFromComponents . drop n . accountNameComponents -- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] expandAccountNames :: [AccountName] -> [AccountName] -expandAccountNames as = nub $ concatMap expand as - where expand = map accountNameFromComponents . tail . inits . accountNameComponents +expandAccountNames as = nub $ concatMap expandAccountName as + +-- | "a:b:c" -> ["a","a:b","a:b:c"] +expandAccountName :: AccountName -> [AccountName] +expandAccountName = map accountNameFromComponents . tail . inits . accountNameComponents -- | ["a:b:c","d:e"] -> ["a","d"] topAccountNames :: [AccountName] -> [AccountName] @@ -72,83 +73,15 @@ subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts -- | Convert a list of account names to a tree. accountNameTreeFrom :: [AccountName] -> Tree AccountName -accountNameTreeFrom = accountNameTreeFrom1 - -accountNameTreeFrom1 accts = - Node "top" (accounttreesfrom (topAccountNames accts)) +accountNameTreeFrom accts = + Node "root" (accounttreesfrom (topAccountNames accts)) where accounttreesfrom :: [AccountName] -> [Tree AccountName] accounttreesfrom [] = [] accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] subs = subAccountNamesFrom (expandAccountNames accts) -nullaccountnametree = Node "top" [] - -accountNameTreeFrom2 accts = - Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts - where - subs = subAccountNamesFrom allaccts - allaccts = expandAccountNames accts - -- subs' a = subsmap ! a - -- subsmap :: Map AccountName [AccountName] - -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts] - -accountNameTreeFrom3 accts = - Node "top" $ forestfrom allaccts $ topAccountNames accts - where - -- drop accts from the list of potential subs as we add them to the tree - forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName - forestfrom subaccts accts = - [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts] - allaccts = expandAccountNames accts - - --- a more efficient tree builder from Cale Gibbard -newtype Tree' a = T (Map a (Tree' a)) - deriving (Show, Eq, Ord) - -mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a -mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') - -emptyTree = T M.empty - -pathtree :: [a] -> Tree' a -pathtree [] = T M.empty -pathtree (x:xs) = T (M.singleton x (pathtree xs)) - -fromPaths :: (Ord a) => [[a]] -> Tree' a -fromPaths = foldl' mergeTrees emptyTree . map pathtree - --- the above, but trying to build Tree directly - --- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a --- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms') - --- emptyTree' = Node "top" [] - --- pathtree' :: [a] -> Tree a --- pathtree' [] = Node undefined [] --- pathtree' (x:xs) = Node x [pathtree' xs] - --- fromPaths' :: (Ord a) => [[a]] -> Tree a --- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree' - - --- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName] --- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m] - --- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName --- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts) - -converttree :: Tree' AccountName -> [Tree AccountName] -converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m] - -expandTreeNames :: Tree AccountName -> Tree AccountName -expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts) - -accountNameTreeFrom4 :: [AccountName] -> Tree AccountName -accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents - +nullaccountnametree = Node "root" [] -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news: @@ -199,10 +132,10 @@ isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:(" tests_Hledger_Data_AccountName = TestList [ "accountNameTreeFrom" ~: do - accountNameTreeFrom ["a"] `is` Node "top" [Node "a" []] - accountNameTreeFrom ["a","b"] `is` Node "top" [Node "a" [], Node "b" []] - accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]] - accountNameTreeFrom ["a:b:c"] `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]] + accountNameTreeFrom ["a"] `is` Node "root" [Node "a" []] + accountNameTreeFrom ["a","b"] `is` Node "root" [Node "a" [], Node "b" []] + accountNameTreeFrom ["a","a:b"] `is` Node "root" [Node "a" [Node "a:b" []]] + accountNameTreeFrom ["a:b:c"] `is` Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]] ,"expandAccountNames" ~: expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is` diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 1e18955c2..98b1d5551 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -23,7 +23,6 @@ module Hledger.Data.Journal ( filterJournalPostings, filterJournalTransactions, -- * Querying - journalAccountInfo, journalAccountNames, journalAccountNamesUsed, journalAmountAndPriceCommodities, @@ -43,7 +42,6 @@ module Hledger.Data.Journal ( journalEquityAccountQuery, journalCashAccountQuery, -- * Misc - groupPostings, matchpats, nullctx, nulljournal, @@ -53,7 +51,7 @@ module Hledger.Data.Journal ( ) where import Data.List -import Data.Map (findWithDefault, (!), toAscList) +import Data.Map (findWithDefault) import Data.Ord import Data.Time.Calendar import Data.Time.LocalTime @@ -67,7 +65,6 @@ import qualified Data.Map as Map import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName -import Hledger.Data.Account() import Hledger.Data.Amount import Hledger.Data.Commodity import Hledger.Data.Dates @@ -477,209 +474,6 @@ isnegativepat = (negateprefix `isPrefixOf`) abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat --- | Calculate the account tree and all account balances from a journal's --- postings, returning the results for efficient lookup. -journalAccountInfo :: Journal -> (Tree AccountName, Map.Map AccountName Account) -journalAccountInfo j = (ant, amap) - where - (ant, psof, _, inclbalof) = (groupPostings . journalPostings) j - amap = Map.fromList [(a, acctinfo a) | a <- flatten ant] - acctinfo a = Account a (psof a) (inclbalof a) - -tests_journalAccountInfo = [ - "journalAccountInfo" ~: do - let (t,m) = journalAccountInfo samplejournal - assertEqual "account tree" - (Node "top" [ - Node "assets" [ - Node "assets:bank" [ - Node "assets:bank:checking" [], - Node "assets:bank:saving" [] - ], - Node "assets:cash" [] - ], - Node "expenses" [ - Node "expenses:food" [], - Node "expenses:supplies" [] - ], - Node "income" [ - Node "income:gifts" [], - Node "income:salary" [] - ], - Node "liabilities" [ - Node "liabilities:debts" [] - ] - ] - ) - t - mapM_ - (\(e,a) -> assertEqual "" e a) - (zip [ - ("assets",Account "assets" [] (Mixed [dollars (-1)])) - ,("assets:bank",Account "assets:bank" [] (Mixed [dollars 1])) - ,("assets:bank:checking",Account "assets:bank:checking" [ - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [dollars 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [dollars 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [dollars (-1)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - }, - Posting { - pstatus=False, - paccount="assets:bank:checking", - pamount=(Mixed [dollars (-1)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [nullamt])) - ,("assets:bank:saving",Account "assets:bank:saving" [ - Posting { - pstatus=False, - paccount="assets:bank:saving", - pamount=(Mixed [dollars 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars 1])) - ,("assets:cash",Account "assets:cash" [ - Posting { - pstatus=False, - paccount="assets:cash", - pamount=(Mixed [dollars (-2)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars (-2)])) - ,("expenses",Account "expenses" [] (Mixed [dollars 2])) - ,("expenses:food",Account "expenses:food" [ - Posting { - pstatus=False, - paccount="expenses:food", - pamount=(Mixed [dollars 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars 1])) - ,("expenses:supplies",Account "expenses:supplies" [ - Posting { - pstatus=False, - paccount="expenses:supplies", - pamount=(Mixed [dollars 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars 1])) - ,("income",Account "income" [] (Mixed [dollars (-2)])) - ,("income:gifts",Account "income:gifts" [ - Posting { - pstatus=False, - paccount="income:gifts", - pamount=(Mixed [dollars (-1)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars (-1)])) - ,("income:salary",Account "income:salary" [ - Posting { - pstatus=False, - paccount="income:salary", - pamount=(Mixed [dollars (-1)]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars (-1)])) - ,("liabilities",Account "liabilities" [] (Mixed [dollars 1])) - ,("liabilities:debts",Account "liabilities:debts" [ - Posting { - pstatus=False, - paccount="liabilities:debts", - pamount=(Mixed [dollars 1]), - pcomment="", - ptype=RegularPosting, - ptags=[], - ptransaction=Nothing - } - ] (Mixed [dollars 1])) - ,("top",Account "top" [] (Mixed [nullamt])) - ] - (toAscList m) - ) - ] - --- | Given a list of postings, return an account name tree and three query --- functions that fetch postings, subaccount-excluding-balance and --- subaccount-including-balance by account name. -groupPostings :: [Posting] -> (Tree AccountName, - (AccountName -> [Posting]), - (AccountName -> MixedAmount), - (AccountName -> MixedAmount)) -groupPostings ps = (ant, psof, exclbalof, inclbalof) - where - anames = sort $ nub $ map paccount ps - ant = accountNameTreeFrom $ expandAccountNames anames - allanames = flatten ant - pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames]) - psof = (pmap !) - balmap = Map.fromList $ flatten $ calculateBalances ant psof - exclbalof = fst . (balmap !) - inclbalof = snd . (balmap !) - --- | Add subaccount-excluding and subaccount-including balances to a tree --- of account names somewhat efficiently, given a function that looks up --- transactions by account name. -calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount)) -calculateBalances ant psof = addbalances ant - where - addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs' - where - bal = sumPostings $ psof a - subsbal = sum $ map (snd . snd . root) subs' - subs' = map addbalances subs - --- | Convert a list of postings to a map from account name to that --- account's postings. -postingsByAccount :: [Posting] -> Map.Map AccountName [Posting] -postingsByAccount ps = m' - where - sortedps = sortBy (comparing paccount) ps - groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps - m' = Map.fromList [(paccount $ head g, g) | g <- groupedps] - -- debug helpers -- traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a -- tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps @@ -885,11 +679,10 @@ Right samplejournal = journalBalanceTransactions $ Journal (TOD 0 0) tests_Hledger_Data_Journal = TestList $ - tests_journalAccountInfo - -- [ + [ -- "query standard account types" ~: -- do -- let j = journal1 -- journalBalanceSheetAccountNames j `is` ["assets","assets:a","equity","equity:q","equity:q:qq","liabilities","liabilities:l"] -- journalProfitAndLossAccountNames j `is` ["expenses","expenses:e","income","income:i"] - -- ] + ] diff --git a/hledger-lib/Hledger/Data/Ledger.hs b/hledger-lib/Hledger/Data/Ledger.hs index 71150ffed..069c570da 100644 --- a/hledger-lib/Hledger/Data/Ledger.hs +++ b/hledger-lib/Hledger/Data/Ledger.hs @@ -9,90 +9,73 @@ balances, and postings in each account. module Hledger.Data.Ledger where -import Data.Map (Map, findWithDefault, fromList) -import Data.Tree +import qualified Data.Map as M +import Safe (headDef) import Test.HUnit import Text.Printf -import Hledger.Utils import Hledger.Data.Types -import Hledger.Data.Account (nullacct) -import Hledger.Data.AccountName +import Hledger.Data.Account import Hledger.Data.Journal import Hledger.Data.Posting import Hledger.Query instance Show Ledger where - show l = printf "Ledger with %d transactions, %d accounts\n%s" - (length (jtxns $ ledgerJournal l) + - length (jmodifiertxns $ ledgerJournal l) + - length (jperiodictxns $ ledgerJournal l)) + show l = printf "Ledger with %d transactions, %d accounts\n" --"%s" + (length (jtxns $ ljournal l) + + length (jmodifiertxns $ ljournal l) + + length (jperiodictxns $ ljournal l)) (length $ ledgerAccountNames l) - (showtree $ ledgerAccountNameTree l) + -- (showtree $ ledgerAccountNameTree l) nullledger :: Ledger -nullledger = Ledger{ - ledgerJournal = nulljournal, - ledgerAccountNameTree = nullaccountnametree, - ledgerAccountMap = fromList [] - } +nullledger = Ledger { + ljournal = nulljournal, + laccounts = [] + } --- | Filter a journal's transactions as specified, and then process them --- to derive a ledger containing all balances, the chart of accounts, --- canonicalised commodities etc. -journalToLedger :: Query -> Journal -> Ledger -journalToLedger q j = nullledger{ledgerJournal=j',ledgerAccountNameTree=t,ledgerAccountMap=amap} - where j' = filterJournalPostings q j - (t, amap) = journalAccountInfo j' - -tests_journalToLedger = [ - "journalToLedger" ~: do - assertEqual "" (0) (length $ ledgerPostings $ journalToLedger Any nulljournal) - assertEqual "" (11) (length $ ledgerPostings $ journalToLedger Any samplejournal) - assertEqual "" (6) (length $ ledgerPostings $ journalToLedger (Depth 2) samplejournal) - ] +-- | Filter a journal's transactions with the given query, then derive a +-- ledger containing the chart of accounts and balances. If the query +-- includes a depth limit, that will affect the ledger's journal but not +-- the account tree. +ledgerFromJournal :: Query -> Journal -> Ledger +ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as} + where + (q',depthq) = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q) + j' = filterJournalPostings q' j + as = accountsFromPostings $ journalPostings j' + j'' = filterJournalPostings depthq j' -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] -ledgerAccountNames = drop 1 . flatten . ledgerAccountNameTree +ledgerAccountNames = drop 1 . map aname . laccounts -- | Get the named account from a ledger. -ledgerAccount :: Ledger -> AccountName -> Account -ledgerAccount l a = findWithDefault nullacct a $ ledgerAccountMap l +ledgerAccount :: Ledger -> AccountName -> Maybe Account +ledgerAccount l a = lookupAccount a $ laccounts l --- | List a ledger's accounts, in tree order -ledgerAccounts :: Ledger -> [Account] -ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999 +-- | Get this ledger's root account, which is a dummy "root" account +-- above all others. This should always be first in the account list, +-- if somehow not this returns a null account. +ledgerRootAccount :: Ledger -> Account +ledgerRootAccount = headDef nullacct . laccounts --- | List a ledger's top-level accounts, in tree order +-- | List a ledger's top-level accounts (the ones below the root), in tree order. ledgerTopAccounts :: Ledger -> [Account] -ledgerTopAccounts = map root . branches . ledgerAccountTree 9999 +ledgerTopAccounts = asubs . head . laccounts --- | List a ledger's bottom-level (subaccount-less) accounts, in tree order +-- | List a ledger's bottom-level (subaccount-less) accounts, in tree order. ledgerLeafAccounts :: Ledger -> [Account] -ledgerLeafAccounts = leaves . ledgerAccountTree 9999 +ledgerLeafAccounts = filter (null.asubs) . laccounts -- | Accounts in ledger whose name matches the pattern, in tree order. ledgerAccountsMatching :: [String] -> Ledger -> [Account] -ledgerAccountsMatching pats = filter (matchpats pats . aname) . ledgerAccounts - --- | List a ledger account's immediate subaccounts -ledgerSubAccounts :: Ledger -> Account -> [Account] -ledgerSubAccounts l Account{aname=a} = - map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ ledgerAccountNames l +ledgerAccountsMatching pats = filter (matchpats pats . aname) . laccounts -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting] -ledgerPostings = journalPostings . ledgerJournal - --- | Get a ledger's tree of accounts to the specified depth. -ledgerAccountTree :: Int -> Ledger -> Tree Account -ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ ledgerAccountNameTree l - --- | Get a ledger's tree of accounts rooted at the specified account. -ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) -ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l +ledgerPostings = journalPostings . ljournal -- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. @@ -100,9 +83,16 @@ ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan = postingsDateSpan . ledgerPostings -- | All commodities used in this ledger, as a map keyed by symbol. -ledgerCommodities :: Ledger -> Map String Commodity -ledgerCommodities = journalCanonicalCommodities . ledgerJournal +ledgerCommodities :: Ledger -> M.Map String Commodity +ledgerCommodities = journalCanonicalCommodities . ljournal + + +tests_ledgerFromJournal = [ + "ledgerFromJournal" ~: do + assertEqual "" (0) (length $ ledgerPostings $ ledgerFromJournal Any nulljournal) + assertEqual "" (11) (length $ ledgerPostings $ ledgerFromJournal Any samplejournal) + assertEqual "" (6) (length $ ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) + ] tests_Hledger_Data_Ledger = TestList $ - tests_journalToLedger - + tests_ledgerFromJournal diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 7f80a2c1f..0716fbc31 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -11,23 +11,10 @@ Here is an overview of the hledger data model: > > Ledger -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains.. > Journal -- a filtered copy of the original journal, containing only the transactions and postings we are interested in -> Tree AccountName -- all accounts named by the journal's transactions, as a hierarchy -> Map AccountName Account -- the postings, and resulting balances, in each account +> [Account] -- all accounts, in tree order beginning with a "root" account", with their balances and sub/parent accounts For more detailed documentation on each type, see the corresponding modules. -Evolution of transaction\/entry\/posting terminology: - - - ledger 2: entries contain transactions - - - hledger 0.4: Entrys contain RawTransactions (which are flattened to Transactions) - - - ledger 3: transactions contain postings - - - hledger 0.5: LedgerTransactions contain Postings (which are flattened to Transactions) - - - hledger 0.8: Transactions contain Postings (referencing Transactions..) - -} module Hledger.Data.Types @@ -35,9 +22,7 @@ where import Control.Monad.Error (ErrorT) import Data.Time.Calendar import Data.Time.LocalTime -import Data.Tree import Data.Typeable -import qualified Data.Map as Map import System.Time (ClockTime) @@ -99,7 +84,7 @@ data Posting = Posting { ptype :: PostingType, ptags :: [Tag], ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). - -- Tying this knot gets tedious, Maybe makes it easier/optional. + -- Tying this knot gets tedious, Maybe makes it easier/optional. } -- The equality test for postings ignores the parent transaction's @@ -115,7 +100,7 @@ data Transaction = Transaction { tdescription :: String, tcomment :: String, -- ^ this transaction's non-tag comment lines, as a single non-indented string ttags :: [Tag], - tpostings :: [Posting], -- ^ this transaction's postings (co-recursive types). + tpostings :: [Posting], -- ^ this transaction's postings tpreceding_comment_lines :: String } deriving (Eq) @@ -248,15 +233,23 @@ data FormatString = deriving (Show, Eq) -data Ledger = Ledger { - ledgerJournal :: Journal, - ledgerAccountNameTree :: Tree AccountName, - ledgerAccountMap :: Map.Map AccountName Account - } - +-- | An account, with name, balances and links to parent/subaccounts +-- which let you walk up or down the account tree. data Account = Account { - aname :: AccountName, - apostings :: [Posting], -- ^ postings in this account - abalance :: MixedAmount -- ^ sum of postings in this account and subaccounts - } -- deriving (Eq) XXX + aname :: AccountName, -- ^ this account's full name + aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts + asubs :: [Account], -- ^ sub-accounts + -- derived from the above: + aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts + aparent :: Maybe Account, -- ^ parent account + aboring :: Bool -- ^ used in the accounts report to label elidable parents + } +-- | A Ledger has the journal it derives from, and the accounts +-- derived from that. Accounts are accessible both list-wise and +-- tree-wise, since each one knows its parent and subs; the first +-- account is the root of the tree and always exists. +data Ledger = Ledger { + ljournal :: Journal, + laccounts :: [Account] +} diff --git a/hledger-lib/Hledger/Reports.hs b/hledger-lib/Hledger/Reports.hs index b9d85e4e9..a92db02be 100644 --- a/hledger-lib/Hledger/Reports.hs +++ b/hledger-lib/Hledger/Reports.hs @@ -42,7 +42,6 @@ module Hledger.Reports ( AccountsReport, AccountsReportItem, accountsReport, - isInteresting, -- * Tests tests_Hledger_Reports ) @@ -51,6 +50,7 @@ where import Control.Monad import Data.List import Data.Maybe +-- import qualified Data.Map as M import Data.Ord import Data.Time.Calendar -- import Data.Tree @@ -151,6 +151,9 @@ clearedValueFromOpts ReportOpts{..} | cleared_ = Just True | uncleared_ = Just False | otherwise = Nothing +-- depthFromOpts :: ReportOpts -> Int +-- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) + -- | Report which date we will report on based on --effective. whichDateFromOpts :: ReportOpts -> WhichDate whichDateFromOpts ReportOpts{..} = if effective_ then EffectiveDate else ActualDate @@ -284,6 +287,297 @@ postingsReport opts q j = -- trace ("q: "++show q++"\nq': "++show q') $ | otherwise = requestedspan `spanIntersect` matchedspan startbal = sumPostings precedingps +totallabel = "Total" +balancelabel = "Balance" + +-- | Generate postings report line items. +postingsReportItems :: [Posting] -> Posting -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem] +postingsReportItems [] _ _ _ _ = [] +postingsReportItems (p:ps) pprev d b sumfn = i:(postingsReportItems ps p d b' sumfn) + where + i = mkpostingsReportItem isfirst p' b' + p' = p{paccount=clipAccountName d $ paccount p} + isfirst = ptransaction p /= ptransaction pprev + b' = b `sumfn` pamount p + +-- | Generate one postings report line item, given a flag indicating +-- whether to include transaction info, the posting, and the current +-- running balance. +mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem +mkpostingsReportItem False p b = (Nothing, p, b) +mkpostingsReportItem True p b = (ds, p, b) + where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de) + Nothing -> Just (nulldate,"") + +-- | Date-sort and split a list of postings into three spans - postings matched +-- by the given display expression, and the preceding and following postings. +postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting]) +postingsMatchingDisplayExpr d ps = (before, matched, after) + where + sorted = sortBy (comparing postingDate) ps + (before, rest) = break (displayExprMatches d) sorted + (matched, after) = span (displayExprMatches d) rest + +-- | Does this display expression allow this posting to be displayed ? +-- Raises an error if the display expression can't be parsed. +displayExprMatches :: Maybe String -> Posting -> Bool +displayExprMatches Nothing _ = True +displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p + +-- | Parse a hledger display expression, which is a simple date test like +-- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. +datedisplayexpr :: GenParser Char st (Posting -> Bool) +datedisplayexpr = do + char 'd' + op <- compareop + char '[' + (y,m,d) <- smartdate + char ']' + let date = parsedate $ printf "%04s/%02s/%02s" y m d + test op = return $ (`op` date) . postingDate + case op of + "<" -> test (<) + "<=" -> test (<=) + "=" -> test (==) + "==" -> test (==) + ">=" -> test (>=) + ">" -> test (>) + _ -> mzero + where + compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] + +-- -- | Clip the account names to the specified depth in a list of postings. +-- depthClipPostings :: Maybe Int -> [Posting] -> [Posting] +-- depthClipPostings depth = map (depthClipPosting depth) + +-- -- | Clip a posting's account name to the specified depth. +-- depthClipPosting :: Maybe Int -> Posting -> Posting +-- depthClipPosting Nothing p = p +-- depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a} + +-- XXX confusing, refactor + +-- | Convert a list of postings into summary postings. Summary postings +-- are one per account per interval and aggregated to the specified depth +-- if any. +summarisePostingsByInterval :: Interval -> Int -> Bool -> DateSpan -> [Posting] -> [Posting] +summarisePostingsByInterval interval depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan + where + summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s) + postingsinspan s = filter (isPostingInDateSpan s) ps + +tests_summarisePostingsByInterval = [ + "summarisePostingsByInterval" ~: do + summarisePostingsByInterval (Quarters 1) 99999 False (DateSpan Nothing Nothing) [] ~?= [] + ] + +-- | Given a date span (representing a reporting interval) and a list of +-- postings within it: aggregate the postings so there is only one per +-- account, and adjust their date/description so that they will render +-- as a summary for this interval. +-- +-- As usual with date spans the end date is exclusive, but for display +-- purposes we show the previous day as end date, like ledger. +-- +-- When a depth argument is present, postings to accounts of greater +-- depth are aggregated where possible. +-- +-- The showempty flag includes spans with no postings and also postings +-- with 0 amount. +summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting] +summarisePostingsInDateSpan (DateSpan b e) depth showempty ps + | null ps && (isNothing b || isNothing e) = [] + | null ps && showempty = [summaryp] + | otherwise = summaryps' + where + summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) + b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b + e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e + summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} + summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps + summaryps = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] + clippedanames = nub $ map (clipAccountName depth) anames + anames = sort $ nub $ map paccount ps + -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping + accts = accountsFromPostings ps + balance a = maybe nullmixedamt bal $ lookupAccount a accts + where + bal = if isclipped a then aibalance else aebalance + isclipped a = accountNameLevel a >= depth + +------------------------------------------------------------------------------- + +-- | A transactions report includes a list of transactions +-- (posting-filtered and unfiltered variants), a running balance, and some +-- other information helpful for rendering a register view (a flag +-- indicating multiple other accounts and a display string describing +-- them) with or without a notion of current account(s). +type TransactionsReport = (String -- label for the balance column, eg "balance" or "total" + ,[TransactionsReportItem] -- line items, one per transaction + ) +type TransactionsReportItem = (Transaction -- the corresponding transaction + ,Transaction -- the transaction with postings to the current account(s) removed + ,Bool -- is this a split, ie more than one other account posting + ,String -- a display string describing the other account(s), if any + ,MixedAmount -- the amount posted to the current account(s) (or total amount posted) + ,MixedAmount -- the running balance for the current account(s) after this transaction + ) + +triDate (t,_,_,_,_,_) = tdate t +triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" + (Amount{quantity=q}):_ -> show q + +-- | Select transactions from the whole journal for a transactions report, +-- with no \"current\" account. The end result is similar to +-- "postingsReport" except it uses queries and transaction-based report +-- items and the items are most recent first. Used by eg hledger-web's +-- journal view. +journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport +journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items) + where + ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts + items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts' + -- XXX items' first element should be the full transaction with all postings + +------------------------------------------------------------------------------- + +-- | Select transactions within one or more \"current\" accounts, and make a +-- transactions report relative to those account(s). This means: +-- +-- 1. it shows transactions from the point of view of the current account(s). +-- The transaction amount is the amount posted to the current account(s). +-- The other accounts' names are provided. +-- +-- 2. With no transaction filtering in effect other than a start date, it +-- shows the accurate historical running balance for the current account(s). +-- Otherwise it shows a running total starting at 0. +-- +-- Currently, reporting intervals are not supported, and report items are +-- most recent first. Used by eg hledger-web's account register view. +-- +accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport +accountTransactionsReport opts j m thisacctquery = (label, items) + where + -- transactions affecting this account, in date order + ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $ + journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + -- starting balance: if we are filtering by a start date and nothing else, + -- the sum of postings to this account before that date; otherwise zero. + (startbal,label) | queryIsNull m = (nullmixedamt, balancelabel) + | queryIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel) + | otherwise = (nullmixedamt, totallabel) + where + priorps = -- ltrace "priorps" $ + filter (matchesPosting + (-- ltrace "priormatcher" $ + And [thisacctquery, tostartdatequery])) + $ transactionsPostings ts + tostartdatequery = Date (DateSpan Nothing startdate) + startdate = queryStartDate (effective_ opts) m + items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts + +-- | Generate transactions report items from a list of transactions, +-- using the provided query and current account queries, starting balance, +-- sign-setting function and balance-summing function. +accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] +accountTransactionsReportItems _ _ _ _ [] = [] +accountTransactionsReportItems query thisacctquery bal signfn (t:ts) = + -- This is used for both accountTransactionsReport and journalTransactionsReport, + -- which makes it a bit overcomplicated + case i of Just i' -> i':is + Nothing -> is + where + tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings query t + (psthisacct,psotheracct) = case thisacctquery of Just m -> partition (matchesPosting m) psmatched + Nothing -> ([],psmatched) + numotheraccts = length $ nub $ map paccount psotheracct + amt = negate $ sum $ map pamount psthisacct + acct | isNothing thisacctquery = summarisePostings psmatched -- journal register + | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct + | otherwise = prefix ++ summarisePostingAccounts psotheracct + where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt + (i,bal') = case psmatched of + [] -> (Nothing,bal) + _ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b) + where + a = signfn amt + b = bal + a + is = accountTransactionsReportItems query thisacctquery bal' signfn ts + +-- | Generate a short readable summary of some postings, like +-- "from (negatives) to (positives)". +summarisePostings :: [Posting] -> String +summarisePostings ps = + case (summarisePostingAccounts froms, summarisePostingAccounts tos) of + ("",t) -> "to "++t + (f,"") -> "from "++f + (f,t) -> "from "++f++" to "++t + where + (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps + +-- | Generate a simplified summary of some postings' accounts. +summarisePostingAccounts :: [Posting] -> String +summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount + +filterTransactionPostings :: Query -> Transaction -> Transaction +filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} + +------------------------------------------------------------------------------- + +-- | An accounts report is a list of account names (full and short +-- variants) with their balances, appropriate indentation for rendering as +-- a hierarchy, and grand total. +type AccountsReport = ([AccountsReportItem] -- line items, one per account + ,MixedAmount -- total balance of all accounts + ) +type AccountsReportItem = (AccountName -- full account name + ,AccountName -- short account name for display (the leaf name, prefixed by any boring parents immediately above) + ,Int -- how many steps to indent this account (0-based account depth excluding boring parents) + ,MixedAmount) -- account balance, includes subs unless --flat is present + +-- | Select accounts, and get their balances at the end of the selected +-- period, and misc. display information, for an accounts report. +accountsReport :: ReportOpts -> Query -> Journal -> AccountsReport +accountsReport opts q j = (items, total) + where + l = ledgerFromJournal q $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + accts = clipAccounts (queryDepth q) $ ledgerRootAccount l + accts' + | flat_ opts = filterzeros $ tail $ flattenAccounts accts + | otherwise = filter (not.aboring) $ tail $ flattenAccounts $ markboring $ prunezeros accts + where + filterzeros | empty_ opts = id + | otherwise = filter (not . isZeroMixedAmount . aebalance) + prunezeros | empty_ opts = id + | otherwise = fromMaybe nullacct . pruneAccounts (isZeroMixedAmount.aibalance) + markboring | no_elide_ opts = id + | otherwise = markBoringParentAccounts + items = map (accountsReportItem opts) accts' + total = sum [amt | (_,_,depth,amt) <- items, depth==0] + +-- | In an account tree with zero-balance leaves removed, mark the +-- elidable parent accounts (those with one subaccount and no balance +-- of their own). +markBoringParentAccounts :: Account -> Account +markBoringParentAccounts = tieAccountParents . mapAccounts mark + where + mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True} + | otherwise = a + +accountsReportItem :: ReportOpts -> Account -> AccountsReportItem +accountsReportItem opts a@Account{aname=name, aibalance=ibal} + | flat_ opts = (name, name, 0, ibal) + | otherwise = (name, elidedname, depth, ibal) + where + elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name]) + adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents + depth = length $ filter (not.aboring) parents + parents = init $ parentAccounts a + + +------------------------------------------------------------------------------- +-- TESTS + tests_postingsReport = [ "postingsReport" ~: do @@ -450,284 +744,6 @@ tests_postingsReport = [ -} ] -totallabel = "Total" -balancelabel = "Balance" - --- | Generate postings report line items. -postingsReportItems :: [Posting] -> Posting -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem] -postingsReportItems [] _ _ _ _ = [] -postingsReportItems (p:ps) pprev d b sumfn = i:(postingsReportItems ps p d b' sumfn) - where - i = mkpostingsReportItem isfirst p' b' - p' = p{paccount=clipAccountName d $ paccount p} - isfirst = ptransaction p /= ptransaction pprev - b' = b `sumfn` pamount p - --- | Generate one postings report line item, given a flag indicating --- whether to include transaction info, the posting, and the current --- running balance. -mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem -mkpostingsReportItem False p b = (Nothing, p, b) -mkpostingsReportItem True p b = (ds, p, b) - where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de) - Nothing -> Just (nulldate,"") - --- | Date-sort and split a list of postings into three spans - postings matched --- by the given display expression, and the preceding and following postings. -postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting]) -postingsMatchingDisplayExpr d ps = (before, matched, after) - where - sorted = sortBy (comparing postingDate) ps - (before, rest) = break (displayExprMatches d) sorted - (matched, after) = span (displayExprMatches d) rest - --- | Does this display expression allow this posting to be displayed ? --- Raises an error if the display expression can't be parsed. -displayExprMatches :: Maybe String -> Posting -> Bool -displayExprMatches Nothing _ = True -displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p - --- | Parse a hledger display expression, which is a simple date test like --- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. -datedisplayexpr :: GenParser Char st (Posting -> Bool) -datedisplayexpr = do - char 'd' - op <- compareop - char '[' - (y,m,d) <- smartdate - char ']' - let date = parsedate $ printf "%04s/%02s/%02s" y m d - test op = return $ (`op` date) . postingDate - case op of - "<" -> test (<) - "<=" -> test (<=) - "=" -> test (==) - "==" -> test (==) - ">=" -> test (>=) - ">" -> test (>) - _ -> mzero - where - compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] - --- -- | Clip the account names to the specified depth in a list of postings. --- depthClipPostings :: Maybe Int -> [Posting] -> [Posting] --- depthClipPostings depth = map (depthClipPosting depth) - --- -- | Clip a posting's account name to the specified depth. --- depthClipPosting :: Maybe Int -> Posting -> Posting --- depthClipPosting Nothing p = p --- depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a} - --- XXX confusing, refactor - --- | Convert a list of postings into summary postings. Summary postings --- are one per account per interval and aggregated to the specified depth --- if any. -summarisePostingsByInterval :: Interval -> Int -> Bool -> DateSpan -> [Posting] -> [Posting] -summarisePostingsByInterval interval depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan - where - summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s) - postingsinspan s = filter (isPostingInDateSpan s) ps - -tests_summarisePostingsByInterval = [ - "summarisePostingsByInterval" ~: do - summarisePostingsByInterval (Quarters 1) 99999 False (DateSpan Nothing Nothing) [] ~?= [] - ] - --- | Given a date span (representing a reporting interval) and a list of --- postings within it: aggregate the postings so there is only one per --- account, and adjust their date/description so that they will render --- as a summary for this interval. --- --- As usual with date spans the end date is exclusive, but for display --- purposes we show the previous day as end date, like ledger. --- --- When a depth argument is present, postings to accounts of greater --- depth are aggregated where possible. --- --- The showempty flag includes spans with no postings and also postings --- with 0 amount. -summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting] -summarisePostingsInDateSpan (DateSpan b e) depth showempty ps - | null ps && (isNothing b || isNothing e) = [] - | null ps && showempty = [summaryp] - | otherwise = summaryps' - where - summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) - b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b - e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e - summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} - - summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps - summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames] - anames = sort $ nub $ map paccount ps - -- aggregate balances by account, like journalToLedger, then do depth-clipping - (_,_,exclbalof,inclbalof) = groupPostings ps - clippedanames = nub $ map (clipAccountName depth) anames - isclipped a = accountNameLevel a >= depth - balancetoshowfor a = - (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) - -------------------------------------------------------------------------------- - --- | A transactions report includes a list of transactions --- (posting-filtered and unfiltered variants), a running balance, and some --- other information helpful for rendering a register view (a flag --- indicating multiple other accounts and a display string describing --- them) with or without a notion of current account(s). -type TransactionsReport = (String -- label for the balance column, eg "balance" or "total" - ,[TransactionsReportItem] -- line items, one per transaction - ) -type TransactionsReportItem = (Transaction -- the corresponding transaction - ,Transaction -- the transaction with postings to the current account(s) removed - ,Bool -- is this a split, ie more than one other account posting - ,String -- a display string describing the other account(s), if any - ,MixedAmount -- the amount posted to the current account(s) (or total amount posted) - ,MixedAmount -- the running balance for the current account(s) after this transaction - ) - -triDate (t,_,_,_,_,_) = tdate t -triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" - (Amount{quantity=q}):_ -> show q - --- | Select transactions from the whole journal for a transactions report, --- with no \"current\" account. The end result is similar to --- "postingsReport" except it uses queries and transaction-based report --- items and the items are most recent first. Used by eg hledger-web's --- journal view. -journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport -journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items) - where - ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts - items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts' - -- XXX items' first element should be the full transaction with all postings - -------------------------------------------------------------------------------- - --- | Select transactions within one or more \"current\" accounts, and make a --- transactions report relative to those account(s). This means: --- --- 1. it shows transactions from the point of view of the current account(s). --- The transaction amount is the amount posted to the current account(s). --- The other accounts' names are provided. --- --- 2. With no transaction filtering in effect other than a start date, it --- shows the accurate historical running balance for the current account(s). --- Otherwise it shows a running total starting at 0. --- --- Currently, reporting intervals are not supported, and report items are --- most recent first. Used by eg hledger-web's account register view. --- -accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport -accountTransactionsReport opts j m thisacctquery = (label, items) - where - -- transactions affecting this account, in date order - ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $ - journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j - -- starting balance: if we are filtering by a start date and nothing else, - -- the sum of postings to this account before that date; otherwise zero. - (startbal,label) | queryIsNull m = (nullmixedamt, balancelabel) - | queryIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel) - | otherwise = (nullmixedamt, totallabel) - where - priorps = -- ltrace "priorps" $ - filter (matchesPosting - (-- ltrace "priormatcher" $ - And [thisacctquery, tostartdatequery])) - $ transactionsPostings ts - tostartdatequery = Date (DateSpan Nothing startdate) - startdate = queryStartDate (effective_ opts) m - items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts - --- | Generate transactions report items from a list of transactions, --- using the provided query and current account queries, starting balance, --- sign-setting function and balance-summing function. -accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] -accountTransactionsReportItems _ _ _ _ [] = [] -accountTransactionsReportItems query thisacctquery bal signfn (t:ts) = - -- This is used for both accountTransactionsReport and journalTransactionsReport, - -- which makes it a bit overcomplicated - case i of Just i' -> i':is - Nothing -> is - where - tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings query t - (psthisacct,psotheracct) = case thisacctquery of Just m -> partition (matchesPosting m) psmatched - Nothing -> ([],psmatched) - numotheraccts = length $ nub $ map paccount psotheracct - amt = negate $ sum $ map pamount psthisacct - acct | isNothing thisacctquery = summarisePostings psmatched -- journal register - | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct - | otherwise = prefix ++ summarisePostingAccounts psotheracct - where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt - (i,bal') = case psmatched of - [] -> (Nothing,bal) - _ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b) - where - a = signfn amt - b = bal + a - is = accountTransactionsReportItems query thisacctquery bal' signfn ts - --- | Generate a short readable summary of some postings, like --- "from (negatives) to (positives)". -summarisePostings :: [Posting] -> String -summarisePostings ps = - case (summarisePostingAccounts froms, summarisePostingAccounts tos) of - ("",t) -> "to "++t - (f,"") -> "from "++f - (f,t) -> "from "++f++" to "++t - where - (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps - --- | Generate a simplified summary of some postings' accounts. -summarisePostingAccounts :: [Posting] -> String -summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount - -filterTransactionPostings :: Query -> Transaction -> Transaction -filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} - -------------------------------------------------------------------------------- - --- | An accounts report is a list of account names (full and short --- variants) with their balances, appropriate indentation for rendering as --- a hierarchy, and grand total. -type AccountsReport = ([AccountsReportItem] -- line items, one per account - ,MixedAmount -- total balance of all accounts - ) -type AccountsReportItem = (AccountName -- full account name - ,AccountName -- short account name for display (the leaf name, prefixed by any boring parents immediately above) - ,Int -- how many steps to indent this account (0-based account depth excluding boring parents) - ,MixedAmount) -- account balance, includes subs unless --flat is present - --- | Select accounts, and get their balances at the end of the selected --- period, and misc. display information, for an accounts report. -accountsReport :: ReportOpts -> Query -> Journal -> AccountsReport -accountsReport opts q j = (items, total) - where - -- don't do depth filtering until the end - q1 = filterQuery (not . queryIsDepth) q - q2 = filterQuery queryIsDepth q - l = journalToLedger q1 $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j - acctnames = filter (q2 `matchesAccount`) $ ledgerAccountNames l - interestingaccts | no_elide_ opts = acctnames - | otherwise = filter (isInteresting opts l) acctnames - items = map mkitem interestingaccts - total = sum $ map abalance $ ledgerTopAccounts l - - -- | Get data for one balance report line item. - mkitem :: AccountName -> AccountsReportItem - mkitem a = (a, adisplay, indent, abal) - where - adisplay | flat_ opts = a - | otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a] - where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) - indent | flat_ opts = 0 - | otherwise = length interestingparents - interestingparents = filter (`elem` interestingaccts) parents - parents = parentAccountNames a - abal | flat_ opts = exclusiveBalance acct - | otherwise = abalance acct - where acct = ledgerAccount l a - tests_accountsReport = let (opts,journal) `gives` r = do let (eitems, etotal) = r @@ -971,53 +987,13 @@ Right samplejournal2 = journalBalanceTransactions $ Journal [] (TOD 0 0) -exclusiveBalance :: Account -> MixedAmount -exclusiveBalance = sumPostings . apostings - --- | Is the named account considered interesting for this ledger's accounts report, --- following the eliding style of ledger's balance command ? -isInteresting :: ReportOpts -> Ledger -> AccountName -> Bool -isInteresting opts l a | flat_ opts = isInterestingFlat opts l a - | otherwise = isInterestingIndented opts l a - --- | Determine whether an account should get its own line in the --flat balance report. -isInterestingFlat :: ReportOpts -> Ledger -> AccountName -> Bool -isInterestingFlat opts l a = notempty || emptyflag - where - acct = ledgerAccount l a - notempty = not $ isZeroMixedAmount $ exclusiveBalance acct - emptyflag = empty_ opts - --- | Determine whether an account should get its own line in the indented --- balance report. Cf Balance module doc. -isInterestingIndented :: ReportOpts -> Ledger -> AccountName -> Bool -isInterestingIndented opts l a - | numinterestingsubs == 1 && samebalanceassub && not atmaxdepth = False - | numinterestingsubs < 2 && zerobalance && not emptyflag = False - | otherwise = True - where - atmaxdepth = accountNameLevel a == depthFromOpts opts - emptyflag = empty_ opts - acct = ledgerAccount l a - zerobalance = isZeroMixedAmount inclbalance where inclbalance = abalance acct - samebalanceassub = isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct - numinterestingsubs = length $ filter isInterestingTree subtrees - where - isInterestingTree = treeany (isInteresting opts l . aname) - subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a - -tests_isInterestingIndented = [ - "isInterestingIndented" ~: do - let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r - where l = journalToLedger (queryFromOpts nulldate opts) journal +-- tests_isInterestingIndented = [ +-- "isInterestingIndented" ~: do +-- let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r +-- where l = ledgerFromJournal (queryFromOpts nulldate opts) journal - (defreportopts, samplejournal, "expenses") `gives` True - ] - -depthFromOpts :: ReportOpts -> Int -depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) - -------------------------------------------------------------------------------- +-- (defreportopts, samplejournal, "expenses") `gives` True +-- ] tests_Hledger_Reports :: Test tests_Hledger_Reports = TestList $ @@ -1026,7 +1002,7 @@ tests_Hledger_Reports = TestList $ ++ tests_entriesReport ++ tests_summarisePostingsByInterval ++ tests_postingsReport - ++ tests_isInterestingIndented + -- ++ tests_isInterestingIndented ++ tests_accountsReport ++ [ -- ,"summarisePostingsInDateSpan" ~: do diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index 25970f973..6f76041c4 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -31,6 +31,7 @@ import Control.Monad.Error (MonadIO) import Control.Monad.IO.Class (liftIO) import Data.Char import Data.List +import qualified Data.Map as M import Data.Maybe import Data.Time.Clock import Data.Time.LocalTime @@ -237,6 +238,8 @@ splitAtElement e l = -- trees +-- standard tree helpers + root = rootLabel subs = subForest branches = subForest @@ -291,6 +294,25 @@ showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treema showforest :: Show a => Forest a -> String showforest = concatMap showtree + +-- | An efficient-to-build tree suggested by Cale Gibbard, probably +-- better than accountNameTreeFrom. +newtype FastTree a = T (M.Map a (FastTree a)) + deriving (Show, Eq, Ord) + +emptyTree = T M.empty + +mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a +mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') + +treeFromPath :: [a] -> FastTree a +treeFromPath [] = T M.empty +treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) + +treeFromPaths :: (Ord a) => [[a]] -> FastTree a +treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath + + -- debugging -- | trace (print on stdout at runtime) a showable expression diff --git a/hledger-web/Hledger/Web/Handlers.hs b/hledger-web/Hledger/Web/Handlers.hs index 4aeafb632..ce0d12c74 100644 --- a/hledger-web/Hledger/Web/Handlers.hs +++ b/hledger-web/Hledger/Web/Handlers.hs @@ -269,7 +269,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) = |] where - l = journalToLedger Any j + l = ledgerFromJournal Any j inacctmatcher = inAccountQuery qopts allaccts = isNothing inacctmatcher items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher diff --git a/hledger/Hledger/Cli.hs b/hledger/Hledger/Cli.hs index bb7bd5cec..9b65f3adf 100644 --- a/hledger/Hledger/Cli.hs +++ b/hledger/Hledger/Cli.hs @@ -133,11 +133,6 @@ tests_Hledger_Cli = TestList ,"show hours" ~: showAmount (hours 1) ~?= "1.0h" - ,"subAccounts" ~: do - let l = journalToLedger Any samplejournal - a = ledgerAccount l "assets" - map aname (ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"] - ] @@ -539,7 +534,7 @@ journal7 = Journal [] (TOD 0 0) -ledger7 = journalToLedger Any journal7 +ledger7 = ledgerFromJournal Any journal7 -- journal8_str = unlines -- ["2008/1/1 test " diff --git a/hledger/Hledger/Cli/Add.hs b/hledger/Hledger/Cli/Add.hs index 93e9f73e2..6f728db91 100644 --- a/hledger/Hledger/Cli/Add.hs +++ b/hledger/Hledger/Cli/Add.hs @@ -24,7 +24,6 @@ import System.IO ( stderr, hPutStrLn, hPutStr ) import System.IO.Error import Text.ParserCombinators.Parsec import Text.Printf -import qualified Data.Foldable as Foldable (find) import qualified Data.Set as Set import Hledger @@ -88,9 +87,9 @@ getTransaction j opts defaultDate = do date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr accept x = x == "." || (not . null) x && if no_new_accounts_ opts - then isJust $ Foldable.find (== x) ant + then x `elem` existingaccts else True - where (ant,_,_,_) = groupPostings $ journalPostings j + existingaccts = journalAccountNames j getpostingsandvalidate = do ps <- getPostings (PostingState j accept True bestmatchpostings) [] let t = nulltransaction{tdate=date diff --git a/hledger/Hledger/Cli/Stats.hs b/hledger/Hledger/Cli/Stats.hs index a14b6a218..852650b99 100644 --- a/hledger/Hledger/Cli/Stats.hs +++ b/hledger/Hledger/Cli/Stats.hs @@ -25,7 +25,7 @@ stats :: CliOpts -> Journal -> IO () stats CliOpts{reportopts_=reportopts_} j = do d <- getCurrentDay let q = queryFromOpts d reportopts_ - l = journalToLedger q j + l = ledgerFromJournal q j reportspan = (ledgerDateSpan l) `orDatesFrom` (queryDateSpan False q) intervalspans = splitSpan (intervalFromOpts reportopts_) reportspan showstats = showLedgerStats l d @@ -58,7 +58,7 @@ showLedgerStats l today span = -- Days since last transaction : %(recentelapsed)s ] where - j = ledgerJournal l + j = ljournal l path = journalFilePath j ts = sortBy (comparing tdate) $ filter (spanContainsDate span . tdate) $ jtxns j as = nub $ map paccount $ concatMap tpostings ts