From 2f9a8031b0fd3135042d48f8622038911a200221 Mon Sep 17 00:00:00 2001 From: Henning Thielemann Date: Sun, 29 Sep 2024 20:13:23 +0200 Subject: [PATCH] lib: Write.Html -> Write.Html.Lucid Write.Html: keep common definitions for both HTML backends --- hledger-lib/Hledger/Write/Html.hs | 54 +++-------------- hledger-lib/Hledger/Write/Html/Blaze.hs | 24 +------- hledger-lib/Hledger/Write/Html/Lucid.hs | 60 +++++++++++++++++++ hledger-lib/hledger-lib.cabal | 3 +- hledger-lib/package.yaml | 5 +- hledger/Hledger/Cli/Commands/Balance.hs | 4 +- hledger/Hledger/Cli/CompoundBalanceCommand.hs | 2 +- 7 files changed, 77 insertions(+), 75 deletions(-) create mode 100644 hledger-lib/Hledger/Write/Html/Lucid.hs diff --git a/hledger-lib/Hledger/Write/Html.hs b/hledger-lib/Hledger/Write/Html.hs index 2a3b0533b..0bb4a7249 100644 --- a/hledger-lib/Hledger/Write/Html.hs +++ b/hledger-lib/Hledger/Write/Html.hs @@ -1,67 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} {- | -Export spreadsheet table data as HTML table. - -This is derived from +Common definitions for Html.Blaze and Html.Lucid -} module Hledger.Write.Html ( - printHtml, - formatRow, - formatCell, + Lines(..), + borderStyles, ) 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 Hledger.Write.Spreadsheet (Cell(..)) -import qualified Data.Text as Text -import qualified Lucid.Base as LucidBase -import qualified Lucid import Data.Text (Text) -import Data.Foldable (traverse_) -printHtml :: (Lines border) => [[Cell border (Lucid.Html ())]] -> Lucid.Html () -printHtml table = do - Lucid.style_ Attr.tableStylesheet - Lucid.table_ $ traverse_ formatRow table - -formatRow:: (Lines border) => [Cell border (Lucid.Html ())] -> Lucid.Html () -formatRow = Lucid.tr_ . traverse_ formatCell - -formatCell :: (Lines border) => Cell border (Lucid.Html ()) -> Lucid.Html () -formatCell cell = - let str = cellContent cell in - let content = - if Text.null $ cellAnchor cell - then str - else Lucid.a_ [Lucid.href_ $ cellAnchor cell] str in +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 - let style = - case leftBorder++rightBorder++topBorder++bottomBorder of - [] -> [] - ss -> [Lucid.style_ $ Attr.concatStyles ss] in - let class_ = - map Lucid.class_ $ - filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in - case cellStyle cell of - Head -> Lucid.th_ (style++class_) content - Body emph -> - let align = - case cellType cell of - TypeString -> [] - TypeDate -> [] - _ -> [LucidBase.makeAttribute "align" "right"] - withEmph = - case emph of - Item -> id - Total -> Lucid.b_ - in Lucid.td_ (style++align++class_) $ withEmph content + leftBorder++rightBorder++topBorder++bottomBorder class (Spr.Lines border) => Lines border where diff --git a/hledger-lib/Hledger/Write/Html/Blaze.hs b/hledger-lib/Hledger/Write/Html/Blaze.hs index c1ae23121..4a99f5f5e 100644 --- a/hledger-lib/Hledger/Write/Html/Blaze.hs +++ b/hledger-lib/Hledger/Write/Html/Blaze.hs @@ -12,13 +12,13 @@ module Hledger.Write.Html.Blaze ( import qualified Hledger.Write.Html.Attribute as Attr import qualified Hledger.Write.Spreadsheet as Spr +import Hledger.Write.Html (Lines, borderStyles) 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_) @@ -38,14 +38,8 @@ formatCell 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 + case borderStyles cell of [] -> [] ss -> [HtmlAttr.style $ Html.textValue $ Attr.concatStyles ss] in @@ -67,17 +61,3 @@ formatCell cell = 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/Write/Html/Lucid.hs b/hledger-lib/Hledger/Write/Html/Lucid.hs new file mode 100644 index 000000000..d4bdea8ac --- /dev/null +++ b/hledger-lib/Hledger/Write/Html/Lucid.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | +Export spreadsheet table data as HTML table. + +This is derived from +-} +module Hledger.Write.Html.Lucid ( + printHtml, + 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.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 () + +printHtml :: (Lines border) => [[Cell border Html]] -> Html +printHtml table = do + Html.style_ 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_ [Html.href_ $ cellAnchor cell] str in + let style = + case borderStyles cell of + [] -> [] + ss -> [Html.style_ $ Attr.concatStyles ss] in + let class_ = + map Html.class_ $ + filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in + case cellStyle cell of + Head -> Html.th_ (style++class_) content + Body emph -> + let align = + case cellType cell of + TypeString -> [] + TypeDate -> [] + _ -> [HtmlBase.makeAttribute "align" "right"] + withEmph = + case emph of + Item -> id + Total -> Html.b_ + in Html.td_ (style++align++class_) $ withEmph content diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 786aaf7c4..1092b960d 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -87,9 +87,9 @@ library Hledger.Read.TimeclockReader Hledger.Write.Csv Hledger.Write.Ods - Hledger.Write.Html Hledger.Write.Html.Attribute Hledger.Write.Html.Blaze + Hledger.Write.Html.Lucid Hledger.Write.Spreadsheet Hledger.Reports Hledger.Reports.ReportOptions @@ -110,6 +110,7 @@ library Hledger.Utils.Text Text.Tabular.AsciiWide other-modules: + Hledger.Write.Html Text.WideString Paths_hledger_lib hs-source-dirs: diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 7b0561074..dd56c63dd 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -151,9 +151,9 @@ library: - Hledger.Read.TimeclockReader - Hledger.Write.Csv - Hledger.Write.Ods - - Hledger.Write.Html - Hledger.Write.Html.Attribute - Hledger.Write.Html.Blaze + - Hledger.Write.Html.Lucid - Hledger.Write.Spreadsheet - Hledger.Reports - Hledger.Reports.ReportOptions @@ -173,7 +173,8 @@ library: - Hledger.Utils.Test - Hledger.Utils.Text - Text.Tabular.AsciiWide -# other-modules: + other-modules: + - Hledger.Write.Html # - Ledger.Parser.Text # "cabal test hledger-lib" currently fails, see doctest suite below diff --git a/hledger/Hledger/Cli/Commands/Balance.hs b/hledger/Hledger/Cli/Commands/Balance.hs index 16f561ff2..6ce211879 100644 --- a/hledger/Hledger/Cli/Commands/Balance.hs +++ b/hledger/Hledger/Cli/Commands/Balance.hs @@ -297,9 +297,9 @@ import Hledger.Cli.CliOptions import Hledger.Cli.Utils import Hledger.Write.Csv (CSV, printCSV, printTSV) import Hledger.Write.Ods (printFods) -import Hledger.Write.Html (printHtml) +import Hledger.Write.Html.Lucid (printHtml) import Hledger.Write.Html.Attribute (tableStylesheet) -import qualified Hledger.Write.Html as Html +import qualified Hledger.Write.Html.Lucid as Html import qualified Hledger.Write.Spreadsheet as Ods diff --git a/hledger/Hledger/Cli/CompoundBalanceCommand.hs b/hledger/Hledger/Cli/CompoundBalanceCommand.hs index 98e74ced8..5f42f87a0 100644 --- a/hledger/Hledger/Cli/CompoundBalanceCommand.hs +++ b/hledger/Hledger/Cli/CompoundBalanceCommand.hs @@ -23,7 +23,7 @@ import Data.Time.Calendar (Day, addDays) import System.Console.CmdArgs.Explicit as C (Mode, flagNone, flagReq) import Hledger.Write.Csv (CSV, printCSV, printTSV) import Hledger.Write.Html.Attribute (stylesheet, tableStyle, alignleft, alignright) -import qualified Hledger.Write.Html as Html +import qualified Hledger.Write.Html.Lucid as Html import qualified Hledger.Write.Spreadsheet as Spr import Lucid as L hiding (value_) import Safe (tailDef)