From cc7e034d642b924adbee3899220bba4e370f5434 Mon Sep 17 00:00:00 2001
From: Henning Thielemann <git@henning-thielemann.de>
Date: Sun, 29 Sep 2024 19:12:28 +0200
Subject: [PATCH] lib: Write.Html.Blaze: alternative to Lucid based export

for compatibility with hledger-web/yesod
---
 hledger-lib/Hledger/Write/Html/Blaze.hs | 83 +++++++++++++++++++++++++
 hledger-lib/hledger-lib.cabal           |  2 +
 hledger-lib/package.yaml                |  1 +
 3 files changed, 86 insertions(+)
 create mode 100644 hledger-lib/Hledger/Write/Html/Blaze.hs

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 <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>
+-}
+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