cli: Commands.Balance.multiBalanceReportAsSpreadsheetHelper: vertically merge cells showing account names and Total

thielema · thielema · commit bd82537754a4 · 2024-09-29T11:08:22.000+02:00
lib: Write.Spreadsheet: add support for cell spans
diff --git a/hledger-lib/Hledger/Write/Html.hs b/hledger-lib/Hledger/Write/Html.hs
@@ -54,19 +54,30 @@ formatCell cell =
     let class_ =
             map Lucid.class_ $
             filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in
+    let span_ makeCell attrs cont =
+            case Spr.cellSpan cell of
+                Spr.NoSpan -> makeCell attrs cont
+                Spr.Covered -> pure ()
+                Spr.SpanHorizontal n ->
+                    makeCell (Lucid.colspan_ (Text.pack $ show n) : attrs) cont
+                Spr.SpanVertical n ->
+                    makeCell (Lucid.rowspan_ (Text.pack $ show n) : attrs) cont
+            in
     case cellStyle cell of
-        Head -> Lucid.th_ (style++class_) content
+        Head -> span_ Lucid.th_ (style++class_) content
         Body emph ->
             let align =
                     case cellType cell of
                         TypeString -> []
                         TypeDate -> []
                         _ -> [LucidBase.makeAttribute "align" "right"]
+                valign = [LucidBase.makeAttribute "valign" "top"]
                 withEmph =
                     case emph of
                         Item -> id
                         Total -> Lucid.b_
-            in  Lucid.td_ (style++align++class_) $ withEmph content
+            in  span_ Lucid.td_ (style++align++valign++class_) $
+                withEmph content
 
 
 class (Spr.Lines border) => Lines border where
diff --git a/hledger-lib/Hledger/Write/Ods.hs b/hledger-lib/Hledger/Write/Ods.hs
@@ -239,24 +239,32 @@ data DataStyle =
 
 cellConfig :: ((Spr.Border Spr.NumLines, Style), DataStyle) -> [String]
 cellConfig ((border, cstyle), dataStyle) =
-    let moreStyles =
+    let boldStyle = "    <style:text-properties fo:font-weight='bold'/>"
+        alignTop =
+            "    <style:table-cell-properties style:vertical-align='top'/>"
+        alignParagraph =
+            printf "    <style:paragraph-properties fo:text-align='%s'/>"
+        moreStyles =
             borderStyle border
             ++
             (
             case cstyle of
-                Body Item -> []
+                Body Item ->
+                    alignTop :
+                    []
                 Body Total ->
-                    ["    <style:text-properties fo:font-weight='bold'/>"]
+                    alignTop :
+                    boldStyle :
+                    []
                 Head ->
-                    "    <style:paragraph-properties fo:text-align='center'/>" :
-                    "    <style:text-properties fo:font-weight='bold'/>" :
+                    alignParagraph "center" :
+                    boldStyle :
                     []
             )
             ++
             (
             case dataStyle of
-                DataMixedAmount ->
-                    ["    <style:paragraph-properties fo:text-align='end'/>"]
+                DataMixedAmount -> [alignParagraph "end"]
                 _ -> []
             )
         cstyleName = cellStyleName cstyle
@@ -314,17 +322,30 @@ formatCell cell =
                         (cellContent cell)
                 _ -> "office:value-type='string'"
 
+        covered =
+            case cellSpan cell of
+                Spr.Covered -> "covered-"
+                _ -> ""
+
+        span_ =
+            case cellSpan cell of
+                Spr.SpanHorizontal n | n>1 ->
+                    printf " table:number-columns-spanned='%d'" n
+                Spr.SpanVertical n | n>1 ->
+                    printf " table:number-rows-spanned='%d'" n
+                _ -> ""
+
         anchor text =
             if T.null $ Spr.cellAnchor cell
                 then text
                 else printf "<text:a xlink:href='%s'>%s</text:a>"
                         (escape $ T.unpack $ Spr.cellAnchor cell) text
 
     in
-    printf "<table:table-cell%s %s>" style valueType :
+    printf "<table:%stable-cell%s%s %s>" covered style span_ valueType :
     printf "<text:p>%s</text:p>"
         (anchor $ escape $ T.unpack $ cellContent cell) :
-    "</table:table-cell>" :
+    printf "</table:%stable-cell>" covered :
     []
 
 escape :: String -> String
diff --git a/hledger-lib/Hledger/Write/Spreadsheet.hs b/hledger-lib/Hledger/Write/Spreadsheet.hs
@@ -8,6 +8,7 @@ module Hledger.Write.Spreadsheet (
     Emphasis(..),
     Cell(..),
     Class(Class), textFromClass,
+    Span(..),
     Border(..),
     Lines(..),
     NumLines(..),
@@ -23,6 +24,8 @@ import Hledger.Data.Types (Amount)
 import qualified Data.List as List
 import Data.Text (Text)
 
+import Prelude hiding (span)
+
 
 data Type =
       TypeString
@@ -82,26 +85,67 @@ newtype Class = Class Text
 textFromClass :: Class -> Text
 textFromClass (Class cls) = cls
 
+
+{- |
+* 'NoSpan' means a single unmerged cell.
+
+* 'Covered' is a cell if it is part of a horizontally or vertically merged cell.
+  We maintain these cells although they are ignored in HTML output.
+  In contrast to that, FODS can store covered cells
+  and allows to access the hidden cell content via formulas.
+  CSV does not support merged cells
+  and thus simply writes the content of covered cells.
+  Maintaining 'Covered' cells also simplifies transposing.
+
+* @'SpanHorizontal' n@ denotes the first cell in a row
+  that is part of a merged cell.
+  The merged cell contains @n@ atomic cells, including the first one.
+  That is @SpanHorizontal 1@ is actually like @NoSpan@.
+  The content of this cell is shown as content of the merged cell.
+
+* @'SpanVertical' n@ starts a vertically merged cell.
+
+The writer functions expect consistent data,
+that is, 'Covered' cells must actually be part of a merged cell
+and merged cells must only cover 'Covered' cells.
+-}
+data Span =
+      NoSpan
+    | Covered
+    | SpanHorizontal Int
+    | SpanVertical Int
+    deriving (Eq)
+
+transposeSpan :: Span -> Span
+transposeSpan span =
+    case span of
+        NoSpan -> NoSpan
+        Covered -> Covered
+        SpanHorizontal n -> SpanVertical n
+        SpanVertical n -> SpanHorizontal n
+
 data Cell border text =
     Cell {
         cellType :: Type,
         cellBorder :: Border border,
         cellStyle :: Style,
+        cellSpan :: Span,
         cellAnchor :: Text,
         cellClass :: Class,
         cellContent :: text
     }
 
 instance Functor (Cell border) where
-    fmap f (Cell typ border style anchor class_ content) =
-        Cell typ border style anchor class_ $ f content
+    fmap f (Cell typ border style span anchor class_ content) =
+        Cell typ border style span anchor class_ $ f content
 
 defaultCell :: (Lines border) => text -> Cell border text
 defaultCell text =
     Cell {
         cellType = TypeString,
         cellBorder = noBorder,
         cellStyle = Body Item,
+        cellSpan = NoSpan,
         cellAnchor = mempty,
         cellClass = Class mempty,
         cellContent = text
@@ -112,7 +156,10 @@ emptyCell = defaultCell mempty
 
 transposeCell :: Cell border text -> Cell border text
 transposeCell cell =
-    cell {cellBorder = transposeBorder $ cellBorder cell}
+    cell {
+        cellBorder = transposeBorder $ cellBorder cell,
+        cellSpan = transposeSpan $ cellSpan cell
+    }
 
 transpose :: [[Cell border text]] -> [[Cell border text]]
 transpose = List.transpose . map (map transposeCell)
diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs
@@ -260,6 +260,7 @@ module Hledger.Cli.Commands.Balance (
  ,multiBalanceReportTableAsText
  ,multiBalanceReportAsSpreadsheet
  ,addTotalBorders
+ ,addRowSpanHeader
  ,simpleDateSpanCell
  ,RowClass(..)
   -- ** Tests
@@ -454,12 +455,11 @@ budgetAverageClass rc =
     case rc of Value -> "budget rowaverage"; Total -> "budget colaverage"
 
 -- What to show as heading for the totals row in balance reports ?
--- Currently nothing in terminal, Total: in html and xSV output.
-totalRowHeadingText       = ""
-totalRowHeadingBudgetText = ""
-totalRowHeadingHtml       = "Total:"
-totalRowHeadingCsv        = "Total:"
-totalRowHeadingBudgetCsv  = "Total:"
+-- Currently nothing in terminal, Total: in HTML, FODS and xSV output.
+totalRowHeadingText        = ""
+totalRowHeadingSpreadsheet = "Total:"
+totalRowHeadingBudgetText  = ""
+totalRowHeadingBudgetCsv   = "Total:"
 
 -- Single-column balance reports
 
@@ -659,6 +659,19 @@ addTotalBorders =
 rawTableContent :: [[Ods.Cell border text]] -> [[text]]
 rawTableContent = map (map Ods.cellContent)
 
+addRowSpanHeader ::
+    Ods.Cell border text ->
+    [[Ods.Cell border text]] -> [[Ods.Cell border text]]
+addRowSpanHeader header rows =
+    case rows of
+        [] -> []
+        [row] -> [header:row]
+        _ ->
+            zipWith (:)
+                (header{Ods.cellSpan = Ods.SpanVertical (length rows)} :
+                 repeat header{Ods.cellSpan = Ods.Covered})
+                rows
+
 setAccountAnchor ::
     Maybe Text -> [Text] -> Text -> Ods.Cell border text -> Ods.Cell border text
 setAccountAnchor base query acct cell =
@@ -673,7 +686,7 @@ balanceReportAsSpreadsheet opts (items, total) =
     headers :
     concatMap (\(a, _, _, b) -> rows Value a b) items ++
     if no_total_ opts then []
-      else addTotalBorders $ rows Total totalRowHeadingCsv total
+      else addTotalBorders $ rows Total totalRowHeadingSpreadsheet total
   where
     cell = Ods.defaultCell
     headers =
@@ -690,14 +703,12 @@ balanceReportAsSpreadsheet opts (items, total) =
                   (guard (rc==Value) >> balance_base_url_ opts)
                   (querystring_ opts) name $
               cell $ accountNameDrop (drop_ opts) name in
+      addRowSpanHeader accountCell $
       case layout_ opts of
       LayoutBare ->
-          map (\a ->
-                [accountCell,
-                 cell $ acommodity a,
-                 renderAmount rc $ mixedAmount a])
+          map (\a -> [cell $ acommodity a, renderAmount rc $ mixedAmount a])
           . amounts $ mixedAmountStripCosts ma
-      _ -> [[accountCell, renderAmount rc ma]]
+      _ -> [[renderAmount rc ma]]
 
     renderAmount rc mixedAmt =
         wbToText <$> cellFromMixedAmount bopts (amountClass rc, mixedAmt)
@@ -783,18 +794,17 @@ multiBalanceReportAsSpreadsheetHelper ishtml opts@ReportOpts{..} (PeriodicReport
       [hCell "rowtotal" "total" | row_total_] ++
       [hCell "rowaverage" "average" | average_]
     fullRowAsTexts row =
-        map (anchorCell:) $
+        addRowSpanHeader anchorCell $
         rowAsText Value (dateSpanCell balance_base_url_ querystring_ acctName) row
       where acctName = prrFullName row
             anchorCell =
               setAccountAnchor balance_base_url_ querystring_ acctName $
               accountCell $ accountNameDrop drop_ acctName
-    totalrows
-      | no_total_ = []
-      | ishtml    = zipWith (:) (accountCell totalRowHeadingHtml : repeat Ods.emptyCell) $
-                    rowAsText Total simpleDateSpanCell tr
-      | otherwise = map (accountCell totalRowHeadingCsv :) $
-                    rowAsText Total simpleDateSpanCell tr
+    totalrows =
+      if no_total_
+        then []
+        else addRowSpanHeader (accountCell totalRowHeadingSpreadsheet) $
+                rowAsText Total simpleDateSpanCell tr
     rowAsText rc dsCell =
         let fmt = if ishtml then oneLineNoCostFmt else machineFmt
         in  map (map (fmap wbToText)) .
diff --git a/hledger/Hledger/Cli/CompoundBalanceCommand.hs b/hledger/Hledger/Cli/CompoundBalanceCommand.hs
@@ -370,7 +370,7 @@ compoundBalanceReportAsHtml ropts cbr =
             Total simpleDateSpanCell totalrow
                              -- make a table of rendered lines of the report totals row
         & map (map (fmap wbToText))
-        & zipWith (:) (Spr.defaultCell "Net:" : repeat Spr.emptyCell)
+        & addRowSpanHeader (Spr.defaultCell "Net:")
                              -- insert a headings column, with Net: on the first line only
         & addTotalBorders    -- marking the first for special styling
         & map (Html.formatRow . map (fmap L.toHtml))
