diff --git a/hledger-lib/Hledger/Write/Html/Blaze.hs b/hledger-lib/Hledger/Write/Html/Blaze.hs
new file mode 100644
index 000000000..c1ae23121
--- /dev/null
+++ b/hledger-lib/Hledger/Write/Html/Blaze.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+Export spreadsheet table data as HTML table.
+
+This is derived from
+-}
+module Hledger.Write.Html.Blaze (
+ printHtml,
+ formatRow,
+ formatCell,
+ ) where
+
+import qualified Hledger.Write.Html.Attribute as Attr
+import qualified Hledger.Write.Spreadsheet as Spr
+import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
+
+import qualified Text.Blaze.Html4.Transitional.Attributes as HtmlAttr
+import qualified Text.Blaze.Html4.Transitional as Html
+import qualified Data.Text as Text
+import Text.Blaze.Html4.Transitional (Html, toHtml, (!))
+import Data.Text (Text)
+import Data.Foldable (traverse_)
+
+
+printHtml :: (Lines border) => [[Cell border Html]] -> Html
+printHtml table = do
+ Html.style $ toHtml $ Attr.tableStylesheet
+ Html.table $ traverse_ formatRow table
+
+formatRow:: (Lines border) => [Cell border Html] -> Html
+formatRow = Html.tr . traverse_ formatCell
+
+formatCell :: (Lines border) => Cell border Html -> Html
+formatCell cell =
+ let str = cellContent cell in
+ let content =
+ if Text.null $ cellAnchor cell
+ then str
+ else Html.a str !
+ HtmlAttr.href (Html.textValue (cellAnchor 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 -> [HtmlAttr.style $ Html.textValue $
+ Attr.concatStyles ss] in
+ let class_ =
+ map (HtmlAttr.class_ . Html.textValue) $
+ filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in
+ case cellStyle cell of
+ Head -> foldl (!) (Html.th content) (style++class_)
+ Body emph ->
+ let align =
+ case cellType cell of
+ TypeString -> []
+ TypeDate -> []
+ _ -> [HtmlAttr.align "right"]
+ valign = [HtmlAttr.valign "top"]
+ withEmph =
+ case emph of
+ Item -> id
+ Total -> Html.b
+ in foldl (!) (Html.td $ withEmph content)
+ (style++align++valign++class_)
+
+
+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"]
diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal
index fc19b9c33..786aaf7c4 100644
--- a/hledger-lib/hledger-lib.cabal
+++ b/hledger-lib/hledger-lib.cabal
@@ -89,6 +89,7 @@ library
Hledger.Write.Ods
Hledger.Write.Html
Hledger.Write.Html.Attribute
+ Hledger.Write.Html.Blaze
Hledger.Write.Spreadsheet
Hledger.Reports
Hledger.Reports.ReportOptions
@@ -123,6 +124,7 @@ library
, array
, base >=4.14 && <4.20
, base-compat
+ , blaze-html >0.8
, blaze-markup >=0.5.1
, bytestring
, call-stack
diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml
index 02dab9b4d..7b0561074 100644
--- a/hledger-lib/package.yaml
+++ b/hledger-lib/package.yaml
@@ -153,6 +153,7 @@ library:
- Hledger.Write.Ods
- Hledger.Write.Html
- Hledger.Write.Html.Attribute
+ - Hledger.Write.Html.Blaze
- Hledger.Write.Spreadsheet
- Hledger.Reports
- Hledger.Reports.ReportOptions