537 lines
		
	
	
		
			25 KiB
		
	
	
	
		
			Haskell
		
	
	
	
	
	
			
		
		
	
	
			537 lines
		
	
	
		
			25 KiB
		
	
	
	
		
			Haskell
		
	
	
	
	
	
| {-# LANGUAGE FlexibleInstances   #-}
 | |
| {-# LANGUAGE LambdaCase          #-}
 | |
| {-# LANGUAGE OverloadedStrings   #-}
 | |
| {-# LANGUAGE RecordWildCards     #-}
 | |
| {-# LANGUAGE ScopedTypeVariables #-}
 | |
| {-|
 | |
| 
 | |
| Multi-column balance reports, used by the balance command.
 | |
| 
 | |
| -}
 | |
| 
 | |
| module Hledger.Reports.MultiBalanceReport (
 | |
|   MultiBalanceReport,
 | |
|   MultiBalanceReportRow,
 | |
| 
 | |
|   multiBalanceReport,
 | |
|   multiBalanceReportWith,
 | |
|   balanceReportFromMultiBalanceReport,
 | |
|   tableAsText,
 | |
| 
 | |
|   -- -- * Tests
 | |
|   tests_MultiBalanceReport
 | |
| )
 | |
| where
 | |
| 
 | |
| import Data.List
 | |
| import Data.List.Extra (nubSort)
 | |
| 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
 | |
| 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
 | |
| 
 | |
| 
 | |
| -- | A multi balance report is a kind of periodic report, where the amounts
 | |
| -- correspond to balance changes or ending balances in a given period. It has:
 | |
| --
 | |
| -- 1. a list of each column's period (date span)
 | |
| --
 | |
| -- 2. a list of rows, each containing:
 | |
| --
 | |
| --   * the full account name
 | |
| --
 | |
| --   * the account's depth
 | |
| --
 | |
| --   * A list of amounts, one for each column.
 | |
| --
 | |
| --   * the total of the row's amounts for a periodic report
 | |
| --
 | |
| --   * the average of the row's amounts
 | |
| --
 | |
| -- 3. the column totals, and the overall grand total (or zero for
 | |
| -- cumulative/historical reports) and grand average.
 | |
| 
 | |
| type MultiBalanceReport    = PeriodicReport AccountName MixedAmount
 | |
| type MultiBalanceReportRow = PeriodicReportRow AccountName MixedAmount
 | |
| 
 | |
| -- type alias just to remind us which AccountNames might be depth-clipped, below.
 | |
| type ClippedAccountName = AccountName
 | |
| 
 | |
| -- | Generate a multicolumn balance report for the matched accounts,
 | |
| -- showing the change of balance, accumulated balance, or historical balance
 | |
| -- in each of the specified periods. Does not support tree-mode boring parent eliding.
 | |
| -- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
 | |
| -- (see ReportOpts and CompoundBalanceCommand).
 | |
| -- hledger's most powerful and useful report, used by the balance
 | |
| -- command (in multiperiod mode) and (via multiBalanceReport') by the bs/cf/is commands.
 | |
| 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
 | |
| 
 | |
| -- | A helper for multiBalanceReport. This one takes an explicit Query
 | |
| -- instead of deriving one from ReportOpts, and an extra argument, a
 | |
| -- PriceOracle to be used for looking up market prices. Commands which
 | |
| -- run multiple reports (bs etc.) can generate the price oracle just
 | |
| -- once for efficiency, passing it to each report by calling this
 | |
| -- function directly.
 | |
| multiBalanceReportWith :: ReportOpts -> Query -> Journal -> PriceOracle -> MultiBalanceReport
 | |
| multiBalanceReportWith ropts@ReportOpts{..} q j priceoracle = report
 | |
|   where
 | |
|     -- Queries, report/column dates.
 | |
|     reportspan = dbg "reportspan" $ calculateReportSpan ropts q j
 | |
|     reportq    = dbg "reportq"    $ makeReportQuery ropts reportspan q
 | |
| 
 | |
|     -- The matched accounts with a starting balance. All of these should appear
 | |
|     -- in the report, even if they have no postings during the report period.
 | |
|     startbals = dbg' "startbals" $ startingBalances ropts reportq j reportspan
 | |
| 
 | |
|     -- Postings matching the query within the report period.
 | |
|     ps :: [(Posting, Day)] = dbg'' "ps" $ getPostings ropts reportq j
 | |
|     days = map snd ps
 | |
| 
 | |
|     -- The date spans to be included as report columns.
 | |
|     colspans = dbg "colspans" $ calculateColSpans ropts reportspan days
 | |
| 
 | |
|     -- Group postings into their columns.
 | |
|     colps = dbg'' "colps" $ calculateColumns colspans ps
 | |
| 
 | |
|     -- Each account's balance changes across all columns.
 | |
|     acctchanges = dbg'' "acctchanges" $ calculateAccountChanges ropts q startbals colps
 | |
| 
 | |
|     -- Process changes into normal, cumulative, or historical amounts, plus value them
 | |
|     accumvalued = dbg'' "accumvalued" $ accumValueAmounts ropts j priceoracle startbals acctchanges
 | |
| 
 | |
|     -- All account names that will be displayed, possibly depth-clipped.
 | |
|     displayaccts = dbg'' "displayaccts" $ displayedAccounts ropts q startbals ps
 | |
| 
 | |
|     -- All the rows of the report.
 | |
|     rows = dbg'' "rows" $ buildReportRows ropts reportq accumvalued
 | |
| 
 | |
|     -- Sorted report rows.
 | |
|     sortedrows = dbg' "sortedrows" $ sortRows ropts j rows
 | |
| 
 | |
|     -- Calculate column totals
 | |
|     totalsrow = dbg' "totalsrow" $ calculateTotalsRow ropts displayaccts sortedrows
 | |
| 
 | |
|     -- Postprocess the report, negating balances and taking percentages if needed
 | |
|     report = dbg' "report" . postprocessReport ropts $
 | |
|         PeriodicReport colspans sortedrows totalsrow
 | |
| 
 | |
| 
 | |
| -- | Calculate the span of the report to be generated.
 | |
| calculateReportSpan :: ReportOpts -> Query -> Journal -> DateSpan
 | |
| calculateReportSpan ropts q j = reportspan
 | |
|   where
 | |
|     -- The date span specified by -b/-e/-p options and query args if any.
 | |
|     requestedspan  = dbg "requestedspan" $ queryDateSpan (date2_ ropts) q
 | |
|     -- If the requested span is open-ended, close it using the journal's end dates.
 | |
|     -- This can still be the null (open) span if the journal is empty.
 | |
|     requestedspan' = dbg "requestedspan'" $
 | |
|         requestedspan `spanDefaultsFrom` journalDateSpan (date2_ ropts) j
 | |
|     -- The list of interval spans enclosing the requested span.
 | |
|     -- This list can be empty if the journal was empty,
 | |
|     -- or if hledger-ui has added its special date:-tomorrow to the query
 | |
|     -- and all txns are in the future.
 | |
|     intervalspans  = dbg "intervalspans" $ splitSpan (interval_ ropts) requestedspan'
 | |
|     -- The requested span enlarged to enclose a whole number of intervals.
 | |
|     -- This can be the null span if there were no intervals.
 | |
|     reportspan = DateSpan (spanStart =<< headMay intervalspans)
 | |
|                           (spanEnd =<< lastMay intervalspans)
 | |
| 
 | |
| -- | Remove any date queries and insert queries from the report span.
 | |
| -- The user's query expanded to the report span
 | |
| -- if there is one (otherwise any date queries are left as-is, which
 | |
| -- handles the hledger-ui+future txns case above).
 | |
| 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
 | |
| 
 | |
| -- | Calculate starting balances, if needed for -H
 | |
| --
 | |
| -- Balances at report start date, from all earlier postings which otherwise match the query.
 | |
| -- These balances are unvalued except maybe converted to cost.
 | |
| startingBalances :: ReportOpts -> Query -> Journal -> DateSpan -> HashMap AccountName MixedAmount
 | |
| startingBalances ropts q j reportspan = acctchanges
 | |
|   where
 | |
|     acctchanges = acctChangesFromPostings ropts'' startbalq . map fst $
 | |
|         getPostings ropts'' startbalq j
 | |
| 
 | |
|     -- q projected back before the report start date.
 | |
|     -- When there's no report start date, in case there are future txns (the hledger-ui case above),
 | |
|     -- we use emptydatespan to make sure they aren't counted as starting balance.
 | |
|     startbalq = dbg'' "startbalq" $ And [datelessq, precedingspanq]
 | |
|     datelessq = dbg "datelessq" $ filterQuery (not . queryIsDateOrDate2) q
 | |
| 
 | |
|     ropts' | tree_ ropts = ropts{no_elide_=True}
 | |
|            | otherwise   = ropts{accountlistmode_=ALFlat}
 | |
|     ropts'' = 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
 | |
| 
 | |
| -- | Gather postings matching the query within the report period.
 | |
| getPostings :: ReportOpts -> Query -> Journal -> [(Posting, Day)]
 | |
| getPostings ropts q =
 | |
|     map (\p -> (p, date p)) .
 | |
|     journalPostings .
 | |
|     filterJournalAmounts symq .    -- remove amount parts excluded by cur:
 | |
|     filterJournalPostings reportq  -- remove postings not matched by (adjusted) query
 | |
|   where
 | |
|     symq = dbg "symq" . filterQuery queryIsSym $ dbg "requested q" q
 | |
|     -- The user's query with no depth limit, and expanded to the report span
 | |
|     -- if there is one (otherwise any date queries are left as-is, which
 | |
|     -- handles the hledger-ui+future txns case above).
 | |
|     reportq = dbg "reportq" $ depthless q
 | |
|     depthless = dbg "depthless" . filterQuery (not . queryIsDepth)
 | |
| 
 | |
|     date = case whichDateFromOpts ropts of
 | |
|         PrimaryDate   -> postingDate
 | |
|         SecondaryDate -> postingDate2
 | |
| 
 | |
| -- | Calculate the DateSpans to be used for the columns of the report.
 | |
| calculateColSpans :: ReportOpts -> DateSpan -> [Day] -> [DateSpan]
 | |
| calculateColSpans ropts reportspan days =
 | |
|     splitSpan (interval_ ropts) displayspan
 | |
|   where
 | |
|     displayspan
 | |
|       | empty_ ropts = dbg "displayspan (-E)" reportspan                        -- all the requested intervals
 | |
|       | otherwise = dbg "displayspan" $ reportspan `spanIntersect` matchedspan  -- exclude leading/trailing empty intervals
 | |
|     matchedspan = dbg "matchedspan" $ daysSpan days
 | |
| 
 | |
| -- | Group postings into their columns.
 | |
| calculateColumns :: [DateSpan] -> [(Posting, Day)] -> Map DateSpan [Posting]
 | |
| calculateColumns colspans = foldr addPosting emptyMap
 | |
|   where
 | |
|     addPosting (p, d) = maybe id (M.adjust (p:)) $ latestSpanContaining colspans d
 | |
|     emptyMap = M.fromList . zip colspans $ repeat []
 | |
| 
 | |
| -- | Calculate account balance changes in each column.
 | |
| --
 | |
| -- In each column, gather the accounts that have postings and their change amount.
 | |
| acctChangesFromPostings :: ReportOpts -> Query -> [Posting] -> HashMap ClippedAccountName MixedAmount
 | |
| acctChangesFromPostings ropts q ps =
 | |
|     HM.fromList [(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) -- exclude deeper balances
 | |
|       | otherwise   = clipAccountsAndAggregate $ queryDepth depthq -- aggregate deeper balances at the depth limit
 | |
|     depthq = dbg "depthq" $ filterQuery queryIsDepth q
 | |
| 
 | |
| -- | Gather the account balance changes into a regular matrix including the accounts
 | |
| -- from all columns
 | |
| calculateAccountChanges :: ReportOpts -> Query
 | |
|                         -> HashMap ClippedAccountName MixedAmount
 | |
|                         -> Map DateSpan [Posting]
 | |
|                         -> HashMap ClippedAccountName (Map DateSpan MixedAmount)
 | |
| calculateAccountChanges ropts q startbals colps = acctchanges
 | |
|   where
 | |
|     -- Transpose to get each account's balance changes across all columns.
 | |
|     acctchanges = transposeMap colacctchanges <> (zeros <$ startbals)
 | |
| 
 | |
|     colacctchanges :: Map DateSpan (HashMap ClippedAccountName MixedAmount) =
 | |
|       dbg'' "colacctchanges" $ fmap (acctChangesFromPostings ropts q) colps
 | |
| 
 | |
|     zeros = nullmixedamt <$ colacctchanges
 | |
| 
 | |
| -- | Accumulate and value amounts, as specified by the report options.
 | |
| accumValueAmounts :: ReportOpts -> Journal -> PriceOracle
 | |
|                   -> HashMap ClippedAccountName MixedAmount
 | |
|                   -> HashMap ClippedAccountName (Map DateSpan MixedAmount)
 | |
|                   -> HashMap ClippedAccountName [MixedAmount]
 | |
| accumValueAmounts ropts j priceoracle startbals = HM.mapWithKey processRow
 | |
|   where
 | |
|     processRow name col = zipWith valueAcct spans $ rowbals name amts
 | |
|       where (spans, amts) = unzip $ M.toList col
 | |
| 
 | |
|     -- The row amounts to be displayed: per-period changes,
 | |
|     -- zero-based cumulative totals, or
 | |
|     -- starting-balance-based historical balances.
 | |
|     rowbals name changes = dbg'' "rowbals" $ case balancetype_ ropts of
 | |
|         PeriodChange      -> changes
 | |
|         CumulativeChange  -> drop 1 $ scanl (+) 0                         changes
 | |
|         HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor name) changes
 | |
| 
 | |
|     -- We may be converting amounts to value, per hledger_options.m4.md "Effect of --value on reports".
 | |
|     valueAcct (DateSpan _ (Just end)) = avalue periodlast
 | |
|       where periodlast = addDays (-1) end
 | |
|     valueAcct _ = error' "multiBalanceReport: expected all spans to have an end date"  -- XXX should not happen
 | |
| 
 | |
|     avalue periodlast = maybe id
 | |
|         (mixedAmountApplyValuation priceoracle styles periodlast mreportlast today multiperiod) $
 | |
|         value_ ropts
 | |
|       where
 | |
|         -- Some things needed if doing valuation.
 | |
|         styles = journalCommodityStyles j
 | |
|         mreportlast = reportPeriodLastDay ropts
 | |
|         today = fromMaybe (error' "multiBalanceReport: could not pick a valuation date, ReportOpts today_ is unset") $ today_ ropts  -- XXX shouldn't happen
 | |
|         multiperiod = interval_ ropts /= NoInterval
 | |
| 
 | |
|     startingBalanceFor a = HM.lookupDefault nullmixedamt a startbals
 | |
| 
 | |
| -- | Build the report rows.
 | |
| --
 | |
| -- One row per account, with account name info, row amounts, row total and row average.
 | |
| buildReportRows :: ReportOpts -> Query -> HashMap AccountName [MixedAmount] -> [MultiBalanceReportRow]
 | |
| buildReportRows ropts q acctvalues =
 | |
|     [ PeriodicReportRow a (accountNameLevel a) rowbals rowtot rowavg
 | |
|     | (a,rowbals) <- HM.toList acctvalues
 | |
|     -- The total and average for the row.
 | |
|     -- These are always simply the sum/average of the displayed row amounts.
 | |
|     -- Total for a cumulative/historical report is always zero.
 | |
|     , let rowtot = if balancetype_ ropts == PeriodChange then sum rowbals else 0
 | |
|     , let rowavg = averageMixedAmounts rowbals
 | |
|     , empty_ ropts || queryDepth q == 0 || any (not . mixedAmountLooksZero) rowbals  -- TODO: Remove this eventually, to be handled elswhere
 | |
|     ]
 | |
| 
 | |
| -- | Calculate accounts which are to be displayed in the report
 | |
| displayedAccounts :: ReportOpts -> Query
 | |
|                   -> HashMap AccountName MixedAmount
 | |
|                   -> [(Posting, Day)]
 | |
|                   -> [AccountName]
 | |
| displayedAccounts ropts q startbals ps =
 | |
|     (if tree_ ropts then expandAccountNames else id) $
 | |
|     nub $ map (clipOrEllipsifyAccountName depth) $
 | |
|     if empty_ ropts || balancetype_ ropts == HistoricalBalance
 | |
|     then nubSort $ (HM.keys startbals) ++ allpostedaccts
 | |
|     else allpostedaccts
 | |
|   where
 | |
|     allpostedaccts :: [AccountName] =
 | |
|       dbg'' "allpostedaccts" . sort . accountNamesFromPostings $ map fst ps
 | |
|     depth = queryDepth q
 | |
| 
 | |
| -- | Sort the rows by amount or by account declaration order. This is a bit tricky.
 | |
| -- TODO: is it always ok to sort report rows after report has been generated, as a separate step ?
 | |
| sortRows :: ReportOpts -> Journal -> [MultiBalanceReportRow] -> [MultiBalanceReportRow]
 | |
| sortRows ropts j
 | |
|     | sort_amount_ ropts && accountlistmode_ ropts == ALTree = sortTreeMBRByAmount
 | |
|     | sort_amount_ ropts                                     = sortFlatMBRByAmount
 | |
|     | otherwise                                              = sortMBRByAccountDeclaration
 | |
|   where
 | |
|     -- Sort the report rows, representing a tree of accounts, by row total at each level.
 | |
|     -- Similar to sortMBRByAccountDeclaration/sortAccountNamesByDeclaration.
 | |
|     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
 | |
|             -- should not happen, but it's dangerous; TODO
 | |
|             setibalance a = a{aibalance=fromMaybe (error "sortTreeMBRByAmount 1") $ lookup (aname a) atotals}
 | |
|         sortedaccounttree = sortAccountTreeByAmount (fromMaybe NormallyPositive $ normalbalance_ ropts) accounttreewithbals
 | |
|         sortedanames = map aname $ drop 1 $ flattenAccounts sortedaccounttree
 | |
|         sortedrows = sortAccountItemsLike sortedanames anamesandrows
 | |
| 
 | |
|     -- Sort the report rows, representing a flat account list, by row total.
 | |
|     sortFlatMBRByAmount = sortBy (maybeflip $ comparing (normaliseMixedAmountSquashPricesForDisplay . prrTotal))
 | |
|       where
 | |
|         maybeflip = if normalbalance_ ropts == Just NormallyNegative then id else flip
 | |
| 
 | |
|     -- Sort the report rows by account declaration order then account name.
 | |
|     sortMBRByAccountDeclaration rows = sortedrows
 | |
|       where
 | |
|         anamesandrows = [(prrName r, r) | r <- rows]
 | |
|         anames = map fst anamesandrows
 | |
|         sortedanames = sortAccountNamesByDeclaration j (tree_ ropts) anames
 | |
|         sortedrows = sortAccountItemsLike sortedanames anamesandrows
 | |
| 
 | |
| -- | Build the report totals row.
 | |
| --
 | |
| -- Calculate the column totals. These are always the sum of column amounts.
 | |
| calculateTotalsRow :: ReportOpts -> [ClippedAccountName]
 | |
|                    -> [MultiBalanceReportRow] -> PeriodicReportRow () MixedAmount
 | |
| calculateTotalsRow ropts displayaccts rows =
 | |
|     PeriodicReportRow () 0 coltotals grandtotal grandaverage
 | |
|   where
 | |
|     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] = dbg'' "coltotals" $ map sum colamts
 | |
| 
 | |
|     -- Calculate the grand total and average. These are always the sum/average
 | |
|     -- of the column totals.
 | |
|     grandtotal  = if balancetype_ ropts == PeriodChange then sum coltotals else 0
 | |
|     grandaverage = averageMixedAmounts coltotals
 | |
| 
 | |
| -- | Map the report rows to percentages and negate if needed
 | |
| postprocessReport :: ReportOpts -> MultiBalanceReport -> MultiBalanceReport
 | |
| postprocessReport ropts (PeriodicReport spans rows totalrow) =
 | |
|     maybeInvert $ PeriodicReport spans (map percentage rows) (percentage totalrow)
 | |
|   where
 | |
|     maybeInvert = if invert_ ropts then prNegate else id
 | |
|     percentage  = if not (percent_ ropts) then id else \case
 | |
|         PeriodicReportRow name d rowvals rowtotal rowavg ->
 | |
|           PeriodicReportRow name d
 | |
|             (zipWith perdivide rowvals $ prrAmounts totalrow)
 | |
|             (perdivide rowtotal $ prrTotal totalrow)
 | |
|             (perdivide rowavg $ prrAverage totalrow)
 | |
| 
 | |
| 
 | |
| -- | Generates a simple non-columnar BalanceReport, but using multiBalanceReport,
 | |
| -- in order to support --historical. Does not support tree-mode boring parent eliding.
 | |
| -- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
 | |
| -- (see ReportOpts and CompoundBalanceCommand).
 | |
| balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal
 | |
|     -> ([(AccountName, AccountName, Int, MixedAmount)], MixedAmount)
 | |
| balanceReportFromMultiBalanceReport opts q j = (rows', total)
 | |
|   where
 | |
|     PeriodicReport _ rows (PeriodicReportRow _ _ totals _ _) =
 | |
|       multiBalanceReportWith opts q j (journalPriceOracle (infer_value_ opts) j)
 | |
|     rows' = [( a
 | |
|              , if flat_ opts then a else accountLeafName a   -- BalanceReport expects full account name here with --flat
 | |
|              , if tree_ opts then d-1 else 0  -- BalanceReport uses 0-based account depths
 | |
|              , headDef nullmixedamt amts     -- 0 columns is illegal, should not happen, return zeroes if it does
 | |
|              ) | PeriodicReportRow a d amts _ _ <- rows]
 | |
|     total = headDef nullmixedamt totals
 | |
| 
 | |
| 
 | |
| -- | Transpose a Map of HashMaps to a HashMap of Maps.
 | |
| transposeMap :: Map DateSpan (HashMap AccountName MixedAmount)
 | |
|              -> HashMap AccountName (Map DateSpan MixedAmount)
 | |
| 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 emptySpanMap
 | |
| 
 | |
|     emptySpanMap = nullmixedamt <$ xs
 | |
| 
 | |
| -- | A sorting helper: sort a list of things (eg report rows) keyed by account name
 | |
| -- to match the provided ordering of those same account names.
 | |
| sortAccountItemsLike :: [AccountName] -> [(AccountName, b)] -> [b]
 | |
| sortAccountItemsLike sortedas items =
 | |
|   concatMap (\a -> maybe [] (:[]) $ lookup a items) sortedas
 | |
| 
 | |
| -- | Helper to unify a MixedAmount to a single commodity value.
 | |
| -- Like normaliseMixedAmount, this consolidates amounts of the same commodity
 | |
| -- and discards zero amounts; but this one insists on simplifying to
 | |
| -- a single commodity, and will throw a program-terminating error if
 | |
| -- this is not possible.
 | |
| unifyMixedAmount :: MixedAmount -> Amount
 | |
| unifyMixedAmount mixedAmount = foldl combine (num 0) (amounts mixedAmount)
 | |
|   where
 | |
|     combine amount result =
 | |
|       if amountIsZero amount
 | |
|       then result
 | |
|       else if amountIsZero result
 | |
|         then amount
 | |
|         else if acommodity amount == acommodity result
 | |
|           then amount + result
 | |
|           else error' "Cannot calculate percentages for accounts with multiple commodities. (Hint: Try --cost, -V or similar flags.)"
 | |
| 
 | |
| -- | Helper to calculate the percentage from two mixed. Keeps the sign of the first argument.
 | |
| -- Uses unifyMixedAmount to unify each argument and then divides them.
 | |
| perdivide :: MixedAmount -> MixedAmount -> MixedAmount
 | |
| perdivide a b =
 | |
|   let a' = unifyMixedAmount a
 | |
|       b' = unifyMixedAmount b
 | |
|   in if amountIsZero a' || amountIsZero b' || acommodity a' == acommodity b'
 | |
|     then mixed [per $ if aquantity b' == 0 then 0 else (aquantity a' / abs (aquantity b') * 100)]
 | |
|     else error' "Cannot calculate percentages if accounts have different commodities. (Hint: Try --cost, -V or similar flags.)"
 | |
| 
 | |
| -- Local debug helper
 | |
| -- add a prefix to this function's debug output
 | |
| 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)
 | |
| -- dbg = const id  -- exclude this function from debug output
 | |
| 
 | |
| -- common rendering helper, XXX here for now
 | |
| 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
 | |
| 
 | |
| 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 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 -- we only check the sum of the totals
 | |
|   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])
 | |
| 
 | |
|      -- ,test "a valid history on an empty period"  $
 | |
|      --  (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 [amt0 {aquantity=1}])
 | |
|      --    ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}])
 | |
|      --    ],
 | |
|      --    Mixed [usd0])
 | |
| 
 | |
|      -- ,test "a valid history on an empty period (more complex)"  $
 | |
|      --  (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 [amt0 {aquantity=1}])
 | |
|      --    ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}])
 | |
|      --    ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amt0 {aquantity=(-2)}])
 | |
|      --    ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=(1)}])
 | |
|      --    ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=(1)}])
 | |
|      --    ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}])
 | |
|      --    ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}])
 | |
|      --    ],
 | |
|      --    Mixed [usd0])
 | |
|     ]
 | |
|  ]
 |