lib: Write.Html -> Write.Html.Lucid

Write.Html: keep common definitions for both HTML backends

hledger-lib/Hledger/Write/Html.hs

@@ -1,67 +1,27 @@
 {-# LANGUAGE OverloadedStrings #-}
 {- |
-Export spreadsheet table data as HTML table.
+Common definitions for Html.Blaze and Html.Lucid
-
-This is derived from <https://hackage.haskell.org/package/classify-frog-0.2.4.3/src/src/Spreadsheet/Format.hs>
 -}
 module Hledger.Write.Html (
-    printHtml,
+    Lines(..),
-    formatRow,
+    borderStyles,
-    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 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 ()
+borderStyles :: Lines border => Cell border text -> [Text]
-printHtml table = do
+borderStyles cell =
-    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
     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 =
+    leftBorder++rightBorder++topBorder++bottomBorder
-            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
 
 
 class (Spr.Lines border) => Lines border where

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"]

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

@@ -0,0 +1,60 @@
+{-# 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.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

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:

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

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
 
 

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)