refactor Hledger.Write.Html etc

hledger-lib/Hledger/Write/Html.hs

@@ -1,38 +1,41 @@
-{-# LANGUAGE OverloadedStrings #-}
 {- |
-Common definitions for Html.Blaze and Html.Lucid
+HTML writing helpers.
+This module would ideally hide the details of which HTML library is used, but it doesn't yet.
+
+Currently hledger-web uses blaze-html, but hledger CLI reports use lucid.
+lucid has a more usable API than blaze-html (https://chrisdone.com/posts/lucid).
+lucid2's is even better.
+Unfortunately lucid* can not render multi-line or indented text.
+We want this so that humans can read and troubleshoot our HTML output.
+So a transition to blaze-html may be coming.
+
 -}
-module Hledger.Write.Html (
-    Lines(..),
-    borderStyles,
-    ) where
 
-import qualified Hledger.Write.Spreadsheet as Spr
-import Hledger.Write.Spreadsheet (Cell(..))
+{-# LANGUAGE OverloadedStrings #-}
 
-import Data.Text (Text)
+module Hledger.Write.Html (
+  L.toHtml,
+  Html,
+  formatRow,
+  htmlAsText,
+  htmlAsLazyText,
+  styledTableHtml,
+  tests_Hledger_Write_Html
+  ) where
 
+import qualified Data.Text as T (Text)
+import qualified Data.Text.Lazy as TL (Text, toStrict)
+import qualified Lucid as L (renderText, toHtml)
+import Test.Tasty (testGroup)
 
-borderStyles :: Lines border => Cell border text -> [Text]
-borderStyles cell =
-    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
-    leftBorder++rightBorder++topBorder++bottomBorder
+import Hledger.Write.Html.Lucid (Html, formatRow, styledTableHtml)
 
 
-class (Spr.Lines border) => Lines border where
-    borderLines :: border -> [Text]
+htmlAsText :: Html -> T.Text
+htmlAsText = TL.toStrict . L.renderText
 
-instance Lines () where
-    borderLines () = []
+htmlAsLazyText :: Html -> TL.Text
+htmlAsLazyText = L.renderText
 
-instance Lines Spr.NumLines where
-    borderLines prop =
-        case prop of
-            Spr.NoLine -> []
-            Spr.SingleLine -> ["black"]
-            Spr.DoubleLine -> ["double black"]
+tests_Hledger_Write_Html = testGroup "Write.Html" [
+  ]

hledger-lib/Hledger/Write/Html/Blaze.hs

@@ -1,18 +1,17 @@
 {-# 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>
+HTML writing helpers using blaze-html.
 -}
+
 module Hledger.Write.Html.Blaze (
-    printHtml,
+    styledTableHtml,
     formatRow,
     formatCell,
     ) where
 
 import qualified Hledger.Write.Html.Attribute as Attr
 import qualified Hledger.Write.Spreadsheet as Spr
-import Hledger.Write.Html (Lines, borderStyles)
+import Hledger.Write.Html.HtmlCommon (Lines, borderStyles)
 import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
 
 import qualified Text.Blaze.Html4.Transitional.Attributes as HtmlAttr
@@ -22,8 +21,10 @@ import Text.Blaze.Html4.Transitional (Html, toHtml, (!))
 import Data.Foldable (traverse_)
 
 
-printHtml :: (Lines border) => [[Cell border Html]] -> Html
-printHtml table = do
+-- | 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>
+styledTableHtml :: (Lines border) => [[Cell border Html]] -> Html
+styledTableHtml table = do
     Html.style $ toHtml $ Attr.tableStylesheet
     Html.table $ traverse_ formatRow table
 

hledger-lib/Hledger/Write/Html/HtmlCommon.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+Common definitions used by both Html.Blaze and Html.Lucid.
+-}
+
+module Hledger.Write.Html.HtmlCommon (
+    Lines(..),
+    borderStyles,
+    ) where
+
+import Data.Text (Text)
+
+import           Hledger.Write.Spreadsheet (Cell(..))
+import qualified Hledger.Write.Spreadsheet as Spr
+
+
+borderStyles :: Lines border => Cell border text -> [Text]
+borderStyles cell =
+    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
+    leftBorder++rightBorder++topBorder++bottomBorder
+
+
+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/Html/Lucid.hs

@@ -1,78 +1,82 @@
 {-# 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>
+HTML writing helpers using lucid.
 -}
+
 module Hledger.Write.Html.Lucid (
-    printHtml,
+    Html,
+    L.toHtml,
+    styledTableHtml,
     formatRow,
     formatCell,
     ) where
 
+import           Data.Foldable (traverse_)
+import qualified Data.Text as Text
+import qualified Lucid.Base as L
+import qualified Lucid as L
+
 import qualified Hledger.Write.Html.Attribute as Attr
+import           Hledger.Write.Html.HtmlCommon
+import           Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
 import qualified Hledger.Write.Spreadsheet as Spr
-import Hledger.Write.Html (Lines, borderStyles)
-import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))
-
-import qualified Data.Text as Text
-import qualified Lucid.Base as HtmlBase
-import qualified Lucid as Html
-import Data.Foldable (traverse_)
 
 
-type Html = Html.Html ()
+type Html = L.Html ()
 
-printHtml :: (Lines border) => [[Cell border Html]] -> Html
-printHtml table = do
-    Html.link_ [Html.rel_ "stylesheet", Html.href_ "hledger.css"]
-    Html.style_ Attr.tableStylesheet
-    Html.table_ $ traverse_ formatRow table
+-- | 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>
+styledTableHtml :: (Lines border) => [[Cell border Html]] -> Html
+styledTableHtml table = do
+    L.link_ [L.rel_ "stylesheet", L.href_ "hledger.css"]
+    L.style_ Attr.tableStylesheet
+    L.table_ $ traverse_ formatRow table
 
 formatRow:: (Lines border) => [Cell border Html] -> Html
-formatRow = Html.tr_ . traverse_ formatCell
+formatRow = L.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_ [Html.href_ $ cellAnchor cell] str in
+                else L.a_ [L.href_ $ cellAnchor cell] str in
     let style =
             case borderStyles cell of
                 [] -> []
-                ss -> [Html.style_ $ Attr.concatStyles ss] in
+                ss -> [L.style_ $ Attr.concatStyles ss] in
     let class_ =
-            map Html.class_ $
+            map L.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
+                    makeCell (L.colspan_ (Text.pack $ show n) : attrs) cont
                 Spr.SpanVertical n ->
-                    makeCell (Html.rowspan_ (Text.pack $ show n) : attrs) cont
+                    makeCell (L.rowspan_ (Text.pack $ show n) : attrs) cont
             in
     case cellStyle cell of
-        Head -> span_ Html.th_ (style++class_) content
+        Head -> span_ L.th_ (style++class_) content
         Body emph ->
             let align =
                     case cellType cell of
                         TypeString -> []
                         TypeDate -> []
-                        _ -> [HtmlBase.makeAttribute "align" "right"]
+                        _ -> [L.makeAttribute "align" "right"]
                 valign =
                     case Spr.cellSpan cell of
                         Spr.SpanVertical n ->
                             if n>1
-                                then [HtmlBase.makeAttribute "valign" "top"]
+                                then [L.makeAttribute "valign" "top"]
                                 else []
                         _ -> []
                 withEmph =
                     case emph of
                         Item -> id
-                        Total -> Html.b_
-            in  span_ Html.td_ (style++align++valign++class_) $
+                        Total -> L.b_
+            in  span_ L.td_ (style++align++valign++class_) $
                 withEmph content
+

hledger-lib/hledger-lib.cabal

@@ -93,6 +93,7 @@ library
       Hledger.Write.Html.Attribute
       Hledger.Write.Html.Blaze
       Hledger.Write.Html.Lucid
+      Hledger.Write.Html.HtmlCommon
       Hledger.Write.Spreadsheet
       Hledger.Reports
       Hledger.Reports.ReportOptions

hledger-lib/package.yaml

@@ -162,6 +162,7 @@ library:
   - Hledger.Write.Html.Attribute
   - Hledger.Write.Html.Blaze
   - Hledger.Write.Html.Lucid
+  - Hledger.Write.Html.HtmlCommon
   - Hledger.Write.Spreadsheet
   - Hledger.Reports
   - Hledger.Reports.ReportOptions

hledger/Hledger/Cli/Commands/Aregister.hs

@@ -29,19 +29,18 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
 import Control.Monad (when)
-import Lucid (toHtml)
-import qualified Lucid as L
+import qualified Lucid as L hiding (Html)
 import System.Console.CmdArgs.Explicit (flagNone, flagReq)
+import qualified System.IO as IO
+import Text.Tabular.AsciiWide hiding (render)
 
 import Hledger
+import Hledger.Cli.CliOptions
+import Hledger.Cli.Utils
 import Hledger.Write.Csv (CSV, printCSV, printTSV)
+import Hledger.Write.Html (formatRow, htmlAsLazyText, toHtml)
 import Hledger.Write.Ods (printFods)
 import qualified Hledger.Write.Spreadsheet as Spr
-import qualified Hledger.Write.Html.Lucid as Html
-import Hledger.Cli.CliOptions
-import Hledger.Cli.Utils
-import Text.Tabular.AsciiWide hiding (render)
-import qualified System.IO as IO
 
 aregistermode = hledgerCommandMode
   $(embedFileRelative "Hledger/Cli/Commands/Aregister.txt")
@@ -176,7 +175,7 @@ accountTransactionsReportItemAsRecord
 -- | Render a register report as a HTML snippet.
 accountTransactionsReportAsHTML :: CliOpts -> Query -> Query -> AccountTransactionsReport -> TL.Text
 accountTransactionsReportAsHTML copts reportq thisacctq items =
-  L.renderText $ do
+  htmlAsLazyText $ do
     L.link_ [L.rel_ "stylesheet", L.href_ "hledger.css"]
     L.table_ $ do
       when (headingopt copts) $ L.thead_ $ L.tr_ $ do
@@ -186,7 +185,7 @@ accountTransactionsReportAsHTML copts reportq thisacctq items =
         L.th_ "change"
         L.th_ "balance"
       L.tbody_ $ for_ items $
-        Html.formatRow . map (fmap toHtml) .
+        formatRow . map (fmap toHtml) .
         accountTransactionsReportItemAsRecord
           oneLineNoCostFmt False
           (whichDate $ _rsReportOpts $ reportspec_ copts)

hledger/Hledger/Cli/Commands/Balance.hs

@@ -291,7 +291,6 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
 import Data.Time (addDays, fromGregorian)
 import System.Console.CmdArgs.Explicit as C (flagNone, flagReq, flagOpt)
-import Lucid as L hiding (value_)
 import Safe (headMay, maximumMay)
 import Text.Tabular.AsciiWide
     (Header(..), Align(..), Properties(..), Cell(..), Table(..), TableOpts(..),
@@ -305,7 +304,7 @@ import Hledger.Cli.Utils
 import Hledger.Cli.Anchor (setAccountAnchor, dateSpanCell, headerDateSpanCell)
 import Hledger.Write.Csv (CSV, printCSV, printTSV)
 import Hledger.Write.Ods (printFods)
-import Hledger.Write.Html.Lucid (printHtml)
+import Hledger.Write.Html (Html, styledTableHtml, htmlAsLazyText, toHtml)
 import Hledger.Write.Spreadsheet (rawTableContent, headerCell,
             addHeaderBorders, addRowSpanHeader,
             cellFromMixedAmount, cellsFromMixedAmount)
@@ -391,8 +390,8 @@ balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ ropts of
             "json" -> (<>"\n") . toJsonText
             "csv"  -> printCSV . budgetReportAsCsv ropts
             "tsv"  -> printTSV . budgetReportAsCsv ropts
-            "html" -> (<>"\n") . L.renderText .
-                      printHtml . map (map (fmap L.toHtml)) . budgetReportAsSpreadsheet ropts
+            "html" -> (<>"\n") . htmlAsLazyText .
+                      styledTableHtml . map (map (fmap toHtml)) . budgetReportAsSpreadsheet ropts
             "fods" -> printFods IO.localeEncoding .
                       Map.singleton "Budget Report" . (,) (1,0) . budgetReportAsSpreadsheet ropts
             _      -> error' $ unsupportedOutputFormatError fmt
@@ -404,7 +403,7 @@ balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ ropts of
               "txt"  -> multiBalanceReportAsText ropts
               "csv"  -> printCSV . multiBalanceReportAsCsv ropts
               "tsv"  -> printTSV . multiBalanceReportAsCsv ropts
-              "html" -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts
+              "html" -> (<>"\n") . htmlAsLazyText . multiBalanceReportAsHtml ropts
               "json" -> (<>"\n") . toJsonText
               "fods" -> printFods IO.localeEncoding .
                         Map.singleton "Multi-period Balance Report" . multiBalanceReportAsSpreadsheet ropts
@@ -417,8 +416,8 @@ balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ ropts of
               "txt"  -> TB.toLazyText . balanceReportAsText ropts
               "csv"  -> printCSV . balanceReportAsCsv ropts
               "tsv"  -> printTSV . balanceReportAsCsv ropts
-              "html" -> (<>"\n") . L.renderText .
-                                   printHtml . map (map (fmap L.toHtml)) . balanceReportAsSpreadsheet ropts
+              "html" -> (<>"\n") . htmlAsLazyText .
+                                   styledTableHtml . map (map (fmap toHtml)) . balanceReportAsSpreadsheet ropts
               "json" -> (<>"\n") . toJsonText
               "fods" -> printFods IO.localeEncoding . Map.singleton "Balance Report" . (,) (1,0) . balanceReportAsSpreadsheet ropts
               _      -> error' $ unsupportedOutputFormatError fmt  -- PARTIAL:
@@ -709,9 +708,9 @@ tidyColumnLabels =
 
 
 -- | Render a multi-column balance report as HTML.
-multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html ()
+multiBalanceReportAsHtml :: ReportOpts -> MultiBalanceReport -> Html
 multiBalanceReportAsHtml ropts mbr =
-  printHtml . map (map (fmap L.toHtml)) $
+  styledTableHtml . map (map (fmap toHtml)) $
     snd $ multiBalanceReportAsSpreadsheet ropts mbr
 
 -- | Render the ODS table rows for a MultiBalanceReport.

hledger/Hledger/Cli/Commands/Print.hs

@@ -37,7 +37,7 @@ import Hledger
 import Hledger.Write.Beancount (accountNameToBeancount, showTransactionBeancount, showBeancountMetadata)
 import Hledger.Write.Csv (CSV, printCSV, printTSV)
 import Hledger.Write.Ods (printFods)
-import Hledger.Write.Html.Lucid (printHtml)
+import Hledger.Write.Html.Lucid (styledTableHtml)
 import qualified Hledger.Write.Spreadsheet as Spr
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Utils
@@ -142,7 +142,7 @@ printEntries opts@CliOpts{rawopts_=rawopts, reportspec_=rspec} j =
            | fmt=="json"      = toJsonText                    . styleAmounts styles
            | fmt=="sql"       = entriesReportAsSql            . styleAmounts styles
            | fmt=="html" =
-                (<>"\n") . Lucid.renderText . printHtml .
+                (<>"\n") . Lucid.renderText . styledTableHtml .
                 map (map (fmap Lucid.toHtml)) .
                 entriesReportAsSpreadsheet oneLineNoCostFmt baseUrl query .
                 styleAmounts styles