fix: budget: handle transpose flag with commodity-columns (#1654)

Budget formatting is quite complicated since we must determine widths
for each of the transposed columns

hledger-lib/Hledger/Reports/BudgetReport.hs

@@ -22,8 +22,8 @@ module Hledger.Reports.BudgetReport (
 where
 
 import Control.Applicative ((<|>))
+import Control.Arrow ((***))
 import Data.Decimal (roundTo)
-import Data.Default (def)
 import Data.Function (on)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HM
@@ -58,8 +58,10 @@ type BudgetCell = (Maybe Change, Maybe BudgetGoal)
 type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell
 type BudgetReport    = PeriodicReport    DisplayName BudgetCell
 
-
+type BudgetDisplayCell = (WideBuilder, Maybe (WideBuilder, Maybe WideBuilder))
-type BudgetDisplayCell = (BudgetCell, (Int, Int, Int))
+type BudgetDisplayRow  = [BudgetDisplayCell]
+type BudgetShowMixed   = MixedAmount -> [WideBuilder]
+type BudgetPercBudget  = Change -> BudgetGoal -> [Maybe Percentage]
 
 -- | Calculate per-account, per-period budget (balance change) goals
 -- from all periodic transactions, calculate actual balance changes
@@ -215,8 +217,7 @@ combineBudgetAndActual ropts j
 budgetReportAsText :: ReportOpts -> BudgetReport -> TL.Text
 budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
     TB.fromText title <> TB.fromText "\n\n" <>
-      renderTableByRowsB def{tableBorders=False,prettyTable=pretty_tables_}
+      balanceReportTableAsText ropts (budgetReportAsTable ropts budgetr)
-        renderCh renderRow displayTableWithWidths
   where
     title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr)
            <> (case cost_ of
@@ -230,114 +231,154 @@ budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
                  Nothing             -> "")
            <> ":"
 
-    renderCh
+-- | Add the second table below the first, discarding its column headings.
-      | not commodity_column_ = fmap (textCell TopRight)
+concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') =
-      | otherwise = zipWith ($) (Tab.textCell TopLeft : repeat (Tab.textCell TopRight))
+    Table (Tab.Group SingleLine [hLeft, hLeft']) hTop (dat ++ dat')
 
-    renderRow :: (Text, [((Int, Int, Int), BudgetDisplayCell)]) -> (Cell, [Cell])
+-- | Build a 'Table' from a multi-column balance report.
-    renderRow (rh, cells)
+budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text WideBuilder
-      | not commodity_column_ = (textCell TopLeft rh, fmap (uncurry showcell) cells)
+budgetReportAsTable
-      | otherwise =
+  ReportOpts{..}
-          ( textCell TopLeft rh
+  (PeriodicReport spans items tr) =
-          , textsCell TopLeft cs : fmap (uncurry (showcell' cs)) cells)
+    maybetransposetable $
+    addtotalrow $
+    Table
+      (Tab.Group NoLine $ map Header accts)
+      (Tab.Group NoLine $ map Header colheadings)
+      rows
+  where
+    colheadings = ["Commodity" | commodity_column_]
+                  ++ map (reportPeriodName balanceaccum_ spans) spans
+                  ++ ["  Total" | row_total_]
+                  ++ ["Average" | average_]
+
+    -- FIXME. Have to check explicitly for which to render here, since
+    -- budgetReport sets accountlistmode to ALTree. Find a principled way to do
+    -- this.
+    renderacct row = case accountlistmode_ of
+        ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row
+        ALFlat -> accountNameDrop (drop_) $ prrFullName row
+
+    addtotalrow
+      | no_total_ = id
+      | otherwise = let rh = Tab.Group NoLine $ map Header (replicate (length totalrows) "")
+                        ch = Header [] -- ignored
+                     in (`concatTables` Table rh ch totalrows)
+
+    maybetranspose
+      | transpose_ = transpose
+      | otherwise  = id
+
+    maybetransposetable
+      | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals)
+      | otherwise  = id
+
+    (accts, rows, totalrows) = (accts, prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts))
       where
-        cs = S.toList . foldl' S.union mempty
+        shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]]
-            . fmap (budgetCellCommodities . fst . snd) $ cells
+        shownitems = (fmap (\i -> fmap (\(cs, cvals) -> (renderacct i, cs, cvals)) . showrow $ rowToBudgetCells i) items)
+        (accts, itemscs, texts) = unzip3 $ concat shownitems
 
+        showntr    :: [[(WideBuilder, BudgetDisplayRow)]]
+        showntr    = [showrow $ rowToBudgetCells tr]
+        (trcs, trtexts)         = unzip  $ concat showntr
+        trwidths
+          | transpose_ = snd $ splitAt (length texts) widths
+          | otherwise = widths
+
+        padcells = maybetranspose . fmap (fmap (uncurry paddisplaycell) . zip widths)   . maybetranspose
+        padtr    = maybetranspose . fmap (fmap (uncurry paddisplaycell) . zip trwidths) . maybetranspose
+
+        -- commodities are shown with the amounts without `commodity-column`
+        prependcs cs
+          | commodity_column_ = zipWith (:) cs
+          | otherwise = id
+
+    rowToBudgetCells (PeriodicReportRow _ as rowtot rowavg) = as
+        ++ [rowtot | row_total_ && not (null as)]
+        ++ [rowavg | average_   && not (null as)]
+
+    -- functions for displaying budget cells depending on `commodity-column` flag
+    rowfuncs :: [CommoditySymbol] -> (BudgetShowMixed, BudgetPercBudget)
+    rowfuncs cs
+      | not commodity_column_ =
+          ( pure . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32}
+          , \a -> pure . percentage a)
+      | otherwise =
+          ( showMixedAmountLinesB noPrice{displayOrder=Just cs, displayMinWidth=Nothing, displayColour=color_}
+          , \a b -> fmap (percentage' a b) cs)
+
+    showrow :: [BudgetCell] -> [(WideBuilder, BudgetDisplayRow)]
+    showrow row =
+      let cs = budgetCellsCommodities row
+          (showmixed, percbudget) = rowfuncs cs
+       in   zip (fmap wbFromText cs)
+          . transpose
+          . fmap (showcell showmixed percbudget)
+          $ row
+
+    budgetCellsCommodities = S.toList . foldl' S.union mempty . fmap budgetCellCommodities
     budgetCellCommodities :: BudgetCell -> S.Set CommoditySymbol
     budgetCellCommodities (am, bm) = f am `S.union` f bm
       where f = maybe mempty maCommodities
 
-    displayTableWithWidths :: Table Text Text ((Int, Int, Int), BudgetDisplayCell)
+    cellswidth :: [BudgetCell] -> [[(Int, Int, Int)]]
-    displayTableWithWidths = Table rh ch $ map (zipWith (,) widths) displaycells
+    cellswidth row =
-    Table rh ch displaycells = case budgetReportAsTable ropts budgetr of
+      let cs = budgetCellsCommodities row
-        Table rh' ch' vals -> maybetranspose . Table rh' ch' $ map (map cellWidth) vals
+          (showmixed, percbudget) = rowfuncs cs
-
+          disp = showcell showmixed percbudget
-    showNorm = showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32}
+          budgetpercwidth = wbWidth *** maybe 0 wbWidth
-
+          cellwidth (am, bm) = let (bw, pw) = maybe (0, 0) budgetpercwidth bm in (wbWidth am, bw, pw)
-    cellWidth :: BudgetCell -> BudgetDisplayCell
+       in fmap (fmap cellwidth . disp) row
-    cellWidth cell@(actual, budget) =
-        let (showF, budgetF)
-              | not commodity_column_ = (showamt , budgetAndPerc)
-              | otherwise              = (showamt', budgetAndPerc')
-            (bam, bp) = fromMaybe (0, 0) $ budgetF <$> budget
-         in (cell, (showF actual', bam, bp))
-      where
-        actual' = fromMaybe nullmixedamt actual
-        budgetAndPerc b = (showamt b, fromMaybe 0 $ showper <$> percentage actual' b)
-        showamt = wbWidth . showNorm
-        showper = T.length . showperc
-
-        cs = S.toList $ budgetCellCommodities cell
-        showComm amt = showMixedAmountLinesB noPrice{displayOrder = Just cs} amt
-        showamt' = maximum' . fmap wbWidth . showComm
-        budgetAndPerc' b = (showamt' b, maximum' $ fmap (fromMaybe 0 . fmap showper . percentage' actual' b) cs)
 
+    -- build a list of widths for each column. In the case of transposed budget
+    -- reports, the total 'row' must be included in this list
     widths = zip3 actualwidths budgetwidths percentwidths
-    actualwidths  = map (maximum' . map (first3  . snd)) cols
-    budgetwidths  = map (maximum' . map (second3 . snd)) cols
-    percentwidths = map (maximum' . map (third3  . snd)) cols
-    cols = transpose displaycells
-
-    -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells
-    showcell :: (Int, Int, Int) -> BudgetDisplayCell -> Cell
-    showcell abs@(actualwidth, _, _) ((actual, mbudget), dim@(wa, _, _)) =
-        Cell TopRight [WideBuilder ( TB.fromText (T.replicate (actualwidth - wa) " ")
-                                   <> TB.fromText (toText actual')
-                                   <> budgetstr abs dim (budgetAndPerc <$> mbudget)
-                                   ) (actualwidth + totalbudgetwidth)]
       where
-        toText = TL.toStrict . TB.toLazyText . wbBuilder . showNorm
+        actualwidths  = map (maximum' . map first3 ) $ cols
-        actual' = fromMaybe nullmixedamt actual
+        budgetwidths  = map (maximum' . map second3) $ cols
-        budgetAndPerc b = (toText b, showperc <$> percentage actual' b)
+        percentwidths = map (maximum' . map third3 ) $ cols
+        catcolumnwidths = foldl (\l a -> zipWith (++) l a) (repeat [])
+        cols = maybetranspose $ catcolumnwidths $ map (cellswidth . rowToBudgetCells) items ++ [cellswidth $ rowToBudgetCells tr]
 
-        (_, totalbudgetwidth) = budgetw abs
+    -- split a BudgetCell into BudgetDisplayCell's (one per commodity when applicable)
-
+    showcell :: BudgetShowMixed -> BudgetPercBudget -> BudgetCell -> BudgetDisplayRow
-    showcell' :: [CommoditySymbol] -> (Int, Int, Int) -> BudgetDisplayCell -> Cell
+    showcell showmixed percbudget (actual, mbudget) = zip (showmixed actual') full
-    showcell' cs abs@(actualwidth, _, _) ((actual, mbudget), _) = Cell TopRight full
       where
-        showComm = showMixedAmountLinesB noPrice{displayOrder = Just cs}
-
         actual' = fromMaybe nullmixedamt actual
 
-        toPadded (WideBuilder b w) =
+        budgetAndPerc b = uncurry zip
-            (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b
+          ( showmixed b
-        paddedActual = fmap toPadded $ showComm actual'
+          , fmap (fmap (wbFromText . T.pack . show . roundTo 0)) $ percbudget actual' b
-
-        (_, totalbudgetwidth) = budgetw abs
-
-        budgetAndPerc :: MixedAmount -> [TB.Builder]
-        budgetAndPerc = fmap toBudgetStr . uncurry zip . toText
-          where
-            toBudgetStr t@(b, mp) =
-              let bt = if b == "0" then Nothing else Just t
-               in budgetstr abs (0, textWidth b, maybe 0 textWidth mp) bt
-            toText b =
-                ( fmap (TL.toStrict . TB.toLazyText . wbBuilder) $ showComm b
-                , fmap (fmap showperc . percentage' actual' b) cs
-                )
-
-        full :: [WideBuilder]
-        full = fmap (flip WideBuilder (actualwidth + totalbudgetwidth)) $
-            zipWith (<>) paddedActual (fromMaybe (repeat (TB.fromText $ T.replicate totalbudgetwidth " ")) $ fmap budgetAndPerc mbudget)
-
-    budgetw (_, budgetwidth, percentwidth) =
-      let totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5
-       in ( totalpercentwidth
-          , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3
           )
 
-    -- | Display a padded budget string
+        full
-    budgetstr abs@(_, budgetwidth, percentwidth) (_, wb, wp) mbudget =
+          | Just b <- mbudget = fmap Just $ budgetAndPerc b
-        TB.fromText $ case mbudget of
+          | otherwise         = repeat Nothing
-      Nothing                 -> T.replicate totalbudgetwidth " "
-      Just (budget, Nothing)  -> " [" <> T.replicate totalpercentwidth " " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
-      Just (budget, Just pct) -> " [" <> T.replicate (percentwidth - wp) " " <> pct <> "% of " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
 
-      where (totalpercentwidth, totalbudgetwidth) = budgetw abs
+    paddisplaycell :: (Int, Int, Int) -> BudgetDisplayCell -> WideBuilder
+    paddisplaycell (actualwidth, budgetwidth, percentwidth) (actual, mbudget) = full
+      where
+        toPadded (WideBuilder b w) =
+            (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b
 
-    showperc :: Percentage -> Text
+        (totalpercentwidth, totalbudgetwidth) =
-    showperc = T.pack . show . roundTo 0
+          let totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5
+           in ( totalpercentwidth
+              , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3
+              )
+
+        -- | Display a padded budget string
+        budgetb (budget, perc) =
+          let perct = case perc of
+                Nothing  -> T.replicate totalpercentwidth " "
+                Just pct -> T.replicate (percentwidth - wbWidth pct) " " <> wbToText pct <> "% of "
+           in TB.fromText $ " [" <> perct <> T.replicate (budgetwidth - wbWidth budget) " " <> wbToText budget <> "]"
+
+        emptyBudget = TB.fromText $ T.replicate totalbudgetwidth " "
+
+        full = flip WideBuilder (actualwidth + totalbudgetwidth) $
+            toPadded actual <> maybe emptyBudget budgetb mbudget
 
     -- | Calculate the percentage of actual change to budget goal to show, if any.
     -- If valuing at cost, both amounts are converted to cost before comparing.
@@ -357,46 +398,11 @@ budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
             NoCost -> amounts
 
     -- | Calculate the percentage of actual change to budget goal for a particular commodity
-    percentage' :: MixedAmount -> MixedAmount -> CommoditySymbol -> Maybe Percentage
+    percentage' :: Change -> BudgetGoal -> CommoditySymbol -> Maybe Percentage
     percentage' am bm c = case ((,) `on` find ((==) c . acommodity) . amounts) am bm of
         (Just a, Just b) -> percentage (mixedAmount a) (mixedAmount b)
         _                -> Nothing
 
-    maybetranspose | transpose_ = \(Table rh ch vals) -> Table ch rh (transpose vals)
-                   | otherwise  = id
-
--- | Build a 'Table' from a multi-column balance report.
-budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text (Maybe MixedAmount, Maybe MixedAmount)
-budgetReportAsTable
-  ropts@ReportOpts{balanceaccum_}
-  (PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) =
-    addtotalrow $
-    Table
-      (Tab.Group NoLine $ map Header accts)
-      (Tab.Group NoLine $ map Header colheadings)
-      (map rowvals rows)
-  where
-    colheadings = ["Commodity" | commodity_column_ ropts]
-                  ++ map (reportPeriodName balanceaccum_ spans) spans
-                  ++ ["  Total" | row_total_ ropts]
-                  ++ ["Average" | average_ ropts]
-
-    accts = map renderacct rows
-    -- FIXME. Have to check explicitly for which to render here, since
-    -- budgetReport sets accountlistmode to ALTree. Find a principled way to do
-    -- this.
-    renderacct row = case accountlistmode_ ropts of
-        ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row
-        ALFlat -> accountNameDrop (drop_ ropts) $ prrFullName row
-    rowvals (PeriodicReportRow _ as rowtot rowavg) =
-        as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts]
-    addtotalrow
-      | no_total_ ropts = id
-      | otherwise = (+----+ (row "" $
-                       coltots ++ [grandtot | row_total_ ropts && not (null coltots)]
-                               ++ [grandavg | average_ ropts && not (null coltots)]
-                    ))
-
 -- XXX generalise this with multiBalanceReportAsCsv ?
 -- | Render a budget report as CSV. Like multiBalanceReportAsCsv,
 -- but includes alternating actual and budget amount columns.

hledger-lib/Hledger/Reports/MultiBalanceReport.hs

@@ -27,6 +27,7 @@ module Hledger.Reports.MultiBalanceReport (
   getPostings,
   startingBalances,
   generateMultiBalanceReport,
+  balanceReportTableAsText,
 
   -- -- * Tests
   tests_MultiBalanceReport
@@ -47,6 +48,11 @@ import Data.Semigroup (sconcat)
 import Data.Time.Calendar (Day, fromGregorian)
 import Safe (lastDef, minimumMay)
 
+import Data.Default (def)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Text.Tabular.AsciiWide as Tab
+
 import Hledger.Data
 import Hledger.Query
 import Hledger.Utils hiding (dbg3,dbg4,dbg5)
@@ -555,6 +561,25 @@ cumulativeSum :: (DateSpan -> Account -> Account) -> Account -> Map DateSpan Acc
 cumulativeSum value start = snd . M.mapAccumWithKey accumValued start
   where accumValued startAmt date newAmt = let s = sumAcct startAmt newAmt in (s, value date s)
 
+-- | Given a table representing a multi-column balance report (for example,
+-- made using 'balanceReportAsTable'), render it in a format suitable for
+-- console output. Amounts with more than two commodities will be elided
+-- unless --no-elide is used.
+balanceReportTableAsText :: ReportOpts -> Tab.Table T.Text T.Text WideBuilder -> TB.Builder
+balanceReportTableAsText ReportOpts{..} =
+    Tab.renderTableByRowsB def{Tab.tableBorders=False, Tab.prettyTable=pretty_tables_} renderCh renderRow
+  where
+    renderCh
+      | not commodity_column_ || transpose_ = fmap (Tab.textCell Tab.TopRight)
+      | otherwise = zipWith ($) (Tab.textCell Tab.TopLeft : repeat (Tab.textCell Tab.TopRight))
+
+    renderRow (rh, row)
+      | not commodity_column_ || transpose_ =
+          (Tab.textCell Tab.TopLeft rh, fmap (Tab.Cell Tab.TopRight . pure) row)
+      | otherwise =
+          (Tab.textCell Tab.TopLeft rh, zipWith ($) (Tab.Cell Tab.TopLeft : repeat (Tab.Cell Tab.TopRight)) (fmap pure row))
+
+
 -- tests
 
 tests_MultiBalanceReport = tests "MultiBalanceReport" [

hledger/Hledger/Cli/Commands/Balance.hs

@@ -678,25 +678,6 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balanceaccum_}
     maybetranspose | transpose_ opts = \(Table rh ch vals) -> Table ch rh (transpose vals)
                    | otherwise       = id
 
--- | Given a table representing a multi-column balance report (for example,
--- made using 'balanceReportAsTable'), render it in a format suitable for
--- console output. Amounts with more than two commodities will be elided
--- unless --no-elide is used.
-balanceReportTableAsText :: ReportOpts -> Table T.Text T.Text WideBuilder -> TB.Builder
-balanceReportTableAsText ReportOpts{..} =
-    Tab.renderTableByRowsB def{tableBorders=False, prettyTable=pretty_tables_} renderCh renderRow
-  where
-    renderCh
-      | not commodity_column_ || transpose_ = fmap (Tab.textCell TopRight)
-      | otherwise = zipWith ($) (Tab.textCell TopLeft : repeat (Tab.textCell TopRight))
-
-    renderRow :: (T.Text, [WideBuilder]) -> (Cell, [Cell])
-    renderRow (rh, row)
-      | not commodity_column_ || transpose_ =
-          (Tab.textCell TopLeft rh, fmap (Cell TopRight . pure) row)
-      | otherwise =
-          (Tab.textCell TopLeft rh, zipWith ($) (Cell TopLeft : repeat (Cell TopRight)) (fmap pure row))
-
 multiBalanceRowAsWbs :: AmountDisplayOpts -> ReportOpts -> PeriodicReportRow a MixedAmount -> [[WideBuilder]]
 multiBalanceRowAsWbs bopts ReportOpts{..} (PeriodicReportRow _ as rowtot rowavg)
   | not commodity_column_ = [fmap (showMixedAmountB bopts) all]