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

module Hledger.Write.Html.Lucid (
    Html,
    L.toHtml,
    styledTableHtml,
    formatRow,
    formatCell,
    ) where

import           Data.Foldable (traverse_)
import qualified Data.Text as Text
import qualified Lucid.Base as L
import qualified Lucid as L

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


type Html = L.Html ()

-- | 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
    [Attribute] -> Html
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
L.link_ [Text -> Attribute
L.rel_ Text
"stylesheet", Text -> Attribute
L.href_ Text
"hledger.css"]
    Text -> Html
forall arg result. TermRaw arg result => arg -> result
L.style_ Text
Attr.tableStylesheet
    Html -> Html
forall arg result. Term arg result => arg -> result
L.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
forall arg result. Term arg result => arg -> result
L.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 [Attribute] -> Html -> Html
forall arg result. Term arg result => arg -> result
L.a_ [Text -> Attribute
L.href_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Cell border Html -> Text
forall border text. Cell border text -> Text
cellAnchor Cell border Html
cell] Html
str 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 -> [Text -> Attribute
forall arg result. TermRaw arg result => arg -> result
L.style_ (Text -> Attribute) -> Text -> Attribute
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 Text -> Attribute
L.class_ ([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_ :: ([Attribute] -> t -> f ()) -> [Attribute] -> t -> f ()
span_ [Attribute] -> t -> f ()
makeCell [Attribute]
attrs t
cont =
            case Cell border Html -> Span
forall border text. Cell border text -> Span
Spr.cellSpan Cell border Html
cell of
                Span
Spr.NoSpan -> [Attribute] -> t -> f ()
makeCell [Attribute]
attrs t
cont
                Span
Spr.Covered -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Spr.SpanHorizontal Int
n ->
                    [Attribute] -> t -> f ()
makeCell (Text -> Attribute
L.colspan_ (String -> Text
Text.pack (String -> Text) -> String -> Text
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) t
cont
                Spr.SpanVertical Int
n ->
                    [Attribute] -> t -> f ()
makeCell (Text -> Attribute
L.rowspan_ (String -> Text
Text.pack (String -> Text) -> String -> Text
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) t
cont
            in
    case Cell border Html -> Style
forall border text. Cell border text -> Style
cellStyle Cell border Html
cell of
        Style
Head -> ([Attribute] -> Html -> Html) -> [Attribute] -> Html -> Html
forall {f :: * -> *} {t}.
Applicative f =>
([Attribute] -> t -> f ()) -> [Attribute] -> t -> f ()
span_ [Attribute] -> Html -> Html
forall arg result. Term arg result => arg -> result
L.th_ ([Attribute]
style[Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++[Attribute]
class_) Html
content
        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
_ -> [Text -> Text -> Attribute
L.makeAttribute Text
"align" Text
"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 [Text -> Text -> Attribute
L.makeAttribute Text
"valign" Text
"top"]
                                else []
                        Span
_ -> []
                withEmph :: Html -> Html
withEmph =
                    case Emphasis
emph of
                        Emphasis
Item -> Html -> Html
forall a. a -> a
id
                        Emphasis
Total -> Html -> Html
forall arg result. Term arg result => arg -> result
L.b_
            in  ([Attribute] -> Html -> Html) -> [Attribute] -> Html -> Html
forall {f :: * -> *} {t}.
Applicative f =>
([Attribute] -> t -> f ()) -> [Attribute] -> t -> f ()
span_ [Attribute] -> Html -> Html
forall arg result. Term arg result => arg -> result
L.td_ ([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_) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                Html -> Html
withEmph Html
content