diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/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 "" [] nullmixedamt +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 " ") + tests_Hledger_Data_Account = TestList [ ] diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -10,11 +10,9 @@ 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,9 +40,12 @@ -- | ["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] topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1] @@ -72,83 +73,15 @@ -- | 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 @@ 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/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -23,7 +23,6 @@ filterJournalPostings, filterJournalTransactions, -- * Querying - journalAccountInfo, journalAccountNames, journalAccountNamesUsed, journalAmountAndPriceCommodities, @@ -43,7 +42,6 @@ journalEquityAccountQuery, journalCashAccountQuery, -- * Misc - groupPostings, matchpats, nullctx, nulljournal, @@ -53,7 +51,7 @@ ) 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 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 @@ 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 @@ (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/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -9,90 +9,73 @@ 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 [] - } - --- | 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' +nullledger = Ledger { + ljournal = nulljournal, + laccounts = [] + } -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 = 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_Hledger_Data_Ledger = TestList $ - tests_journalToLedger +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_ledgerFromJournal diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -11,23 +11,10 @@ > > 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 @@ 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 @@ 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 @@ 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 @@ 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/Reports.hs b/Hledger/Reports.hs --- a/Hledger/Reports.hs +++ b/Hledger/Reports.hs @@ -42,7 +42,6 @@ AccountsReport, AccountsReportItem, accountsReport, - isInteresting, -- * Tests tests_Hledger_Reports ) @@ -51,6 +50,7 @@ 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 @@ | 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,172 +287,6 @@ | otherwise = requestedspan `spanIntersect` matchedspan startbal = sumPostings precedingps -tests_postingsReport = [ - "postingsReport" ~: do - - -- with the query specified explicitly - let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n - (Any, nulljournal) `gives` 0 - (Any, samplejournal) `gives` 11 - -- register --depth just clips account names - (Depth 2, samplejournal) `gives` 11 - (And [Depth 1, Status True, Acct "expenses"], samplejournal) `gives` 2 - (And [And [Depth 1, Status True], Acct "expenses"], samplejournal) `gives` 2 - - -- with query and/or command-line options - assertEqual "" 11 (length $ snd $ postingsReport defreportopts Any samplejournal) - assertEqual "" 9 (length $ snd $ postingsReport defreportopts{monthly_=True} Any samplejournal) - assertEqual "" 19 (length $ snd $ postingsReport defreportopts{monthly_=True} (Empty True) samplejournal) - assertEqual "" 4 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) - - -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 - -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1) - -- ,(Nothing,income:salary $-1,0) - -- ,(Just (2008-06-01,"gift"),assets:bank:checking $1,$1) - -- ,(Nothing,income:gifts $-1,0) - -- ,(Just (2008-06-02,"save"),assets:bank:saving $1,$1) - -- ,(Nothing,assets:bank:checking $-1,0) - -- ,(Just (2008-06-03,"eat & shop"),expenses:food $1,$1) - -- ,(Nothing,expenses:supplies $1,$2) - -- ,(Nothing,assets:cash $-2,0) - -- ,(Just (2008-12-31,"pay off"),liabilities:debts $1,$1) - -- ,(Nothing,assets:bank:checking $-1,0) - -- ] - -{- - let opts = defreportopts - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/01/01 income assets:bank:checking $1 $1" - ," income:salary $-1 0" - ,"2008/06/01 gift assets:bank:checking $1 $1" - ," income:gifts $-1 0" - ,"2008/06/02 save assets:bank:saving $1 $1" - ," assets:bank:checking $-1 0" - ,"2008/06/03 eat & shop expenses:food $1 $1" - ," expenses:supplies $1 $2" - ," assets:cash $-2 0" - ,"2008/12/31 pay off liabilities:debts $1 $1" - ," assets:bank:checking $-1 0" - ] - - ,"postings report with cleared option" ~: - do - let opts = defreportopts{cleared_=True} - j <- readJournal' sample_journal_str - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/06/03 eat & shop expenses:food $1 $1" - ," expenses:supplies $1 $2" - ," assets:cash $-2 0" - ,"2008/12/31 pay off liabilities:debts $1 $1" - ," assets:bank:checking $-1 0" - ] - - ,"postings report with uncleared option" ~: - do - let opts = defreportopts{uncleared_=True} - j <- readJournal' sample_journal_str - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/01/01 income assets:bank:checking $1 $1" - ," income:salary $-1 0" - ,"2008/06/01 gift assets:bank:checking $1 $1" - ," income:gifts $-1 0" - ,"2008/06/02 save assets:bank:saving $1 $1" - ," assets:bank:checking $-1 0" - ] - - ,"postings report sorts by date" ~: - do - j <- readJournal' $ unlines - ["2008/02/02 a" - ," b 1" - ," c" - ,"" - ,"2008/01/01 d" - ," e 1" - ," f" - ] - let opts = defreportopts - registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"] - - ,"postings report with account pattern" ~: - do - j <- samplejournal - let opts = defreportopts{patterns_=["cash"]} - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/06/03 eat & shop assets:cash $-2 $-2" - ] - - ,"postings report with account pattern, case insensitive" ~: - do - j <- samplejournal - let opts = defreportopts{patterns_=["cAsH"]} - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/06/03 eat & shop assets:cash $-2 $-2" - ] - - ,"postings report with display expression" ~: - do - j <- samplejournal - let gives displayexpr = - (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`) - where opts = defreportopts{display_=Just displayexpr} - "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] - "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] - "d=[2008/6/2]" `gives` ["2008/06/02"] - "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"] - "d>[2008/6/2]" `gives` ["2008/06/03","2008/12/31"] - - ,"postings report with period expression" ~: - do - j <- samplejournal - let periodexpr `gives` dates = do - j' <- samplejournal - registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates - where opts = defreportopts{period_=maybePeriod date1 periodexpr} - "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] - "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] - "2007" `gives` [] - "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] - "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] - "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] - let opts = defreportopts{period_=maybePeriod date1 "yearly"} - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" - ," assets:cash $-2 $-1" - ," expenses:food $1 0" - ," expenses:supplies $1 $1" - ," income:gifts $-1 0" - ," income:salary $-1 $-1" - ," liabilities:debts $1 0" - ] - let opts = defreportopts{period_=maybePeriod date1 "quarterly"} - registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"] - let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True} - registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] - - ] - - , "postings report with depth arg" ~: - do - j <- samplejournal - let opts = defreportopts{depth_=Just 2} - (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines - ["2008/01/01 income assets:bank $1 $1" - ," income:salary $-1 0" - ,"2008/06/01 gift assets:bank $1 $1" - ," income:gifts $-1 0" - ,"2008/06/02 save assets:bank $1 $1" - ," assets:bank $-1 0" - ,"2008/06/03 eat & shop expenses:food $1 $1" - ," expenses:supplies $1 $2" - ," assets:cash $-2 0" - ,"2008/12/31 pay off liabilities:debts $1 $1" - ," assets:bank $-1 0" - ] - --} - ] - totallabel = "Total" balancelabel = "Balance" @@ -557,16 +394,16 @@ 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 + summaryps = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] 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) + 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 ------------------------------------------------------------------------------- @@ -703,31 +540,210 @@ 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) + 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 - 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 + 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 + + -- with the query specified explicitly + let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n + (Any, nulljournal) `gives` 0 + (Any, samplejournal) `gives` 11 + -- register --depth just clips account names + (Depth 2, samplejournal) `gives` 11 + (And [Depth 1, Status True, Acct "expenses"], samplejournal) `gives` 2 + (And [And [Depth 1, Status True], Acct "expenses"], samplejournal) `gives` 2 + + -- with query and/or command-line options + assertEqual "" 11 (length $ snd $ postingsReport defreportopts Any samplejournal) + assertEqual "" 9 (length $ snd $ postingsReport defreportopts{monthly_=True} Any samplejournal) + assertEqual "" 19 (length $ snd $ postingsReport defreportopts{monthly_=True} (Empty True) samplejournal) + assertEqual "" 4 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) + + -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 + -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1) + -- ,(Nothing,income:salary $-1,0) + -- ,(Just (2008-06-01,"gift"),assets:bank:checking $1,$1) + -- ,(Nothing,income:gifts $-1,0) + -- ,(Just (2008-06-02,"save"),assets:bank:saving $1,$1) + -- ,(Nothing,assets:bank:checking $-1,0) + -- ,(Just (2008-06-03,"eat & shop"),expenses:food $1,$1) + -- ,(Nothing,expenses:supplies $1,$2) + -- ,(Nothing,assets:cash $-2,0) + -- ,(Just (2008-12-31,"pay off"),liabilities:debts $1,$1) + -- ,(Nothing,assets:bank:checking $-1,0) + -- ] + +{- + let opts = defreportopts + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/01/01 income assets:bank:checking $1 $1" + ," income:salary $-1 0" + ,"2008/06/01 gift assets:bank:checking $1 $1" + ," income:gifts $-1 0" + ,"2008/06/02 save assets:bank:saving $1 $1" + ," assets:bank:checking $-1 0" + ,"2008/06/03 eat & shop expenses:food $1 $1" + ," expenses:supplies $1 $2" + ," assets:cash $-2 0" + ,"2008/12/31 pay off liabilities:debts $1 $1" + ," assets:bank:checking $-1 0" + ] + + ,"postings report with cleared option" ~: + do + let opts = defreportopts{cleared_=True} + j <- readJournal' sample_journal_str + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/06/03 eat & shop expenses:food $1 $1" + ," expenses:supplies $1 $2" + ," assets:cash $-2 0" + ,"2008/12/31 pay off liabilities:debts $1 $1" + ," assets:bank:checking $-1 0" + ] + + ,"postings report with uncleared option" ~: + do + let opts = defreportopts{uncleared_=True} + j <- readJournal' sample_journal_str + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/01/01 income assets:bank:checking $1 $1" + ," income:salary $-1 0" + ,"2008/06/01 gift assets:bank:checking $1 $1" + ," income:gifts $-1 0" + ,"2008/06/02 save assets:bank:saving $1 $1" + ," assets:bank:checking $-1 0" + ] + + ,"postings report sorts by date" ~: + do + j <- readJournal' $ unlines + ["2008/02/02 a" + ," b 1" + ," c" + ,"" + ,"2008/01/01 d" + ," e 1" + ," f" + ] + let opts = defreportopts + registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"] + + ,"postings report with account pattern" ~: + do + j <- samplejournal + let opts = defreportopts{patterns_=["cash"]} + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/06/03 eat & shop assets:cash $-2 $-2" + ] + + ,"postings report with account pattern, case insensitive" ~: + do + j <- samplejournal + let opts = defreportopts{patterns_=["cAsH"]} + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/06/03 eat & shop assets:cash $-2 $-2" + ] + + ,"postings report with display expression" ~: + do + j <- samplejournal + let gives displayexpr = + (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`) + where opts = defreportopts{display_=Just displayexpr} + "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] + "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] + "d=[2008/6/2]" `gives` ["2008/06/02"] + "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"] + "d>[2008/6/2]" `gives` ["2008/06/03","2008/12/31"] + + ,"postings report with period expression" ~: + do + j <- samplejournal + let periodexpr `gives` dates = do + j' <- samplejournal + registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates + where opts = defreportopts{period_=maybePeriod date1 periodexpr} + "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] + "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] + "2007" `gives` [] + "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] + "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] + "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] + let opts = defreportopts{period_=maybePeriod date1 "yearly"} + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" + ," assets:cash $-2 $-1" + ," expenses:food $1 0" + ," expenses:supplies $1 $1" + ," income:gifts $-1 0" + ," income:salary $-1 $-1" + ," liabilities:debts $1 0" + ] + let opts = defreportopts{period_=maybePeriod date1 "quarterly"} + registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"] + let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True} + registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] + + ] + + , "postings report with depth arg" ~: + do + j <- samplejournal + let opts = defreportopts{depth_=Just 2} + (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines + ["2008/01/01 income assets:bank $1 $1" + ," income:salary $-1 0" + ,"2008/06/01 gift assets:bank $1 $1" + ," income:gifts $-1 0" + ,"2008/06/02 save assets:bank $1 $1" + ," assets:bank $-1 0" + ,"2008/06/03 eat & shop expenses:food $1 $1" + ," expenses:supplies $1 $2" + ," assets:cash $-2 0" + ,"2008/12/31 pay off liabilities:debts $1 $1" + ," assets:bank $-1 0" + ] + +-} + ] + tests_accountsReport = let (opts,journal) `gives` r = do let (eitems, etotal) = r @@ -971,53 +987,13 @@ [] (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_entriesReport ++ tests_summarisePostingsByInterval ++ tests_postingsReport - ++ tests_isInterestingIndented + -- ++ tests_isInterestingIndented ++ tests_accountsReport ++ [ -- ,"summarisePostingsInDateSpan" ~: do diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -31,6 +31,7 @@ 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 @@ -- trees +-- standard tree helpers + root = rootLabel subs = subForest branches = subForest @@ -290,6 +293,25 @@ -- | show a compact ascii representation of a forest 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 diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,5 @@ name: hledger-lib -version: 0.18.2 +version: 0.19 category: Finance synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: @@ -17,7 +17,7 @@ homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues stability: beta -tested-with: GHC==7.0.4, GHC==7.2.2, GHC==7.4.1 +tested-with: GHC==7.0.4, GHC==7.2.2, GHC==7.4.1, GHC==7.6.1 cabal-version: >= 1.8 build-type: Simple -- data-dir: data @@ -57,7 +57,7 @@ Build-Depends: base >= 4.3 && < 5 ,bytestring - ,cmdargs >= 0.9.1 && < 0.10 + ,cmdargs >= 0.10 && < 0.11 ,containers ,csv ,directory @@ -69,7 +69,7 @@ ,regexpr >= 0.5.1 ,safe >= 0.2 ,shakespeare-text >= 1.0 && < 1.1 - ,split == 0.1.* + ,split >= 0.1 && < 0.3 ,time ,transformers >= 0.2 && < 0.4 ,utf8-string >= 0.3.5 && < 0.4