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

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

import qualified Hledger.Write.Html.Attribute as Attr
import qualified Hledger.Write.Spreadsheet as Spr
import Hledger.Write.Html.HtmlCommon (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.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_