    {-# LANGUAGE OverloadedStrings #-}
    {- |
    HTML writing helpers using blaze-html.
    -}

    module Hledger.Write.Html.Blaze (
        styledTableHtml,
        formatRow,
        formatCell,
        ) where

    import Hledger.Write.Html.Attribute qualified as Attr
    import Hledger.Write.Spreadsheet qualified as Spr
    import Hledger.Write.Html.HtmlCommon (Lines, borderStyles)
    import Hledger.Write.Spreadsheet (Type(..), Style(..), Emphasis(..), Cell(..))

    import Text.Blaze.Html4.Transitional.Attributes qualified as HtmlAttr
    import Text.Blaze.Html4.Transitional qualified as Html
    import Data.Text qualified as Text
    import Text.Blaze.Html4.Transitional (Html, toHtml, (!))
    import Data.Foldable (traverse_)

    -- | 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 :: forall border. Lines border => [[Cell border Html]] -> Html
    styledTableHtml [[Cell border Html]]
    table = do
        Html -> Html
    Html.style (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ Text -> Html
    forall a. ToMarkup a => a -> Html
    toHtml (Text -> Html) -> Text -> Html
    forall a b. (a -> b) -> a -> b
    $ Text
    Attr.tableStylesheet
        Html -> Html
    Html.table (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ ([Cell border Html] -> Html) -> [[Cell border Html]] -> Html
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    (a -> f b) -> t a -> f ()
    traverse_ [Cell border Html] -> Html
    forall border. Lines border => [Cell border Html] -> Html
    formatRow [[Cell border Html]]
    table

    formatRow:: (Lines border) => [Cell border Html] -> Html
    formatRow :: forall border. Lines border => [Cell border Html] -> Html
    formatRow = Html -> Html
    Html.tr (Html -> Html)
    -> ([Cell border Html] -> Html) -> [Cell border Html] -> Html
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Cell border Html -> Html) -> [Cell border Html] -> Html
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    (a -> f b) -> t a -> f ()
    traverse_ Cell border Html -> Html
    forall border. Lines border => Cell border Html -> Html
    formatCell

    formatCell :: (Lines border) => Cell border Html -> Html
    formatCell :: forall border. Lines border => Cell border Html -> Html
    formatCell Cell border Html
    cell =
        let str :: Html
    str = Cell border Html -> Html
    forall border text. Cell border text -> text
    cellContent Cell border Html
    cell in
        let content :: Html
    content =
                if Text -> Bool
    Text.null (Text -> Bool) -> Text -> Bool
    forall a b. (a -> b) -> a -> b
    $ Cell border Html -> Text
    forall border text. Cell border text -> Text
    cellAnchor Cell border Html
    cell
                    then Html
    str
                    else Html -> Html
    Html.a Html
    str Html -> Attribute -> Html
    forall h. Attributable h => h -> Attribute -> h
    !
                            AttributeValue -> Attribute
    HtmlAttr.href (Text -> AttributeValue
    Html.textValue (Cell border Html -> Text
    forall border text. Cell border text -> Text
    cellAnchor Cell border Html
    cell)) in
        let style :: [Attribute]
    style =
                case Cell border Html -> [Text]
    forall border text. Lines border => Cell border text -> [Text]
    borderStyles Cell border Html
    cell of
                    [] -> []
                    [Text]
    ss -> [AttributeValue -> Attribute
    HtmlAttr.style (AttributeValue -> Attribute) -> AttributeValue -> Attribute
    forall a b. (a -> b) -> a -> b
    $ Text -> AttributeValue
    Html.textValue (Text -> AttributeValue) -> Text -> AttributeValue
    forall a b. (a -> b) -> a -> b
    $
                            [Text] -> Text
    Attr.concatStyles [Text]
    ss] in
        let class_ :: [Attribute]
    class_ =
                (Text -> Attribute) -> [Text] -> [Attribute]
    forall a b. (a -> b) -> [a] -> [b]
    map (AttributeValue -> Attribute
    HtmlAttr.class_ (AttributeValue -> Attribute)
    -> (Text -> AttributeValue) -> Text -> Attribute
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> AttributeValue
    Html.textValue) ([Text] -> [Attribute]) -> [Text] -> [Attribute]
    forall a b. (a -> b) -> a -> b
    $
                (Text -> Bool) -> [Text] -> [Text]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Bool
    Text.null) [Class -> Text
    Spr.textFromClass (Class -> Text) -> Class -> Text
    forall a b. (a -> b) -> a -> b
    $ Cell border Html -> Class
    forall border text. Cell border text -> Class
    cellClass Cell border Html
    cell] in
        let span_ :: f () -> [Attribute] -> f ()
    span_ f ()
    makeCell [Attribute]
    attrs =
                case Cell border Html -> Span
    forall border text. Cell border text -> Span
    Spr.cellSpan Cell border Html
    cell of
                    Span
    Spr.NoSpan -> (f () -> Attribute -> f ()) -> f () -> [Attribute] -> f ()
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl f () -> Attribute -> f ()
    forall h. Attributable h => h -> Attribute -> h
    (!) f ()
    makeCell [Attribute]
    attrs
                    Span
    Spr.Covered -> () -> f ()
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
                    Spr.SpanHorizontal Int
    n ->
                        (f () -> Attribute -> f ()) -> f () -> [Attribute] -> f ()
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl f () -> Attribute -> f ()
    forall h. Attributable h => h -> Attribute -> h
    (!) f ()
    makeCell
                            (AttributeValue -> Attribute
    HtmlAttr.colspan (String -> AttributeValue
    Html.stringValue (String -> AttributeValue) -> String -> AttributeValue
    forall a b. (a -> b) -> a -> b
    $ Int -> String
    forall a. Show a => a -> String
    show Int
    n) Attribute -> [Attribute] -> [Attribute]
    forall a. a -> [a] -> [a]
    : [Attribute]
    attrs)
                    Spr.SpanVertical Int
    n ->
                        (f () -> Attribute -> f ()) -> f () -> [Attribute] -> f ()
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl f () -> Attribute -> f ()
    forall h. Attributable h => h -> Attribute -> h
    (!) f ()
    makeCell
                            (AttributeValue -> Attribute
    HtmlAttr.rowspan (String -> AttributeValue
    Html.stringValue (String -> AttributeValue) -> String -> AttributeValue
    forall a b. (a -> b) -> a -> b
    $ Int -> String
    forall a. Show a => a -> String
    show Int
    n) Attribute -> [Attribute] -> [Attribute]
    forall a. a -> [a] -> [a]
    : [Attribute]
    attrs)
                in
        case Cell border Html -> Style
    forall border text. Cell border text -> Style
    cellStyle Cell border Html
    cell of
            Style
    Head -> Html -> [Attribute] -> Html
    forall {f :: * -> *}.
    (Attributable (f ()), Applicative f) =>
    f () -> [Attribute] -> f ()
    span_ (Html -> Html
    Html.th Html
    content) ([Attribute]
    style[Attribute] -> [Attribute] -> [Attribute]
    forall a. [a] -> [a] -> [a]
    ++[Attribute]
    class_)
            Body Emphasis
    emph ->
                let align :: [Attribute]
    align =
                        case Cell border Html -> Type
    forall border text. Cell border text -> Type
    cellType Cell border Html
    cell of
                            Type
    TypeString -> []
                            Type
    TypeDate -> []
                            Type
    _ -> [AttributeValue -> Attribute
    HtmlAttr.align AttributeValue
    "right"]
                    valign :: [Attribute]
    valign =
                        case Cell border Html -> Span
    forall border text. Cell border text -> Span
    Spr.cellSpan Cell border Html
    cell of
                            Spr.SpanVertical Int
    n ->
                                if Int
    nInt -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >Int
    1 then [AttributeValue -> Attribute
    HtmlAttr.valign AttributeValue
    "top"] else []
                            Span
    _ -> []
                    withEmph :: Html -> Html
    withEmph =
                        case Emphasis
    emph of
                            Emphasis
    Item -> Html -> Html
    forall a. a -> a
    id
                            Emphasis
    Total -> Html -> Html
    Html.b
                in  Html -> [Attribute] -> Html
    forall {f :: * -> *}.
    (Attributable (f ()), Applicative f) =>
    f () -> [Attribute] -> f ()
    span_ (Html -> Html
    Html.td (Html -> Html) -> Html -> Html
    forall a b. (a -> b) -> a -> b
    $ Html -> Html
    withEmph Html
    content) ([Attribute] -> Html) -> [Attribute] -> Html
    forall a b. (a -> b) -> a -> b
    $
                    [Attribute]
    style[Attribute] -> [Attribute] -> [Attribute]
    forall a. [a] -> [a] -> [a]
    ++[Attribute]
    align[Attribute] -> [Attribute] -> [Attribute]
    forall a. [a] -> [a] -> [a]
    ++[Attribute]
    valign[Attribute] -> [Attribute] -> [Attribute]
    forall a. [a] -> [a] -> [a]
    ++[Attribute]
    class_