{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hledger.Reports.MultiBalanceReport (
MultiBalanceReport,
MultiBalanceReportRow,
multiBalanceReport,
multiBalanceReportWith,
CompoundBalanceReport,
compoundBalanceReport,
compoundBalanceReportWith,
tableAsText,
sortRows,
sortRowsLike,
tests_MultiBalanceReport
)
where
import Control.Monad (guard)
import Data.Foldable (toList)
import Data.List (sortOn, transpose)
import Data.List.NonEmpty (NonEmpty(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (Down(..))
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import Data.Semigroup (sconcat)
import Data.Time.Calendar (Day, addDays, fromGregorian)
import Safe (headMay, lastDef, lastMay)
import Text.Tabular as T
import Text.Tabular.AsciiWide (render)
import Hledger.Data
import Hledger.Query
import Hledger.Utils
import Hledger.Read (mamountp')
import Hledger.Reports.ReportOptions
import Hledger.Reports.ReportTypes
type MultiBalanceReport = PeriodicReport DisplayName MixedAmount
type MultiBalanceReportRow = PeriodicReportRow DisplayName MixedAmount
type CompoundBalanceReport = CompoundPeriodicReport DisplayName MixedAmount
type ClippedAccountName = AccountName
multiBalanceReport :: Day -> ReportOpts -> Journal -> MultiBalanceReport
multiBalanceReport today ropts j =
multiBalanceReportWith ropts q j (journalPriceOracle infer j)
where
q = queryFromOpts today ropts
infer = infer_value_ ropts
multiBalanceReportWith :: ReportOpts -> Query -> Journal -> PriceOracle -> MultiBalanceReport
multiBalanceReportWith ropts q j priceoracle = report
where
reportspan = dbg "reportspan" $ calculateReportSpan ropts q j
reportq = dbg "reportq" $ makeReportQuery ropts reportspan q
colps = dbg'' "colps" $ getPostingsByColumn ropts reportq j reportspan
colspans = dbg "colspans" $ M.keys colps
startbals = dbg' "startbals" $ startingBalances ropts reportq j reportspan
report = dbg' "report" $
generateMultiBalanceReport ropts reportq j priceoracle colspans colps startbals
compoundBalanceReport :: Day -> ReportOpts -> Journal -> [CBCSubreportSpec]
-> CompoundBalanceReport
compoundBalanceReport today ropts j =
compoundBalanceReportWith ropts q j (journalPriceOracle infer j)
where
q = queryFromOpts today ropts
infer = infer_value_ ropts
compoundBalanceReportWith :: ReportOpts -> Query -> Journal -> PriceOracle
-> [CBCSubreportSpec] -> CompoundBalanceReport
compoundBalanceReportWith ropts q j priceoracle subreportspecs = cbr
where
reportspan = dbg "reportspan" $ calculateReportSpan ropts q j
reportq = dbg "reportq" $ makeReportQuery ropts reportspan q
colps = dbg'' "colps" $ getPostingsByColumn ropts{empty_=True} reportq j reportspan
colspans = dbg "colspans" $ M.keys colps
startbals = dbg' "startbals" $ startingBalances ropts reportq j reportspan
subreports = map generateSubreport subreportspecs
where
generateSubreport CBCSubreportSpec{..} =
( cbcsubreporttitle
, prNormaliseSign cbcsubreportnormalsign $
generateMultiBalanceReport ropts' reportq j priceoracle colspans colps' startbals'
, cbcsubreportincreasestotal
)
where
ropts' = ropts{normalbalance_=Just cbcsubreportnormalsign}
colps' = filter (matchesPosting $ cbcsubreportquery j) <$> colps
startbals' = HM.filterWithKey (\k _ -> matchesAccount (cbcsubreportquery j) k) startbals
overalltotals = case subreports of
[] -> PeriodicReportRow () [] nullmixedamt nullmixedamt
(r:rs) -> sconcat $ fmap subreportTotal (r:|rs)
where
subreportTotal (_, sr, increasestotal) =
(if increasestotal then id else fmap negate) $ prTotals sr
cbr = CompoundPeriodicReport "" colspans subreports overalltotals
startingBalances :: ReportOpts -> Query -> Journal -> DateSpan -> HashMap AccountName Account
startingBalances ropts q j reportspan = acctchanges
where
acctchanges = acctChangesFromPostings ropts' startbalq . map fst $
getPostings ropts' startbalq j
startbalq = dbg'' "startbalq" $ And [datelessq, precedingspanq]
datelessq = dbg "datelessq" $ filterQuery (not . queryIsDateOrDate2) q
ropts' = case accountlistmode_ ropts of
ALTree -> ropts{no_elide_=True, period_=precedingperiod}
ALFlat -> ropts{period_=precedingperiod}
precedingperiod = dateSpanAsPeriod . spanIntersect precedingspan .
periodAsDateSpan $ period_ ropts
precedingspan = DateSpan Nothing $ spanStart reportspan
precedingspanq = (if date2_ ropts then Date2 else Date) $ case precedingspan of
DateSpan Nothing Nothing -> emptydatespan
a -> a
calculateReportSpan :: ReportOpts -> Query -> Journal -> DateSpan
calculateReportSpan ropts q j = reportspan
where
requestedspan = dbg "requestedspan" $ queryDateSpan (date2_ ropts) q
requestedspan' = dbg "requestedspan'" $
requestedspan `spanDefaultsFrom` journalDateSpan (date2_ ropts) j
intervalspans = dbg "intervalspans" $ splitSpan (interval_ ropts) requestedspan'
reportspan = DateSpan (spanStart =<< headMay intervalspans)
(spanEnd =<< lastMay intervalspans)
makeReportQuery :: ReportOpts -> DateSpan -> Query -> Query
makeReportQuery ropts reportspan q
| reportspan == nulldatespan = q
| otherwise = And [dateless q, reportspandatesq]
where
reportspandatesq = dbg "reportspandatesq" $ dateqcons reportspan
dateless = dbg "dateless" . filterQuery (not . queryIsDateOrDate2)
dateqcons = if date2_ ropts then Date2 else Date
getPostingsByColumn :: ReportOpts -> Query -> Journal -> DateSpan -> Map DateSpan [Posting]
getPostingsByColumn ropts q j reportspan = columns
where
ps :: [(Posting, Day)] = dbg'' "ps" $ getPostings ropts q j
days = map snd ps
colspans = calculateColSpans ropts reportspan days
addPosting (p, d) = maybe id (M.adjust (p:)) $ latestSpanContaining colspans d
emptyMap = M.fromList . zip colspans $ repeat []
columns = foldr addPosting emptyMap ps
getPostings :: ReportOpts -> Query -> Journal -> [(Posting, Day)]
getPostings ropts q =
map (\p -> (p, date p)) .
journalPostings .
filterJournalAmounts symq .
filterJournalPostings reportq
where
symq = dbg "symq" . filterQuery queryIsSym $ dbg "requested q" q
reportq = dbg "reportq" $ depthless q
depthless = dbg "depthless" . filterQuery (not . queryIsDepth)
date = case whichDateFromOpts ropts of
PrimaryDate -> postingDate
SecondaryDate -> postingDate2
calculateColSpans :: ReportOpts -> DateSpan -> [Day] -> [DateSpan]
calculateColSpans ropts reportspan days =
splitSpan (interval_ ropts) displayspan
where
displayspan
| empty_ ropts = dbg "displayspan (-E)" reportspan
| otherwise = dbg "displayspan" $ reportspan `spanIntersect` matchedspan
matchedspan = dbg "matchedspan" $ daysSpan days
calculateAccountChanges :: ReportOpts -> Query -> [DateSpan]
-> Map DateSpan [Posting]
-> HashMap ClippedAccountName (Map DateSpan Account)
calculateAccountChanges ropts q colspans colps
| queryDepth q == Just 0 = acctchanges <> elided
| otherwise = acctchanges
where
acctchanges = transposeMap colacctchanges
colacctchanges :: Map DateSpan (HashMap ClippedAccountName Account) =
dbg'' "colacctchanges" $ fmap (acctChangesFromPostings ropts q) colps
elided = HM.singleton "..." $ M.fromList [(span, nullacct) | span <- colspans]
acctChangesFromPostings :: ReportOpts -> Query -> [Posting] -> HashMap ClippedAccountName Account
acctChangesFromPostings ropts q ps = HM.fromList [(aname a, a) | a <- as]
where
as = filterAccounts . drop 1 $ accountsFromPostings ps
filterAccounts = case accountlistmode_ ropts of
ALTree -> filter ((depthq `matchesAccount`) . aname)
ALFlat -> clipAccountsAndAggregate (queryDepth depthq) .
filter ((0<) . anumpostings)
depthq = dbg "depthq" $ filterQuery queryIsDepth q
accumValueAmounts :: ReportOpts -> Journal -> PriceOracle -> [DateSpan]
-> HashMap ClippedAccountName Account
-> HashMap ClippedAccountName (Map DateSpan Account)
-> HashMap ClippedAccountName (Map DateSpan Account)
accumValueAmounts ropts j priceoracle colspans startbals acctchanges =
HM.mapWithKey processRow $ acctchanges <> (mempty <$ startbals)
where
processRow name changes = M.mapWithKey valueAcct . rowbals name $ changes <> zeros
rowbals name changes = dbg'' "rowbals" $ case balancetype_ ropts of
PeriodChange -> changes
CumulativeChange -> snd $ M.mapAccum f nullacct changes
HistoricalBalance -> snd $ M.mapAccum f (startingBalanceFor name) changes
where f a b = let s = sumAcct a b in (s, s)
sumAcct Account{aibalance=i1,aebalance=e1} a@Account{aibalance=i2,aebalance=e2} =
a{aibalance = i1 + i2, aebalance = e1 + e2}
valueAcct (DateSpan _ (Just end)) acct =
acct{aibalance = value (aibalance acct), aebalance = value (aebalance acct)}
where value = avalue (addDays (-1) end)
valueAcct _ _ = error' "multiBalanceReport: expected all spans to have an end date"
avalue periodlast = maybe id
(mixedAmountApplyValuation priceoracle styles periodlast mreportlast today multiperiod) $
value_ ropts
where
styles = journalCommodityStyles j
mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "multiBalanceReport: could not pick a valuation date, ReportOpts today_ is unset") $ today_ ropts
multiperiod = interval_ ropts /= NoInterval
startingBalanceFor a = HM.lookupDefault nullacct a startbals
zeros = M.fromList [(span, nullacct) | span <- colspans]
generateMultiBalanceReport :: ReportOpts -> Query -> Journal -> PriceOracle
-> [DateSpan]
-> Map DateSpan [Posting]
-> HashMap AccountName Account
-> MultiBalanceReport
generateMultiBalanceReport ropts q j priceoracle colspans colps startbals = report
where
acctchanges = dbg'' "acctchanges" $ calculateAccountChanges ropts q colspans colps
accumvalued = accumValueAmounts ropts j priceoracle colspans startbals acctchanges
displaynames = dbg'' "displaynames" $ displayedAccounts ropts q accumvalued
rows = dbg'' "rows" $ buildReportRows ropts displaynames accumvalued
totalsrow = dbg' "totalsrow" $ calculateTotalsRow ropts rows
sortedrows = dbg' "sortedrows" $ sortRows ropts j rows
report = postprocessReport ropts $ PeriodicReport colspans sortedrows totalsrow
buildReportRows :: ReportOpts
-> HashMap AccountName DisplayName
-> HashMap AccountName (Map DateSpan Account)
-> [MultiBalanceReportRow]
buildReportRows ropts displaynames = toList . HM.mapMaybeWithKey mkRow
where
mkRow name accts = do
displayname <- HM.lookup name displaynames
return $ PeriodicReportRow displayname rowbals rowtot rowavg
where
rowbals = map balance $ toList accts
rowtot = case balancetype_ ropts of
PeriodChange -> sum rowbals
_ -> lastDef 0 rowbals
rowavg = averageMixedAmounts rowbals
balance = case accountlistmode_ ropts of ALTree -> aibalance; ALFlat -> aebalance
displayedAccounts :: ReportOpts -> Query
-> HashMap AccountName (Map DateSpan Account)
-> HashMap AccountName DisplayName
displayedAccounts ropts q valuedaccts
| depth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1
| otherwise = HM.mapWithKey (\a _ -> displayedName a) displayedAccts
where
displayedAccts = (if depth == 0 then id else HM.filterWithKey keep) valuedaccts
where
keep name amts = isInteresting name amts || name `HM.member` interestingParents
displayedName name = case accountlistmode_ ropts of
ALTree -> DisplayName name leaf . max 0 $ level - boringParents
ALFlat -> DisplayName name droppedName 1
where
droppedName = accountNameDrop (drop_ ropts) name
leaf = accountNameFromComponents . reverse . map accountLeafName $
droppedName : takeWhile notDisplayed parents
level = max 0 $ accountNameLevel name - drop_ ropts
parents = take (level - 1) $ parentAccountNames name
boringParents = if no_elide_ ropts then 0 else length $ filter notDisplayed parents
notDisplayed = not . (`HM.member` displayedAccts)
isInteresting name amts =
d <= depth
&& ((empty_ ropts && all (null . asubs) amts)
|| not (isZeroRow balance amts))
where
d = accountNameLevel name
balance | ALTree <- accountlistmode_ ropts, d == depth = aibalance
| otherwise = aebalance
interestingParents = dbg'' "interestingParents" $ case accountlistmode_ ropts of
ALTree -> HM.filterWithKey hasEnoughSubs numSubs
ALFlat -> mempty
where
hasEnoughSubs name nsubs = nsubs >= minSubs && accountNameLevel name > drop_ ropts
minSubs = if no_elide_ ropts then 1 else 2
isZeroRow balance = all (mixedAmountLooksZero . balance)
depth = fromMaybe maxBound $ queryDepth q
numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts
sortRows :: ReportOpts -> Journal -> [MultiBalanceReportRow] -> [MultiBalanceReportRow]
sortRows ropts j
| sort_amount_ ropts, ALTree <- accountlistmode_ ropts = sortTreeMBRByAmount
| sort_amount_ ropts, ALFlat <- accountlistmode_ ropts = sortFlatMBRByAmount
| otherwise = sortMBRByAccountDeclaration
where
sortTreeMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]
sortTreeMBRByAmount rows = mapMaybe (`HM.lookup` rowMap) sortedanames
where
accounttree = accountTree "root" $ map prrFullName rows
rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows
accounttreewithbals = mapAccounts setibalance accounttree
setibalance a = a{aibalance = maybe (sum . map aibalance $ asubs a) prrTotal $
HM.lookup (aname a) rowMap}
sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals
sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
sortFlatMBRByAmount :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]
sortFlatMBRByAmount = case normalbalance_ ropts of
Just NormallyNegative -> sortOn amt
_ -> sortOn (Down . amt)
where amt = normaliseMixedAmountSquashPricesForDisplay . prrTotal
sortMBRByAccountDeclaration :: [MultiBalanceReportRow] -> [MultiBalanceReportRow]
sortMBRByAccountDeclaration rows = sortRowsLike sortedanames rows
where
sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) $ map prrFullName rows
calculateTotalsRow :: ReportOpts -> [MultiBalanceReportRow] -> PeriodicReportRow () MixedAmount
calculateTotalsRow ropts rows =
PeriodicReportRow () coltotals grandtotal grandaverage
where
isTopRow row = flat_ ropts || not (any (`HM.member` rowMap) parents)
where parents = init . expandAccountName $ prrFullName row
rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows
colamts = transpose . map prrAmounts $ filter isTopRow rows
coltotals :: [MixedAmount] = dbg'' "coltotals" $ map sum colamts
grandtotal = case balancetype_ ropts of
PeriodChange -> sum coltotals
_ -> lastDef 0 coltotals
grandaverage = averageMixedAmounts coltotals
postprocessReport :: ReportOpts -> MultiBalanceReport -> MultiBalanceReport
postprocessReport ropts = maybePercent . maybeInvert
where
maybeInvert = if invert_ ropts then fmap negate else id
maybePercent = if percent_ ropts then prPercent else id
prPercent (PeriodicReport spans rows totalrow) =
PeriodicReport spans (map percentRow rows) (percentRow totalrow)
where
percentRow (PeriodicReportRow name rowvals rowtotal rowavg) =
PeriodicReportRow name
(zipWith perdivide rowvals $ prrAmounts totalrow)
(perdivide rowtotal $ prrTotal totalrow)
(perdivide rowavg $ prrAverage totalrow)
transposeMap :: Map DateSpan (HashMap AccountName a)
-> HashMap AccountName (Map DateSpan a)
transposeMap xs = M.foldrWithKey addSpan mempty xs
where
addSpan span acctmap seen = HM.foldrWithKey (addAcctSpan span) seen acctmap
addAcctSpan span acct a = HM.alter f acct
where f = Just . M.insert span a . fromMaybe mempty
sortRowsLike :: [AccountName] -> [PeriodicReportRow DisplayName b] -> [PeriodicReportRow DisplayName b]
sortRowsLike sortedas rows = mapMaybe (`HM.lookup` rowMap) sortedas
where rowMap = HM.fromList $ map (\row -> (prrFullName row, row)) rows
subaccountTallies :: [AccountName] -> HashMap AccountName Int
subaccountTallies = foldr incrementParent mempty . expandAccountNames
where
incrementParent a = HM.insertWith (+) (parentAccountName a) 1
perdivide :: MixedAmount -> MixedAmount -> MixedAmount
perdivide a b = fromMaybe (error' errmsg) $ do
a' <- unifyMixedAmount a
b' <- unifyMixedAmount b
guard $ amountIsZero a' || amountIsZero b' || acommodity a' == acommodity b'
return $ mixed [per $ if aquantity b' == 0 then 0 else aquantity a' / abs (aquantity b') * 100]
where errmsg = "Cannot calculate percentages if accounts have different commodities (Hint: Try --cost, -V or similar flags.)"
dbg s = let p = "multiBalanceReport" in Hledger.Utils.dbg3 (p++" "++s)
dbg' s = let p = "multiBalanceReport" in Hledger.Utils.dbg4 (p++" "++s)
dbg'' s = let p = "multiBalanceReport" in Hledger.Utils.dbg5 (p++" "++s)
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 = Precision 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False}
(opts,journal) `gives` r = do
let (eitems, etotal) = r
(PeriodicReport _ aitems atotal) = multiBalanceReport nulldate opts journal
showw (PeriodicReportRow a lAmt amt amt')
= (displayFull a, displayName a, displayDepth a, 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 (flatDisplayName "assets:bank:checking") [mamountp' "$1.00"] (mamountp' "$1.00") (Mixed [amt0 {aquantity=1}])
, PeriodicReportRow (flatDisplayName "income:salary") [mamountp' "$-1.00"] (mamountp' "$-1.00") (Mixed [amt0 {aquantity=(-1)}])
],
mamountp' "$0.00")
]
]