mirror of
https://github.com/simonmichael/hledger.git
synced 2024-12-29 05:11:33 +03:00
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 |
+-------------------------------------------++--------------+------------+--------+
This commit is contained in:
Simon Michael
parent
cb2a4e543f
commit
00f22819ae
@ -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 [
|
||||
]
|
||||
|
||||
@ -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`
|
||||
|
||||
@ -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"]
|
||||
-- ]
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
}
|
||||
|
||||
@ -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
|
||||
-- tests_isInterestingIndented = [
|
||||
-- "isInterestingIndented" ~: do
|
||||
-- let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r
|
||||
-- where l = ledgerFromJournal (queryFromOpts nulldate opts) journal
|
||||
|
||||
-- | 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
|
||||
|
||||
(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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -269,7 +269,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
|
||||
<td>
|
||||
|]
|
||||
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
|
||||
|
||||
@ -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 "
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user