lib: Write.Spreadsheet: support for borders like in existing HTML export

cli: Commands.Balance: use for FODS export and balance and budget export to HTML

hledger-lib/Hledger/Write/Html.hs

@@ -8,24 +8,43 @@ module Hledger.Write.Html (
     printHtml,
     ) where
 
+import qualified Hledger.Write.Spreadsheet as Spr
 import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
 
+import qualified Data.Text as Text
 import qualified Lucid.Base as LucidBase
 import qualified Lucid
+import Data.Text (Text)
 import Data.Foldable (for_)
 
 
-printHtml :: [[Cell (Lucid.Html ())]] -> Lucid.Html ()
+printHtml :: (Lines border) => [[Cell border (Lucid.Html ())]] -> Lucid.Html ()
-printHtml table =
+printHtml table = do
+    Lucid.style_ $ Text.unlines $
+        "" :
+        "table {border-collapse:collapse}" :
+        "th, td {padding-left:1em}" :
+        "th.account, td.account {padding-left:0;}" :
+        []
     Lucid.table_ $ for_ table $ \row ->
-    Lucid.tr_ $ for_ row $ \cell ->
+        Lucid.tr_ $ for_ row $ \cell ->
-    formatCell cell
+        formatCell cell
 
-formatCell :: Cell (Lucid.Html ()) -> Lucid.Html ()
+formatCell :: (Lines border) => Cell border (Lucid.Html ()) -> Lucid.Html ()
 formatCell cell =
     let str = cellContent cell in
+    let border field access =
+            map (field<>) $ borderLines $ access $ cellBorder cell in
+    let leftBorder   = border "border-left:"   Spr.borderLeft   in
+    let rightBorder  = border "border-right:"  Spr.borderRight  in
+    let topBorder    = border "border-top:"    Spr.borderTop    in
+    let bottomBorder = border "border-bottom:" Spr.borderBottom in
+    let style =
+            case leftBorder++rightBorder++topBorder++bottomBorder of
+                [] -> []
+                ss -> [Lucid.style_ $ Text.intercalate "; " ss] in
     case cellStyle cell of
-        Head -> Lucid.th_ str
+        Head -> Lucid.th_ style str
         Body emph ->
             let align =
                     case cellType cell of
@@ -36,4 +55,18 @@ formatCell cell =
                     case emph of
                         Item -> id
                         Total -> Lucid.b_
-            in  Lucid.td_ align $ withEmph str
+            in  Lucid.td_ (style++align) $ withEmph str
+
+
+class (Spr.Lines border) => Lines border where
+    borderLines :: border -> [Text]
+
+instance Lines () where
+    borderLines () = []
+
+instance Lines Spr.NumLines where
+    borderLines prop =
+        case prop of
+            Spr.NoLine -> []
+            Spr.SingleLine -> ["black"]
+            Spr.DoubleLine -> ["double black"]

hledger-lib/Hledger/Write/Ods.hs

@@ -12,6 +12,7 @@ module Hledger.Write.Ods (
     printFods,
     ) where
 
+import qualified Hledger.Write.Spreadsheet as Spr
 import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
 import Hledger.Data.Types (CommoditySymbol, AmountPrecision(..))
 import Hledger.Data.Types (acommodity, aquantity, astyle, asprecision)
@@ -20,12 +21,14 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Text as T
 import Data.Text (Text)
 
+import qualified Data.Foldable as Fold
+import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Foldable (fold)
 import Data.Map (Map)
 import Data.Set (Set)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (catMaybes)
 
 import qualified System.IO as IO
 import Text.Printf (printf)
@@ -33,7 +36,7 @@ import Text.Printf (printf)
 
 printFods ::
     IO.TextEncoding ->
-    Map Text ((Maybe Int, Maybe Int), [[Cell Text]]) -> TL.Text
+    Map Text ((Maybe Int, Maybe Int), [[Cell Spr.NumLines Text]]) -> TL.Text
 printFods encoding tables =
     let fileOpen customStyles =
           map (map (\c -> case c of '\'' -> '"'; _ -> c)) $
@@ -57,20 +60,6 @@ printFods encoding tables =
           "  xmlns:field='urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0'" :
           "  xmlns:form='urn:oasis:names:tc:opendocument:xmlns:form:1.0'>" :
           "<office:styles>" :
-          "  <style:style style:name='head' style:family='table-cell'>" :
-          "    <style:paragraph-properties fo:text-align='center'/>" :
-          "    <style:text-properties fo:font-weight='bold'/>" :
-          "  </style:style>" :
-          "  <style:style style:name='foot' style:family='table-cell'>" :
-          "    <style:text-properties fo:font-weight='bold'/>" :
-          "  </style:style>" :
-          "  <style:style style:name='amount' style:family='table-cell'>" :
-          "    <style:paragraph-properties fo:text-align='end'/>" :
-          "  </style:style>" :
-          "  <style:style style:name='total-amount' style:family='table-cell'>" :
-          "    <style:paragraph-properties fo:text-align='end'/>" :
-          "    <style:text-properties fo:font-weight='bold'/>" :
-          "  </style:style>" :
           "  <number:date-style style:name='iso-date'>" :
           "    <number:year number:style='long'/>" :
           "    <number:text>-</number:text>" :
@@ -78,12 +67,6 @@ printFods encoding tables =
           "    <number:text>-</number:text>" :
           "    <number:day number:style='long'/>" :
           "  </number:date-style>" :
-          "  <style:style style:name='date' style:family='table-cell'" :
-          "      style:data-style-name='iso-date'/>" :
-          "  <style:style style:name='foot-date' style:family='table-cell'" :
-          "      style:data-style-name='iso-date'>" :
-          "    <style:text-properties fo:font-weight='bold'/>" :
-          "  </style:style>" :
           customStyles ++
           "</office:styles>" :
           []
@@ -135,7 +118,7 @@ printFods encoding tables =
     in  TL.unlines $ map (TL.fromStrict . T.pack) $
         fileOpen
           (let styles = cellStyles (foldMap (concat.snd) tables) in
-           (numberConfig =<< Set.toList (Set.map snd styles))
+           (numberConfig =<< Set.toList (foldMap (numberParams.snd) styles))
            ++
            (cellConfig =<< Set.toList styles)) ++
         tableConfig (fmap fst tables) ++
@@ -150,18 +133,23 @@ printFods encoding tables =
         fileClose
 
 
-cellStyles :: [Cell Text] -> Set (Emphasis, (CommoditySymbol, AmountPrecision))
+dataStyleFromType :: Type -> DataStyle
+dataStyleFromType typ =
+    case typ of
+        TypeString -> DataString
+        TypeDate -> DataDate
+        TypeAmount amt -> DataAmount (acommodity amt) (asprecision $ astyle amt)
+        TypeMixedAmount -> DataMixedAmount
+
+cellStyles ::
+    (Ord border) =>
+    [Cell border Text] ->
+    Set ((Spr.Border border, Style), DataStyle)
 cellStyles =
     Set.fromList .
-    mapMaybe (\cell ->
+    map (\cell ->
-        case cellType cell of
+            ((cellBorder cell, cellStyle cell),
-            TypeAmount amt ->
+             dataStyleFromType $ cellType cell))
-                Just
-                    (case cellStyle cell of
-                        Body emph -> emph
-                        Head -> Total,
-                     (acommodity amt, asprecision $ astyle amt))
-            _ -> Nothing)
 
 numberStyleName :: (CommoditySymbol, AmountPrecision) -> String
 numberStyleName (comm, prec) =
@@ -170,6 +158,10 @@ numberStyleName (comm, prec) =
         NaturalPrecision -> "natural"
         Precision k -> show k
 
+numberParams :: DataStyle -> Set (CommoditySymbol, AmountPrecision)
+numberParams (DataAmount comm prec) = Set.singleton (comm, prec)
+numberParams _ = Set.empty
+
 numberConfig :: (CommoditySymbol, AmountPrecision) -> [String]
 numberConfig (comm, prec) =
     let precStr =
@@ -191,41 +183,123 @@ emphasisName emph =
         Item -> "item"
         Total -> "total"
 
-cellConfig :: (Emphasis, (CommoditySymbol, AmountPrecision)) -> [String]
+cellStyleName :: Style -> String
-cellConfig (emph, numParam) =
+cellStyleName style =
-    let name = numberStyleName numParam in
+    case style of
-    let style :: String
+        Head -> "head"
+        Body emph -> emphasisName emph
+
+linesName :: Spr.NumLines -> Maybe String
+linesName prop =
+    case prop of
+        Spr.NoLine -> Nothing
+        Spr.SingleLine -> Just "single"
+        Spr.DoubleLine -> Just "double"
+
+linesStyle :: Spr.NumLines -> String
+linesStyle prop =
+    case prop of
+        Spr.NoLine -> "none"
+        Spr.SingleLine -> "1.5pt solid #000000"
+        Spr.DoubleLine -> "1.5pt double-thin #000000"
+
+borderLabels :: Spr.Border String
+borderLabels = Spr.Border "left" "right" "top" "bottom"
+
+borderName :: Spr.Border Spr.NumLines -> String
+borderName border =
+    (\bs ->
+        case bs of
+            [] -> "noborder"
+            _ ->
+                ("border="++) $ List.intercalate "," $
+                map (\(name,num) -> name ++ ':' : num) bs) $
+    catMaybes $ Fold.toList $
+    liftA2
+        (\name numLines -> (,) name <$> linesName numLines)
+        borderLabels
+        border
+
+borderStyle :: Spr.Border Spr.NumLines -> [String]
+borderStyle border =
+    if border == Spr.noBorder
+        then []
+        else (:[]) $
+            printf "    <style:table-cell-properties%s/>" $
+            (id :: String -> String) $ fold $
+            liftA2 (printf " fo:border-%s='%s'") borderLabels $
+            fmap linesStyle border
+
+data DataStyle =
+      DataString
+    | DataDate
+    | DataAmount CommoditySymbol AmountPrecision
+    | DataMixedAmount
+    deriving (Eq, Ord, Show)
+
+cellConfig :: ((Spr.Border Spr.NumLines, Style), DataStyle) -> [String]
+cellConfig ((border, cstyle), dataStyle) =
+    let moreStyles =
+            borderStyle border
+            ++
+            (
+            case cstyle of
+                Body Item -> []
+                Body Total ->
+                    ["    <style:text-properties fo:font-weight='bold'/>"]
+                Head ->
+                    "    <style:paragraph-properties fo:text-align='center'/>" :
+                    "    <style:text-properties fo:font-weight='bold'/>" :
+                    []
+            )
+            ++
+            (
+            case dataStyle of
+                DataMixedAmount ->
+                    ["    <style:paragraph-properties fo:text-align='end'/>"]
+                _ -> []
+            )
+        cstyleName = cellStyleName cstyle
+        bordName = borderName border
+        style :: String
         style =
-            printf "style:name='%s-%s' style:data-style-name='number-%s'"
+            case dataStyle of
-                (emphasisName emph) name name in
+                DataDate ->
-    case emph of
+                    printf
-        Item ->
+                      "style:name='%s-%s-date' style:data-style-name='iso-date'"
+                      cstyleName bordName
+                DataAmount comm prec ->
+                    let name = numberStyleName (comm, prec) in
+                    printf
+                      "style:name='%s-%s-%s' style:data-style-name='number-%s'"
+                      cstyleName bordName name name
+                _ -> printf "style:name='%s-%s'" cstyleName bordName
+    in
+    case moreStyles of
+        [] ->
             printf "  <style:style style:family='table-cell' %s/>" style :
             []
-        Total ->
+        _ ->
             printf "  <style:style style:family='table-cell' %s>" style :
-            "    <style:text-properties fo:font-weight='bold'/>" :
+            moreStyles ++
             "  </style:style>" :
             []
 
 
-formatCell :: Cell Text -> [String]
+formatCell :: Cell Spr.NumLines Text -> [String]
 formatCell cell =
     let style, valueType :: String
-        style =
+        style = tableStyle styleName
-          case (cellStyle cell, cellType cell) of
+        cstyleName = cellStyleName $ cellStyle cell
-            (Body emph, TypeAmount amt) -> tableStyle $ numberStyle emph amt
+        bordName = borderName $ cellBorder cell
-            (Body Item, TypeString) -> ""
+        styleName :: String
-            (Body Item, TypeMixedAmount) -> tableStyle "amount"
+        styleName =
-            (Body Item, TypeDate) -> tableStyle "date"
+            case dataStyleFromType $ cellType cell of
-            (Body Total, TypeString) -> tableStyle "foot"
+                DataDate -> printf "%s-%s-date" cstyleName bordName
-            (Body Total, TypeMixedAmount) -> tableStyle "total-amount"
+                DataAmount comm prec ->
-            (Body Total, TypeDate) -> tableStyle "foot-date"
+                    let name = numberStyleName (comm, prec) in
-            (Head, _) -> tableStyle "head"
+                    printf "%s-%s-%s" cstyleName bordName name
-        numberStyle emph amt =
+                _ -> printf "%s-%s" cstyleName bordName
-            printf "%s-%s"
-                (emphasisName emph)
-                (numberStyleName (acommodity amt, asprecision $ astyle amt))
         tableStyle = printf " table:style-name='%s'"
 
         valueType =

hledger-lib/Hledger/Write/Spreadsheet.hs

@@ -7,6 +7,10 @@ module Hledger.Write.Spreadsheet (
     Style(..),
     Emphasis(..),
     Cell(..),
+    Border(..),
+    Lines(..),
+    NumLines(..),
+    noBorder,
     defaultCell,
     emptyCell,
     ) where
@@ -27,23 +31,62 @@ data Style = Body Emphasis | Head
 data Emphasis = Item | Total
     deriving (Eq, Ord, Show)
 
-data Cell text =
+
+class Lines border where noLine :: border
+instance Lines () where noLine = ()
+instance Lines NumLines where noLine = NoLine
+
+{- |
+The same as Tab.Properties, but has 'Eq' and 'Ord' instances.
+We need those for storing 'NumLines' in 'Set's.
+-}
+data NumLines = NoLine | SingleLine | DoubleLine
+    deriving (Eq, Ord, Show)
+
+data Border lines =
+    Border {
+        borderLeft, borderRight,
+        borderTop, borderBottom :: lines
+    }
+    deriving (Eq, Ord, Show)
+
+instance Functor Border where
+    fmap f (Border left right top bottom) =
+        Border (f left) (f right) (f top) (f bottom)
+
+instance Applicative Border where
+    pure a = Border a a a a
+    Border fLeft fRight fTop fBottom <*> Border left right top bottom =
+        Border (fLeft left) (fRight right) (fTop top) (fBottom bottom)
+
+instance Foldable Border where
+    foldMap f (Border left right top bottom) =
+        f left <> f right <> f top <> f bottom
+
+noBorder :: (Lines border) => Border border
+noBorder = pure noLine
+
+
+data Cell border text =
     Cell {
         cellType :: Type,
+        cellBorder :: Border border,
         cellStyle :: Style,
         cellContent :: text
     }
 
-instance Functor Cell where
+instance Functor (Cell border) where
-    fmap f (Cell typ style content) = Cell typ style $ f content
+    fmap f (Cell typ border style content) =
+        Cell typ border style $ f content
 
-defaultCell :: text -> Cell text
+defaultCell :: (Lines border) => text -> Cell border text
 defaultCell text =
     Cell {
         cellType = TypeString,
+        cellBorder = noBorder,
         cellStyle = Body Item,
         cellContent = text
     }
 
-emptyCell :: (Monoid text) => Cell text
+emptyCell :: (Lines border, Monoid text) => Cell border text
 emptyCell = defaultCell mempty

hledger/Hledger/Cli/Commands/Balance.hs

@@ -550,22 +550,42 @@ renderComponent topaligned oneline opts (acctname, dep, total) (FormatField ljus
                   ,displayColour    = color_ opts
                   }
 
+
+headerCell :: Text -> Ods.Cell Ods.NumLines Text
+headerCell text =
+    let deflt = Ods.defaultCell text
+    in
+    deflt {
+        Ods.cellStyle = Ods.Head,
+        Ods.cellBorder =
+            (Ods.cellBorder deflt) {Ods.borderBottom = Ods.DoubleLine}
+    }
+
+addTotalBorders :: [[Ods.Cell border text]] -> [[Ods.Cell Ods.NumLines text]]
+addTotalBorders =
+    zipWith
+        (\border ->
+            map (\c -> c {
+                    Ods.cellStyle = Ods.Body Ods.Total,
+                    Ods.cellBorder = Ods.noBorder {Ods.borderTop = border}}))
+        (Ods.DoubleLine : repeat Ods.NoLine)
+
 -- | Render a single-column balance report as FODS.
-balanceReportAsSpreadsheet :: ReportOpts -> BalanceReport -> [[Ods.Cell Text]]
+balanceReportAsSpreadsheet ::
+    ReportOpts -> BalanceReport -> [[Ods.Cell Ods.NumLines Text]]
 balanceReportAsSpreadsheet opts (items, total) =
     headers :
     concatMap (\(a, _, _, b) -> rows a b) items ++
     if no_total_ opts then []
-      else map (map (\c -> c {Ods.cellStyle = Ods.Body Ods.Total})) $
+      else addTotalBorders $ rows totalRowHeadingCsv total
-            rows totalRowHeadingCsv total
   where
     cell = Ods.defaultCell
     headers =
-      map (\content -> (cell content) {Ods.cellStyle = Ods.Head}) $
+      map headerCell $
       "account" : case layout_ opts of
         LayoutBare -> ["commodity", "balance"]
         _          -> ["balance"]
-    rows :: AccountName -> MixedAmount -> [[Ods.Cell Text]]
+    rows :: AccountName -> MixedAmount -> [[Ods.Cell Ods.NumLines Text]]
     rows name ma = case layout_ opts of
       LayoutBare ->
           map (\a ->
@@ -583,7 +603,9 @@ balanceReportAsSpreadsheet opts (items, total) =
           | layout_ opts == LayoutBare = (False, Just $ S.toList $ maCommodities mixedAmt)
           | otherwise                  = (True, Nothing)
 
-cellFromMixedAmount :: AmountFormat -> MixedAmount -> Ods.Cell WideBuilder
+cellFromMixedAmount ::
+    (Ods.Lines border) =>
+    AmountFormat -> MixedAmount -> Ods.Cell border WideBuilder
 cellFromMixedAmount bopts mixedAmt =
     (Ods.defaultCell $ showMixedAmountB bopts mixedAmt) {
         Ods.cellType =
@@ -592,7 +614,9 @@ cellFromMixedAmount bopts mixedAmt =
             Nothing -> Ods.TypeMixedAmount
     }
 
-cellsFromMixedAmount :: AmountFormat -> MixedAmount -> [Ods.Cell WideBuilder]
+cellsFromMixedAmount ::
+    (Ods.Lines border) =>
+    AmountFormat -> MixedAmount -> [Ods.Cell border WideBuilder]
 cellsFromMixedAmount bopts mixedAmt =
     map
         (\(str,amt) ->
@@ -630,14 +654,14 @@ multiBalanceReportAsCsvHelper ishtml opts =
 
 -- Helper for CSV and ODS and HTML rendering.
 multiBalanceReportAsSpreadsheetHelper ::
-    Bool -> ReportOpts -> MultiBalanceReport -> ([[Ods.Cell Text]], [[Ods.Cell Text]])
+    Bool -> ReportOpts -> MultiBalanceReport ->
+    ([[Ods.Cell Ods.NumLines Text]], [[Ods.Cell Ods.NumLines Text]])
 multiBalanceReportAsSpreadsheetHelper ishtml opts@ReportOpts{..} (PeriodicReport colspans items tr) =
-    (headers : concatMap fullRowAsTexts items,
+    (headers : concatMap fullRowAsTexts items, addTotalBorders totalrows)
-        map (map (\c -> c{Ods.cellStyle = Ods.Body Ods.Total})) totalrows)
   where
     cell = Ods.defaultCell
     headers =
-      map (\content -> (cell content) {Ods.cellStyle = Ods.Head}) $
+      map headerCell $
       "account" :
       case layout_ of
       LayoutTidy -> ["period", "start_date", "end_date", "commodity", "value"]
@@ -782,7 +806,8 @@ multiBalanceReportHtmlFootRow ropts isfirstline (hdr:cells) =
 -- | Render the ODS table rows for a MultiBalanceReport.
 -- Returns the heading row, 0 or more body rows, and the totals row if enabled.
 multiBalanceReportAsSpreadsheet ::
-  ReportOpts -> MultiBalanceReport -> ((Maybe Int, Maybe Int), [[Ods.Cell Text]])
+  ReportOpts -> MultiBalanceReport ->
+  ((Maybe Int, Maybe Int), [[Ods.Cell Ods.NumLines Text]])
 multiBalanceReportAsSpreadsheet ropts mbr =
   let (upper,lower) = multiBalanceReportAsSpreadsheetHelper True ropts mbr
   in  ((Just 1, case layout_ ropts of LayoutWide _ -> Just 1; _ -> Nothing),
@@ -885,7 +910,8 @@ multiBalanceRowAsTextBuilders bopts ropts colspans row =
     multiBalanceRowAsCellBuilders bopts ropts colspans row
 
 multiBalanceRowAsCellBuilders ::
-    AmountFormat -> ReportOpts -> [DateSpan] -> PeriodicReportRow a MixedAmount -> [[Ods.Cell WideBuilder]]
+    AmountFormat -> ReportOpts -> [DateSpan] ->
+    PeriodicReportRow a MixedAmount -> [[Ods.Cell Ods.NumLines WideBuilder]]
 multiBalanceRowAsCellBuilders bopts ReportOpts{..} colspans (PeriodicReportRow _ as rowtot rowavg) =
     case layout_ of
       LayoutWide width -> [fmap (cellFromMixedAmount bopts{displayMaxWidth=width}) allamts]
@@ -1192,14 +1218,15 @@ budgetReportAsCsv ropts report
   = map (map Ods.cellContent) $
     budgetReportAsSpreadsheet ropts report
 
-budgetReportAsSpreadsheet :: ReportOpts -> BudgetReport -> [[Ods.Cell Text]]
+budgetReportAsSpreadsheet ::
+  ReportOpts -> BudgetReport -> [[Ods.Cell Ods.NumLines Text]]
 budgetReportAsSpreadsheet
   ReportOpts{..}
   (PeriodicReport colspans items totrow)
   = (if transpose_ then transpose else id) $
 
   -- heading row
-  (map (\content -> (cell content) {Ods.cellStyle = Ods.Head}) $
+  (map headerCell $
   "Account" :
   ["Commodity" | layout_ == LayoutBare ]
    ++ concatMap (\spn -> [showDateSpan spn, "budget"]) colspans
@@ -1211,7 +1238,7 @@ budgetReportAsSpreadsheet
   concatMap (rowAsTexts prrFullName) items
 
   -- totals row
-  ++ map (map (\c -> c {Ods.cellStyle = Ods.Body Ods.Total}))
+  ++ addTotalBorders
         (concat [ rowAsTexts (const totalRowHeadingBudgetCsv) totrow | not no_total_ ])
 
   where
@@ -1221,7 +1248,7 @@ budgetReportAsSpreadsheet
 
     rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text)
                -> PeriodicReportRow a BudgetCell
-               -> [[Ods.Cell Text]]
+               -> [[Ods.Cell Ods.NumLines Text]]
     rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg))
       | layout_ /= LayoutBare = [cell (render row) : map showNorm vals]
       | otherwise =