From 5565f11c737df123e5219dd2a2ce5a18f1bf76b3 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 29 Sep 2024 23:41:47 +0200 Subject: [PATCH] cli: Commands.Balance.multiBalanceReportAsSpreadsheetHelper: vertically merge cells showing account names and Total lib: Write.Spreadsheet: add support for cell spans --- hledger-lib/Hledger/Write/Html/Blaze.hs | 23 ++++++-- hledger-lib/Hledger/Write/Html/Lucid.hs | 21 +++++++- hledger-lib/Hledger/Write/Ods.hs | 39 ++++++++++---- hledger-lib/Hledger/Write/Spreadsheet.hs | 53 +++++++++++++++++-- hledger/Hledger/Cli/Commands/Balance.hs | 48 ++++++++++------- hledger/Hledger/Cli/CompoundBalanceCommand.hs | 2 +- 6 files changed, 148 insertions(+), 38 deletions(-) diff --git a/hledger-lib/Hledger/Write/Html/Blaze.hs b/hledger-lib/Hledger/Write/Html/Blaze.hs index 4a99f5f5e..79c5e1b6f 100644 --- a/hledger-lib/Hledger/Write/Html/Blaze.hs +++ b/hledger-lib/Hledger/Write/Html/Blaze.hs @@ -46,18 +46,33 @@ formatCell cell = let class_ = map (HtmlAttr.class_ . Html.textValue) $ filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in + let span_ makeCell attrs = + case Spr.cellSpan cell of + Spr.NoSpan -> foldl (!) makeCell attrs + Spr.Covered -> pure () + Spr.SpanHorizontal n -> + foldl (!) makeCell + (HtmlAttr.colspan (Html.stringValue $ show n) : attrs) + Spr.SpanVertical n -> + foldl (!) makeCell + (HtmlAttr.rowspan (Html.stringValue $ show n) : attrs) + in case cellStyle cell of - Head -> foldl (!) (Html.th content) (style++class_) + Head -> span_ (Html.th content) (style++class_) Body emph -> let align = case cellType cell of TypeString -> [] TypeDate -> [] _ -> [HtmlAttr.align "right"] - valign = [HtmlAttr.valign "top"] + valign = + case Spr.cellSpan cell of + Spr.SpanVertical n -> + if n>1 then [HtmlAttr.valign "top"] else [] + _ -> [] withEmph = case emph of Item -> id Total -> Html.b - in foldl (!) (Html.td $ withEmph content) - (style++align++valign++class_) + in span_ (Html.td $ withEmph content) $ + style++align++valign++class_ diff --git a/hledger-lib/Hledger/Write/Html/Lucid.hs b/hledger-lib/Hledger/Write/Html/Lucid.hs index d4bdea8ac..1e1215b0f 100644 --- a/hledger-lib/Hledger/Write/Html/Lucid.hs +++ b/hledger-lib/Hledger/Write/Html/Lucid.hs @@ -45,16 +45,33 @@ formatCell cell = let class_ = map Html.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 (Html.colspan_ (Text.pack $ show n) : attrs) cont + Spr.SpanVertical n -> + makeCell (Html.rowspan_ (Text.pack $ show n) : attrs) cont + in case cellStyle cell of - Head -> Html.th_ (style++class_) content + Head -> span_ Html.th_ (style++class_) content Body emph -> let align = case cellType cell of TypeString -> [] TypeDate -> [] _ -> [HtmlBase.makeAttribute "align" "right"] + valign = + case Spr.cellSpan cell of + Spr.SpanVertical n -> + if n>1 + then [HtmlBase.makeAttribute "valign" "top"] + else [] + _ -> [] withEmph = case emph of Item -> id Total -> Html.b_ - in Html.td_ (style++align++class_) $ withEmph content + in span_ Html.td_ (style++align++valign++class_) $ + withEmph content diff --git a/hledger-lib/Hledger/Write/Ods.hs b/hledger-lib/Hledger/Write/Ods.hs index 7d299b222..0e75f55b3 100644 --- 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 = " " + alignTop = + " " + alignParagraph = + printf " " + moreStyles = borderStyle border ++ ( case cstyle of - Body Item -> [] + Body Item -> + alignTop : + [] Body Total -> - [" "] + alignTop : + boldStyle : + [] Head -> - " " : - " " : + alignParagraph "center" : + boldStyle : [] ) ++ ( case dataStyle of - DataMixedAmount -> - [" "] + DataMixedAmount -> [alignParagraph "end"] _ -> [] ) cstyleName = cellStyleName cstyle @@ -314,6 +322,19 @@ 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 @@ -321,10 +342,10 @@ formatCell cell = (escape $ T.unpack $ Spr.cellAnchor cell) text in - printf "" style valueType : + printf "" covered style span_ valueType : printf "%s" (anchor $ escape $ T.unpack $ cellContent cell) : - "" : + printf "" covered : [] escape :: String -> String diff --git a/hledger-lib/Hledger/Write/Spreadsheet.hs b/hledger-lib/Hledger/Write/Spreadsheet.hs index 538fc1994..9a66fa06b 100644 --- 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,19 +85,59 @@ 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 = @@ -102,6 +145,7 @@ defaultCell text = 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 index 6ce211879..dea47eee4 100644 --- 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 @@ -458,12 +459,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 @@ -663,6 +663,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 = @@ -677,7 +690,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 = @@ -694,14 +707,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) @@ -787,18 +798,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 index 5f42f87a0..2a5a59ac3 100644 --- a/hledger/Hledger/Cli/CompoundBalanceCommand.hs +++ b/hledger/Hledger/Cli/CompoundBalanceCommand.hs @@ -376,7 +376,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))