module Hledger.Reports.MultiBalanceReports (
MultiBalanceReport(..),
MultiBalanceReportRow,
multiBalanceReport,
singleBalanceReport,
tests_Hledger_Reports_MultiBalanceReport
)
where
import Data.List
import Data.Maybe
import Data.Ord
import Data.Time.Calendar
import Safe
import Test.HUnit
import Hledger.Data
import Hledger.Query
import Hledger.Utils
import Hledger.Read (mamountp')
import Hledger.Reports.ReportOptions
import Hledger.Reports.BalanceReport
newtype MultiBalanceReport =
MultiBalanceReport ([DateSpan]
,[MultiBalanceReportRow]
,MultiBalanceReportTotals
)
type MultiBalanceReportRow = (AccountName, AccountName, Int, [MixedAmount], MixedAmount, MixedAmount)
type MultiBalanceReportTotals = ([MixedAmount], MixedAmount, MixedAmount)
instance Show MultiBalanceReport where
show (MultiBalanceReport (spans, items, totals)) =
"MultiBalanceReport (ignore extra quotes):\n" ++ ppShow (show spans, map show items, totals)
type ClippedAccountName = AccountName
singleBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
singleBalanceReport opts q j = (rows', total)
where
MultiBalanceReport (_, rows, (totals, _, _)) = multiBalanceReport opts q j
rows' = [(a
,if flat_ opts then a else a'
,if tree_ opts then d1 else 0
, headDef nullmixedamt amts
) | (a,a',d, amts, _, _) <- rows]
total = headDef nullmixedamt totals
multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
multiBalanceReport opts q j = MultiBalanceReport (displayspans, sorteditems, totalsrow)
where
symq = dbg1 "symq" $ filterQuery queryIsSym $ dbg1 "requested q" q
depthq = dbg1 "depthq" $ filterQuery queryIsDepth q
depth = queryDepth depthq
depthless = dbg1 "depthless" . filterQuery (not . queryIsDepth)
datelessq = dbg1 "datelessq" $ filterQuery (not . queryIsDateOrDate2) q
dateqcons = if date2_ opts then Date2 else Date
precedingq = dbg1 "precedingq" $ And [datelessq, dateqcons $ DateSpan Nothing (spanStart reportspan)]
requestedspan = dbg1 "requestedspan" $ queryDateSpan (date2_ opts) q
requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j
intervalspans = dbg1 "intervalspans" $ splitSpan (interval_ opts) requestedspan'
reportspan = dbg1 "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans)
(maybe Nothing spanEnd $ lastMay intervalspans)
newdatesq = dbg1 "newdateq" $ dateqcons reportspan
reportq = dbg1 "reportq" $ depthless $ And [datelessq, newdatesq]
ps :: [Posting] =
dbg1 "ps" $
journalPostings $
filterJournalAmounts symq $
filterJournalPostings reportq $
journalSelectingAmountFromOpts opts j
displayspans = dbg1 "displayspans" $ splitSpan (interval_ opts) displayspan
where
displayspan
| empty_ opts = dbg1 "displayspan (-E)" reportspan
| otherwise = dbg1 "displayspan" $ requestedspan `spanIntersect` matchedspan
matchedspan = dbg1 "matchedspan" $ postingsDateSpan' (whichDateFromOpts opts) ps
psPerSpan :: [[Posting]] =
dbg1 "psPerSpan"
[filter (isPostingInDateSpan' (whichDateFromOpts opts) s) ps | s <- displayspans]
postedAcctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =
dbg1 "postedAcctBalChangesPerSpan" $
map postingAcctBals psPerSpan
where
postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)]
postingAcctBals ps = [(aname a, (if tree_ opts then aibalance else aebalance) a) | a <- as]
where
as = depthLimit $
(if tree_ opts then id else filter ((>0).anumpostings)) $
drop 1 $ accountsFromPostings ps
depthLimit
| tree_ opts = filter ((depthq `matchesAccount`).aname)
| otherwise = clipAccountsAndAggregate depth
postedAccts :: [AccountName] = dbg1 "postedAccts" $ sort $ accountNamesFromPostings ps
startacctbals = dbg1 "startacctbals" $ map (\(a,_,_,b) -> (a,b)) startbalanceitems
where
(startbalanceitems,_) = dbg1 "starting balance report" $ balanceReport opts' precedingq j
where
opts' | tree_ opts = opts{no_elide_=True}
| otherwise = opts{accountlistmode_=ALFlat}
startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals
startAccts = dbg1 "startAccts" $ map fst startacctbals
displayedAccts :: [ClippedAccountName] =
dbg1 "displayedAccts" $
(if tree_ opts then expandAccountNames else id) $
nub $ map (clipOrEllipsifyAccountName depth) $
if empty_ opts || (balancetype_ opts) == HistoricalBalance then nub $ sort $ startAccts ++ postedAccts else postedAccts
acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =
dbg1 "acctBalChangesPerSpan"
[sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') postedacctbals zeroes
| postedacctbals <- postedAcctBalChangesPerSpan]
where zeroes = [(a, nullmixedamt) | a <- displayedAccts]
acctBalChanges :: [(ClippedAccountName, [MixedAmount])] =
dbg1 "acctBalChanges"
[(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan]
items :: [MultiBalanceReportRow] =
dbg1 "items" $
[(a, accountLeafName a, accountNameLevel a, displayedBals, rowtot, rowavg)
| (a,changes) <- acctBalChanges
, let displayedBals = case balancetype_ opts of
HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes
CumulativeChange -> drop 1 $ scanl (+) nullmixedamt changes
_ -> changes
, let rowtot = sum displayedBals
, let rowavg = averageMixedAmounts displayedBals
, empty_ opts || depth == 0 || any (not . isZeroMixedAmount) displayedBals
]
sorteditems :: [MultiBalanceReportRow] =
dbg1 "sorteditems" $
maybesort items
where
maybesort
| not $ sort_amount_ opts = id
| accountlistmode_ opts == ALTree = sortTreeMultiBalanceReportRowsByAmount
| otherwise = sortFlatMultiBalanceReportRowsByAmount
where
sortFlatMultiBalanceReportRowsByAmount = sortBy (maybeflip $ comparing fifth6)
where
maybeflip = if normalbalance_ opts == Just NormalNegative then id else flip
sortTreeMultiBalanceReportRowsByAmount rows = sortedrows
where
anamesandrows = [(first6 r, r) | r <- rows]
anames = map fst anamesandrows
atotals = [(a,tot) | (a,_,_,_,tot,_) <- rows]
nametree = treeFromPaths $ map expandAccountName anames
accounttree = nameTreeToAccount "root" nametree
accounttreewithbals = mapAccounts setibalance accounttree
where
setibalance a = a{aibalance=fromMaybe (error "sortTreeMultiBalanceReportRowsByAmount 1") $ lookup (aname a) atotals}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormalPositive $ normalbalance_ opts) accounttreewithbals
sortedaccounts = drop 1 $ flattenAccounts sortedaccounttree
sortedrows = [
fromMaybe (error "sortTreeMultiBalanceReportRowsByAmount 2") $ lookup (aname a) anamesandrows
| a <- sortedaccounts
]
totals :: [MixedAmount] =
map sum balsbycol
where
balsbycol = transpose [bs | (a,_,_,bs,_,_) <- sorteditems, not (tree_ opts) || a `elem` highestlevelaccts]
highestlevelaccts =
dbg1 "highestlevelaccts"
[a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a]
totalsrow :: MultiBalanceReportTotals =
dbg1 "totalsrow"
(totals, sum totals, averageMixedAmounts totals)
dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s)
tests_multiBalanceReport =
let
(opts,journal) `gives` r = do
let (eitems, etotal) = r
(MultiBalanceReport (_, aitems, atotal)) = multiBalanceReport opts (queryFromOpts nulldate opts) journal
showw (acct,acct',indent,lAmt,amt,amt') = (acct, acct', indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')
assertEqual "items" (map showw eitems) (map showw aitems)
assertEqual "total" (showMixedAmountDebug etotal) ((\(_, b, _) -> showMixedAmountDebug b) atotal)
usd0 = usd 0
amount0 = Amount {acommodity="$", aquantity=0, aprice=NoPrice, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, amultiplier=False}
in [
"multiBalanceReport with no args on null journal" ~: do
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,"multiBalanceReport with -H on a populated period" ~: do
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
(
[
("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])
,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(1)}])
],
Mixed [usd0])
,"multiBalanceReport tests the ability to have a valid history on an empty period" ~: do
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`
(
[
("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])
,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(1)}])
],
Mixed [usd0])
,"multiBalanceReport tests the ability to have a valid history on an empty period (More complex)" ~: do
(defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
(
[
("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])
,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}])
,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amount0 {aquantity=(2)}])
,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])
,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}])
,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(1)}])
,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(1)}])
],
Mixed [usd0])
]
tests_Hledger_Reports_MultiBalanceReport :: Test
tests_Hledger_Reports_MultiBalanceReport = TestList
tests_multiBalanceReport