Html.hs

module KB.Text.Layout.Html
  ( -- * Rendering laid-out lines
    render
  , Options (..)
  , height

    -- * Page scaffolding
  , page
  , escape
  ) where

import Data.Text (Text)
import Data.Text qualified as Text
import Text.Printf (printf)

import KB.Text.Layout.Break (LineEnd (..), LineRange (..), LineSlice (..), materializeSlices)
import KB.Text.Layout.Measure (PreparedText)

render :: Options -> PreparedText -> [LineRange] -> Text
render opts prepared ranges =
  Text.concat $
    concat
      [
        [ "<div style=\"position:relative;width:" <> px opts.width
        , ";height:" <> pxAbs (height opts (length ranges))
        , "\">"
        ]
      , zipWith renderLine [0 :: Int ..] ranges
      , ["</div>"]
      ]
  where
    px v = pxAbs (v * opts.unit)
    renderLine i range =
      Text.concat $
        concat
          [
            [ "<div style=\"position:absolute;left:0;top:" <> px (fromIntegral i * opts.lineHeight)
            , ";text-box-trim:trim-both;text-box-edge:cap alphabetic"
            , ";white-space:pre" <> spacing <> ";" <> escape opts.baseCss <> "\">"
            ]
          , map renderSlice slices
          , ["</div>"]
          ]
      where
        slices = materializeSlices prepared range
        separators = sum [Text.count " " s.text + Text.count "\xA0" s.text | s <- slices, not s.atom]
        slack = opts.width - range.width
        spacing
          | opts.justify
          , range.ended /= HardBroken
          , range.ended /= Finished
          , abs slack > 1e-4
          , separators > 0 =
              ";word-spacing:" <> pxAbs (slack * opts.unit / fromIntegral separators)
          | otherwise = ""
    renderSlice slice =
      Text.concat
        [ "<span style=\""
        , if slice.atom then "display:inline-block;width:" <> px slice.width <> ";word-spacing:normal;" else ""
        , escape (opts.styleCss slice.style)
        , "\">"
        , escape slice.text
        , "</span>"
        ]

data Options = Options
  { width :: Float
  , lineHeight :: Float
  , unit :: Float
  , baseCap :: Float
  , justify :: Bool
  , baseCss :: Text
  , styleCss :: Int -> Text
  }

height :: Options -> Int -> Float
height opts lineCount
  | lineCount <= 0 = 0
  | otherwise = (fromIntegral (lineCount - 1) * opts.lineHeight + opts.baseCap) * opts.unit

pxAbs :: Float -> Text
pxAbs v = Text.pack (printf "%.2fpx" v)

page :: Text -> Text -> Text
page title body =
  Text.concat
    [ "<!doctype html><html><head><meta charset=\"utf-8\"><title>"
    , escape title
    , "</title></head><body>"
    , body
    , "</body></html>"
    ]

escape :: Text -> Text
escape = Text.concatMap \case
  '&' -> "&amp;"
  '<' -> "&lt;"
  '>' -> "&gt;"
  '"' -> "&quot;"
  c -> Text.singleton c