Blaze.hs

{-# 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 table = do
    Html.style $ toHtml $ 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 str !
                        HtmlAttr.href (Html.textValue (cellAnchor cell)) in
    let style =
            case borderStyles cell of
                [] -> []
                ss -> [HtmlAttr.style $ Html.textValue $
                        Attr.concatStyles ss] in
    let class_ =
            map (HtmlAttr.class_ . Html.textValue) $
            filter (not . Text.null) [Spr.textFromClass $ cellClass cell] in
    let span_ makeCell attrs =
            case Spr.cellSpan cell of
                Spr.NoSpan -> foldl (!) makeCell attrs
                Spr.Covered -> pure ()
                Spr.SpanHorizontal n ->
                    foldl (!) makeCell
                        (HtmlAttr.colspan (Html.stringValue $ show n) : attrs)
                Spr.SpanVertical n ->
                    foldl (!) makeCell
                        (HtmlAttr.rowspan (Html.stringValue $ show n) : attrs)
            in
    case cellStyle cell of
        Head -> span_ (Html.th content) (style++class_)
        Body emph ->
            let align =
                    case cellType cell of
                        TypeString -> []
                        TypeDate -> []
                        _ -> [HtmlAttr.align "right"]
                valign =
                    case Spr.cellSpan cell of
                        Spr.SpanVertical n ->
                            if n>1 then [HtmlAttr.valign "top"] else []
                        _ -> []
                withEmph =
                    case emph of
                        Item -> id
                        Total -> Html.b
            in  span_ (Html.td $ withEmph content) $
                style++align++valign++class_