{-# LANGUAGE FlexibleInstances, RecordWildCards, ScopedTypeVariables, OverloadedStrings, DeriveGeneric #-}
module Hledger.Reports.MultiBalanceReport (
MultiBalanceReport,
MultiBalanceReportRow,
multiBalanceReport,
multiBalanceReportWith,
balanceReportFromMultiBalanceReport,
tableAsText,
tests_MultiBalanceReport
)
where
import Data.List
import Data.List.Extra (nubSort)
import qualified Data.Map as M
import Data.Maybe
import Data.Ord
import Data.Time.Calendar
import Safe
import Text.Tabular as T
import Text.Tabular.AsciiWide
import Hledger.Data
import Hledger.Query
import Hledger.Utils
import Hledger.Read (mamountp')
import Hledger.Reports.ReportOptions
import Hledger.Reports.ReportTypes
import Hledger.Reports.BalanceReport
type MultiBalanceReport = PeriodicReport AccountName MixedAmount
type MultiBalanceReportRow = PeriodicReportRow AccountName MixedAmount
type ClippedAccountName = AccountName
multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
multiBalanceReport ropts q j = multiBalanceReportWith ropts q j (journalPriceOracle j)
multiBalanceReportWith :: ReportOpts -> Query -> Journal -> PriceOracle -> MultiBalanceReport
multiBalanceReportWith ropts@ReportOpts{..} q j priceoracle =
(if invert_ then prNegate else id) $
PeriodicReport colspans mappedsortedrows mappedtotalsrow
where
dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s)
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_ then Date2 else Date
requestedspan = dbg1 "requestedspan" $ queryDateSpan date2_ q
requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan date2_ j
intervalspans = dbg1 "intervalspans" $ splitSpan interval_ requestedspan'
reportspan = dbg1 "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans)
(maybe Nothing spanEnd $ lastMay intervalspans)
mreportstart = spanStart reportspan
reportq = dbg1 "reportq" $ depthless $
if reportspan == nulldatespan
then q
else And [datelessq, reportspandatesq]
where
reportspandatesq = dbg1 "reportspandatesq" $ dateqcons reportspan
colspans :: [DateSpan] = dbg1 "colspans" $ splitSpan interval_ displayspan
where
displayspan
| empty_ = dbg1 "displayspan (-E)" reportspan
| otherwise = dbg1 "displayspan" $ requestedspan `spanIntersect` matchedspan
matchedspan = dbg1 "matchedspan" . daysSpan $ map snd ps
j' = journalSelectingAmountFromOpts ropts j
startbals :: [(AccountName, MixedAmount)] = dbg1 "startbals" $ map (\(a,_,_,b) -> (a,b)) startbalanceitems
where
(startbalanceitems,_) = dbg1 "starting balance report" $ balanceReport ropts''{value_=Nothing, percent_=False} startbalq j'
where
ropts' | tree_ ropts = ropts{no_elide_=True}
| otherwise = ropts{accountlistmode_=ALFlat}
ropts'' = ropts'{period_ = precedingperiod}
where
precedingperiod = dateSpanAsPeriod $ spanIntersect (DateSpan Nothing mreportstart) $ periodAsDateSpan period_
startbalq = dbg1 "startbalq" $ And [datelessq, dateqcons precedingspan]
where
precedingspan = case mreportstart of
Just d -> DateSpan Nothing (Just d)
Nothing -> emptydatespan
startaccts = dbg1 "startaccts" $ map fst startbals
startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startbals
ps :: [(Posting, Day)] =
dbg1 "ps" $
map postingWithDate $
journalPostings $
filterJournalAmounts symq $
filterJournalPostings reportq $
j'
where
postingWithDate p = case whichDateFromOpts ropts of
PrimaryDate -> (p, postingDate p)
SecondaryDate -> (p, postingDate2 p)
colps :: [([Posting], Maybe Day)] =
dbg1 "colps"
[ (posts, end) | (DateSpan _ end, posts) <- M.toList colMap ]
where
colMap = foldr addPosting emptyMap ps
addPosting (p, d) = maybe id (M.adjust (p:)) $ latestSpanContaining colspans d
emptyMap = M.fromList . zip colspans $ repeat []
acctChangesFromPostings :: [Posting] -> [(ClippedAccountName, MixedAmount)]
acctChangesFromPostings ps = [(aname a, (if tree_ ropts then aibalance else aebalance) a) | a <- as]
where
as = depthLimit $
(if tree_ ropts then id else filter ((>0).anumpostings)) $
drop 1 $ accountsFromPostings ps
depthLimit
| tree_ ropts = filter ((depthq `matchesAccount`).aname)
| otherwise = clipAccountsAndAggregate depth
colacctchanges :: [[(ClippedAccountName, MixedAmount)]] =
dbg1 "colacctchanges" $ map (acctChangesFromPostings . fst) colps
displayaccts :: [ClippedAccountName] =
dbg1 "displayaccts" $
(if tree_ ropts then expandAccountNames else id) $
nub $ map (clipOrEllipsifyAccountName depth) $
if empty_ || balancetype_ == HistoricalBalance
then nubSort $ startaccts ++ allpostedaccts
else allpostedaccts
where
allpostedaccts :: [AccountName] =
dbg1 "allpostedaccts" . sort . accountNamesFromPostings $ map fst ps
colallacctchanges :: [[(ClippedAccountName, MixedAmount)]] =
dbg1 "colallacctchanges"
[ sortOn fst $ unionBy (\(a,_) (a',_) -> a == a') postedacctchanges zeroes
| postedacctchanges <- colacctchanges ]
where zeroes = [(a, nullmixedamt) | a <- displayaccts]
acctchanges :: [(ClippedAccountName, [MixedAmount])] =
dbg1 "acctchanges"
[(a, map snd abs) | abs@((a,_):_) <- transpose colallacctchanges]
rows :: [MultiBalanceReportRow] =
dbg1 "rows" $
[ PeriodicReportRow a (accountNameLevel a) valuedrowbals rowtot rowavg
| (a,changes) <- dbg1 "acctchanges" acctchanges
, let rowbals = dbg1 "rowbals" $ case balancetype_ of
PeriodChange -> changes
CumulativeChange -> drop 1 $ scanl (+) 0 changes
HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes
, let valuedrowbals = dbg1 "valuedrowbals" $ [avalue periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays]
, let rowtot = if balancetype_==PeriodChange then sum valuedrowbals else 0
, let rowavg = averageMixedAmounts valuedrowbals
, empty_ || depth == 0 || any (not . isZeroMixedAmount) valuedrowbals
]
where
avalue periodlast =
maybe id (mixedAmountApplyValuation priceoracle styles periodlast mreportlast today multiperiod) value_
where
styles = journalCommodityStyles j
mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "multiBalanceReport: could not pick a valuation date, ReportOpts today_ is unset") today_
multiperiod = interval_ /= NoInterval
lastdays =
map ((maybe
(error' "multiBalanceReport: expected all spans to have an end date")
(addDays (-1)))
. spanEnd) colspans
sortedrows :: [MultiBalanceReportRow] =
dbg1 "sortedrows" $
sortrows rows
where
sortrows
| sort_amount_ && accountlistmode_ == ALTree = sortTreeMBRByAmount
| sort_amount_ = sortFlatMBRByAmount
| otherwise = sortMBRByAccountDeclaration
where
sortTreeMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]
sortTreeMBRByAmount rows = sortedrows
where
anamesandrows = [(prrName r, r) | r <- rows]
anames = map fst anamesandrows
atotals = [(prrName r, prrTotal r) | r <- rows]
accounttree = accountTree "root" anames
accounttreewithbals = mapAccounts setibalance accounttree
where
setibalance a = a{aibalance=fromMaybe (error "sortTreeMBRByAmount 1") $ lookup (aname a) atotals}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive normalbalance_) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
sortedrows = sortAccountItemsLike sortedanames anamesandrows
sortFlatMBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . prrTotal))
where
maybeflip = if normalbalance_ == Just NormallyNegative then id else flip
sortMBRByAccountDeclaration rows = sortedrows
where
anamesandrows = [(prrName r, r) | r <- rows]
anames = map fst anamesandrows
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
sortedrows = sortAccountItemsLike sortedanames anamesandrows
highestlevelaccts = [a | a <- displayaccts, not $ any (`elem` displayaccts) $ init $ expandAccountName a]
colamts = transpose . map prrAmounts $ filter isHighest rows
where isHighest row = not (tree_ ropts) || prrName row `elem` highestlevelaccts
coltotals :: [MixedAmount] =
dbg1 "coltotals" $ map sum colamts
[grandtotal,grandaverage] =
let amts = map ($ map sum colamts)
[if balancetype_==PeriodChange then sum else const 0
,averageMixedAmounts
]
in amts
totalsrow :: PeriodicReportRow () MixedAmount =
dbg1 "totalsrow" $ PeriodicReportRow () 0 coltotals grandtotal grandaverage
mappedsortedrows :: [MultiBalanceReportRow] =
if not percent_ then sortedrows
else dbg1 "mappedsortedrows"
[ PeriodicReportRow aname alevel
(zipWith perdivide rowvals coltotals)
(rowtotal `perdivide` grandtotal)
(rowavg `perdivide` grandaverage)
| PeriodicReportRow aname alevel rowvals rowtotal rowavg <- sortedrows
]
mappedtotalsrow :: PeriodicReportRow () MixedAmount
| percent_ = dbg1 "mappedtotalsrow" $ PeriodicReportRow () 0
(map (\t -> perdivide t t) coltotals)
(perdivide grandtotal grandtotal)
(perdivide grandaverage grandaverage)
| otherwise = totalsrow
balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport
balanceReportFromMultiBalanceReport opts q j = (rows', total)
where
PeriodicReport _ rows (PeriodicReportRow _ _ totals _ _) = multiBalanceReport opts q j
rows' = [( a
, if flat_ opts then a else accountLeafName a
, if tree_ opts then d-1 else 0
, headDef nullmixedamt amts
) | PeriodicReportRow a d amts _ _ <- rows]
total = headDef nullmixedamt totals
tableAsText :: ReportOpts -> (a -> String) -> Table String String a -> String
tableAsText (ReportOpts{pretty_tables_ = pretty}) showcell =
unlines
. trimborder
. lines
. render pretty id id showcell
. align
where
trimborder = drop 1 . init . map (drop 1 . init)
align (Table l t d) = Table l' t d
where
acctswidth = maximum' $ map strWidth (headerContents l)
l' = padRightWide acctswidth <$> l
tests_MultiBalanceReport = tests "MultiBalanceReport" [
let
amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False}
(opts,journal) `gives` r = do
let (eitems, etotal) = r
(PeriodicReport _ aitems atotal) = multiBalanceReport opts (queryFromOpts nulldate opts) journal
showw (PeriodicReportRow acct indent lAmt amt amt')
= (acct, accountLeafName acct, indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')
(map showw aitems) @?= (map showw eitems)
showMixedAmountDebug (prrTotal atotal) @?= showMixedAmountDebug etotal
in
tests "multiBalanceReport" [
test "null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "with -H on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
(
[ PeriodicReportRow "assets:bank:checking" 3 [mamountp' "$1.00"] (Mixed [nullamt]) (Mixed [amt0 {aquantity=1}])
, PeriodicReportRow "income:salary" 2 [mamountp' "$-1.00"] (Mixed [nullamt]) (Mixed [amt0 {aquantity=(-1)}])
],
Mixed [nullamt])
]
]