{-# 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 :: forall border. Lines border => [[Cell border Html]] -> Html
printHtml [[Cell border Html]]
table = do
    [Attribute] -> Html
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
Html.link_ [Text -> Attribute
Html.rel_ Text
"stylesheet", Text -> Attribute
Html.href_ Text
"hledger.css"]
    Text -> Html
forall arg result. TermRaw arg result => arg -> result
Html.style_ Text
Attr.tableStylesheet
    Html -> Html
forall arg result. Term arg result => arg -> result
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
forall arg result. Term arg result => arg -> result
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 [Attribute] -> Html -> Html
forall arg result. Term arg result => arg -> result
Html.a_ [Text -> Attribute
Html.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
Html.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
Html.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
Html.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
Html.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
Html.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
HtmlBase.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
HtmlBase.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
Html.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
Html.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