slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
Write.Html: keep common definitions for both HTML backends
This commit is contained in:
Henning Thielemann 2024-09-29 20:13:23 +02:00 committed by Simon Michael
parent cc7e034d64
commit 2f9a8031b0
7 changed files with 77 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
hledger-lib/Hledger/Write/Html.hs
View File

@ -1,67 +1,27 @@
{-# 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>
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

24
hledger-lib/Hledger/Write/Html/Blaze.hs
View File

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

60
hledger-lib/Hledger/Write/Html/Lucid.hs Normal file
View File

@ -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

3
hledger-lib/hledger-lib.cabal
View File

@ -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:

5
hledger-lib/package.yaml
View File

@ -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

4
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -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

2
hledger/Hledger/Cli/CompoundBalanceCommand.hs
View File

@ -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)