Main.hs

module Main (main) where

import Data.Text qualified as Text
import Data.Text.IO qualified as Text.IO
import System.Environment (getArgs)
import Text.Printf (printf)

import Demo qualified

import KB.Text.Layout.Break qualified as Break
import KB.Text.Layout.Html qualified as Html
import KB.Text.Layout.Measure (Span (..), Style)
import KB.Text.Layout.Measure qualified as Measure
import KB.Text.Shape qualified as TextShape

unit, maxBubble, containerW, pad, gap :: Float
unit = 11
maxBubble = 18
containerW = 26
pad = 9
gap = 10

data Side = Them | Us

main :: IO ()
main = do
  args <- getArgs
  let (bodyFile, emojiFile) = case args of
        a : b : _ -> (a, b)
        [a] -> (a, a)
        [] ->
          ( "assets/NotoSans-Regular.kbts.zst"
          , "assets/NotoColorEmoji.kbts.zst"
          )
  TextShape.withContext \shape -> do
    bodyFont <- Demo.pushFont shape bodyFile
    _emojiFont <- Demo.pushFont shape emojiFile
    ctx <- Measure.createLayoutContext shape
    body <- Measure.newStyle ctx bodyFont 1.0
    mark <- Measure.newStyle ctx bodyFont 1.0

    pill <- AtomSpan mark "v2.4" . (+ 0.6) <$> Measure.measure ctx mark "v2.4"
    prepped <- traverse (traverse (Measure.prepareStyled ctx)) (conversation body pill)

    let
      cssFont style = Demo.fontCss unit style ["Body", "Emoji"]
      styleCss k
        | k == mark.key = cssFont mark <> ";background:#fff3a8;border-radius:4px;text-align:center"
        | otherwise = cssFont body
      bubble (side, prep) =
        let
          w = Break.shrinkwrap prep maxBubble
          ranges = Break.layoutGreedy prep w
          opts = (Demo.options unit w body (cssFont body)){Html.styleCss = styleCss}
          h = Html.height opts (length ranges) + 2 * pad
          boxW = w * unit + 2 * pad
          (x, bg, fg) = case side of
            Them -> (0 :: Float, "#f0f0f3", "#1f2430")
            Us -> (containerW * unit - boxW, "#dceaff", "#103a75")
        in
          ( h
          , \y ->
              Demo.at
                x
                y
                ( ";width:"
                    <> Demo.px (boxW - 2 * pad)
                    <> ";height:"
                    <> Demo.px (h - 2 * pad)
                    <> ";padding:"
                    <> Demo.px pad
                    <> ";background:"
                    <> bg
                    <> ";color:"
                    <> fg
                    <> ";border-radius:12px"
                )
                (Html.render opts prep ranges)
          )
      stack y = \case
        [] -> ([], y - gap)
        (h, render) : rest ->
          let (divs, total) = stack (y + h + gap) rest
          in (render y : divs, total)
      (bubbleDivs, totalH) = stack 0 (map bubble prepped)
      fontFace = Demo.fontFaces [("Body", bodyFile), ("Emoji", emojiFile)]
      container = Demo.canvas (containerW * unit) totalH (Text.concat bubbleDivs)
    Text.IO.writeFile "bubbles.html" $
      Html.page "kb-text-layout bubbles" (fontFace <> container)
    printf "wrote bubbles.html (%d bubbles)\n" (length prepped)

conversation :: Style -> Span -> [(Side, [Span])]
conversation body pill =
  [ (Them, [t "Hey! Does the engine handle emoji families like \128104\8205\128105\8205\128103 yet?"])
  , (Us, [t "Yep. They measure as one cluster and never split across lines \128077"])
  , (Them, [t "And long words? Antidis\173establish\173ment\173arian\173ism used to blow up the bubbles."])
  , (Us, [t "Soft hy\173phens and grapheme emergency breaks both work, and non\160breaking\160spaces hold on."])
  , (Them, [t "Where does the font live? /usr/share/fonts/truetype/noto/NotoSans-Regular.ttf"])
  , (Us, [t "Shipping it in ", pill, t " \8212 bubbles shrinkwrap to their widest line, so short replies stay snug."])
  , (Them, [t "ok"])
  , (Us, [t "\127881"])
  ]
  where
    t = TextSpan body