ktx-font-0.2.0.0: test/Spec.hs

module Main where

import Control.Monad (unless)
import Data.Foldable (for_)
import Data.List (isSuffixOf)
import Data.Text qualified as Text
import Data.Traversable (for)
import Data.Vector.Storable qualified as Storable
import System.Directory (doesFileExist, listDirectory)
import System.FilePath ((</>))
import Test.Tasty (TestTree, defaultMain, testGroup, withResource)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))

import Codec.Ktx2.Font (Bundle(..))
import Codec.Ktx2.Font qualified as Font
import Codec.Ktx2.Font.Layout qualified as Layout
import Codec.Ktx2.Font.Shaping (Box(..), Compact(..), PlacedGlyph(..))
import Codec.Ktx2.Font.Shaping qualified as Shaping

{- | Font bundles built from @assets.yaml@.

Regenerate them with @stack exec ktx-build@ when the assets or the bundle format change.
-}
bundlesPath :: FilePath
bundlesPath = ".." </> "assets" </> "fonts"

main :: IO ()
main = do
  entries <- listDirectory bundlesPath
  let sources = [bundlesPath </> entry | entry <- entries, ".ktxf" `isSuffixOf` entry]
  unless (null sources) $
    putStrLn $ "Found " <> show (length sources) <> " bundles in " <> bundlesPath

  defaultMain $
    testGroup "ktx-font"
      [ testCase "bundles are built" $
          assertBool (bundlesPath <> " has no .ktxf bundles, run the ktx-build asset build") $
            not (null sources)

      , testGroup "bundles" $ map bundleTests sources

      , withStack sources \getStack ->
          testGroup "text"
            [ shapingTests (fmap fst getStack)
            , layoutTests getStack
            ]

      , testCase "demo bundles are built" $
          doesFileExist ligatureBundle >>=
            assertBool (ligatureBundle <> " is missing, run the ktx-build asset build")

      , withStack [ligatureBundle] ligatureTests
      ]

bundleTests :: FilePath -> TestTree
bundleTests source =
  withResource (Font.loadBundleFile source) Font.freeBundle \getBundle ->
    testGroup source
      [ testCase "carries an atlas" do
          Bundle{atlas} <- getBundle
          assertBool "no glyphs in the atlas" $
            not (Storable.null atlas.glyphs)
          Storable.length atlas.glyphs @?= Storable.length atlas.planes

      , testCase "atlas boxes are normalized to UV" do
          Bundle{atlas} <- getBundle
          Storable.forM_ atlas.glyphs \box ->
            assertBool ("glyph box outside the 0..1 UV range: " <> show box) $
              inUnitRange box
      ]
  where
    inUnitRange Box{x, y, w, h} =
      x >= 0 && y >= 0 && x + w <= 1.001 && y + h <= 1.001

{- | Load every bundle into a single shaping context, the way a renderer would.

The stack context doesn't keep the font memory alive, so the bundles have to outlive it.
-}
withStack :: [FilePath] -> (IO (Font.StackContext (), Layout.TextStyle) -> TestTree) -> TestTree
withStack sources withCtx =
  withResource acquire release $ withCtx . fmap snd
  where
    acquire = do
      bundles <- for sources Font.loadBundleFile
      ctx <- Font.createStackContext bundles
      style <- Layout.bundleStyle ctx (last bundles)
      pure (bundles, (ctx, style))

    release (bundles, (ctx, _style)) = do
      Font.destroyStackContext ctx
      for_ bundles Font.freeBundle

shapingTests :: IO (Font.StackContext ()) -> TestTree
shapingTests getCtx =
  testGroup "shaping"
    [ testCase "shapes the samples" do
        ctx <- getCtx
        for_ samples \sample -> do
          runs <- Shaping.shapeText (Shaping.initialCursorDown 2.0) ctx sample
          assertBool ("nothing shaped for " <> show sample) $
            not (null runs)
          assertBool ("no glyphs placed for " <> show sample) $
            not (null $ concatMap snd runs)

    , testCase "cursorDown advances the lines downwards" do
        ctx <- getCtx
        (top, bottom) <- twoLines (Shaping.initialCursorDown 2.0) ctx
        assertBool ("second line is not below the first: " <> show (top, bottom)) $
          bottom.plane.y < top.plane.y

    , testCase "cursorUp advances the lines upwards" do
        ctx <- getCtx
        (first_, second_) <- twoLines (Shaping.initialCursorUp 2.0) ctx
        assertBool ("second line is not above the first: " <> show (first_, second_)) $
          second_.plane.y > first_.plane.y

    , testCase "the newline advance matches the line height" do
        ctx <- getCtx
        (top, bottom) <- twoLines (Shaping.initialCursorDown 2.0) ctx
        -- Same glyph on both lines, so the planes differ by exactly one line.
        let gap = top.plane.y - bottom.plane.y
        assertBool ("unexpected line gap: " <> show gap) $
          abs (gap - 2.0) < 0.001
    ]
  where
    -- The same glyph on two lines, so the placements are comparable.
    -- The newline itself doesn't get placed.
    twoLines cur ctx = do
      runs <- Shaping.shapeText cur ctx "H\nH"
      case concatMap snd runs of
        [top, bottom] ->
          pure (top, bottom)
        placed ->
          assertFailure $ "expected two placed glyphs, got " <> show placed

    samples =
      [ "Test text, please shape."
      , "Multiple\nlines\nwith an empty one:\n\nand a tail."
      , "Punctuation: ,.!?;:'\"()[]{}"
      ]

layoutTests :: IO (Font.StackContext (), Layout.TextStyle) -> TestTree
layoutTests getStack =
  testGroup "layout"
    [ testCase "wide enough text stays on one line, matching plain shaping" do
        (ctx, style) <- getStack
        lns <- layout ctx style 1e6 "Sphinx of black quartz, judge my vow."
        map (.ended) lns @?= [Layout.Finished]
        shaped <- Shaping.shapeText cursor ctx "Sphinx of black quartz, judge my vow."
        planesOf (Layout.placedRuns lns) `closeTo` planesOf shaped

    , testCase "narrow text wraps under the maximum width" do
        (ctx, style) <- getStack
        lns <- layout ctx style 3.0 "one two three four five"
        assertBool "text did not wrap" $ length lns > 1
        for_ lns \line ->
          unless (line.ended == Layout.Overflowed) $
            assertBool ("line too wide: " <> show (line.text, line.width)) $
              line.width <= 3.001

    , testCase "hard breaks match the legacy newline behavior" do
        (ctx, style) <- getStack
        lns <- layout ctx style 1e6 "H\nH"
        map (.ended) lns @?= [Layout.HardBroken, Layout.Finished]
        case planesOf (Layout.placedRuns lns) of
          [top, bottom] ->
            assertBool ("unexpected line gap: " <> show (top, bottom)) $
              abs (top.y - bottom.y - 2.0) < 0.001
          planes ->
            assertFailure $ "expected two placed glyphs, got " <> show planes

    , testCase "hard breaks don't accumulate drift" do
        (ctx, style) <- getStack
        lns <- layout ctx style 1e6 "H\nH\nH\nH"
        let firsts = [p.x | line <- lns, p : _ <- [planesOf line.runs]]
        length firsts @?= 4
        assertBool ("line starts drift: " <> show firsts) $
          maximum firsts - minimum firsts < 0.001

    , testCase "empty lines are preserved" do
        (ctx, style) <- getStack
        lns <- layout ctx style 1e6 "a\n\nb"
        map (.ended) lns @?= [Layout.HardBroken, Layout.HardBroken, Layout.Finished]
        map (null . (.runs)) lns @?= [False, True, False]

    , testCase "right alignment pushes the origin to the edge" do
        (ctx, style) <- getStack
        lns <- Layout.layoutTextWith
          Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignRight}
          ctx style 10 "H"
        case lns of
          [line] -> do
            let (x0, _y0) = line.origin
            assertBool ("origin not at the right edge: " <> show (x0, line.width)) $
              abs (x0 - (10 - line.width)) < 0.001
          _ ->
            assertFailure $ "expected one line, got " <> show (length lns)

    , testCase "one shaping places at any width" do
        (ctx, style) <- getStack
        shaped <- Layout.shapeText ctx style "one two three four five"
        let
          place w = Layout.placeText Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignLeft} w shaped
          wide = place 1e6
          narrow = place 3.0
        length wide @?= 1
        assertBool "narrow placement did not wrap" $ length narrow > 1
        for_ (zip [0 :: Int ..] narrow) \(i, line) -> do
          let (x0, y0) = line.origin
          assertBool ("line " <> show i <> " is not on its own row: " <> show y0) $
            abs (y0 + fromIntegral i * 2.0) < 0.001
          plain <- Shaping.shapeText cursor{Shaping.curX = x0, Shaping.curY = y0} ctx line.text
          planesOf line.runs `closeTo` planesOf plain

    , testCase "soft hyphens break with a visible hyphen" do
        (ctx, style) <- getStack
        shaped <- Layout.shapeText ctx style "hyphen\173ation"
        w <- Layout.measureText ctx style "hyphenation"
        let
          lns = Layout.placeText Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignLeft} (w * 0.75) shaped
        map (.ended) lns @?= [Layout.Hyphenated, Layout.Finished]
        case lns of
          [top, bottom] -> do
            top.text @?= "hyphen-"
            bottom.text @?= "ation"
            let glyphs = concatMap snd top.runs
            assertBool "no glyphs on the hyphenated line" $ not (null glyphs)
            (last glyphs).codepoint @?= '-'
            assertBool ("hyphen not at the line end: " <> show (map (.plane) glyphs)) $
              (last glyphs).plane.x >= maximum (map (.plane.x) (init glyphs))
          _ ->
            assertFailure $ "expected two lines, got " <> show (length lns)

    , testCase "measuring and shrinkwrapping" do
        (ctx, style) <- getStack
        w <- Layout.measureText ctx style "H"
        assertBool ("H has no width: " <> show w) $ w > 0
        shrunk <- Layout.shrinkwrapText ctx style 3.0 "one two three four five"
        assertBool ("shrinkwrap exceeded the limit: " <> show shrunk) $ shrunk <= 3.001
    ]
  where
    layout = Layout.layoutText cursor

{- | Ligature tests need a font with real multi-codepoint glyphs.

MapleMono renders its coding ligatures as per-glyph contextual alternates,
so its glyphs never span codepoints. NotoSans has a proper @ffi@ ligature.
-}
ligatureBundle :: FilePath
ligatureBundle = ".." </> "assets" </> "demo" </> "NotoSans-Regular.ktxf"

ligatureTests :: IO (Font.StackContext (), Layout.TextStyle) -> TestTree
ligatureTests getStack =
  testGroup "ligatures"
    [ testCase "the bundle shapes the ligature as one glyph" do
        (ctx, style) <- getStack
        shaped <- Layout.shapeText ctx style ligature
        let whole = glyphsOf (place shaped 1e6)
        assertBool ("no ligature shaped for " <> show ligature <> ": " <> show (map (.codepoint) whole)) $
          length whole < Text.length ligature

    , testCase "emergency breaks keep the ligature whole" do
        (ctx, style) <- getStack
        shaped <- Layout.shapeText ctx style ligature
        w <- Layout.measureText ctx style ligature
        let whole = glyphsOf (place shaped 1e6)
        for_ [w / 2, w * 0.9] \width -> do
          let lns = place shaped width
          map (.text) lns @?= [ligature]
          map (.ended) lns @?= [Layout.Overflowed]
          map (.plane) (glyphsOf lns) `closeTo` map (.plane) whole

    , testCase "wrapping after the ligature keeps the following text" do
        (ctx, style) <- getStack
        shaped <- Layout.shapeText ctx style (ligature <> "ab")
        w <- max <$> Layout.measureText ctx style ligature <*> Layout.measureText ctx style "ab"
        let lns = place shaped w
        map (.text) lns @?= [ligature, "ab"]
        for_ lns \line -> do
          let (x0, y0) = line.origin
          plain <- Shaping.shapeText cursor{Shaping.curX = x0, Shaping.curY = y0} ctx line.text
          planesOf line.runs `closeTo` planesOf plain
    ]
  where
    ligature = "ffi"
    place shaped width = Layout.placeText Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignLeft} width shaped
    glyphsOf lns = concatMap snd (Layout.placedRuns lns)

cursor :: Shaping.Cursor
cursor = Shaping.initialCursorDown 2.0

planesOf :: [Shaping.PlacedRun] -> [Box]
planesOf runs = [g.plane | (_font, glyphs) <- runs, g <- glyphs]

closeTo :: [Box] -> [Box] -> IO ()
closeTo actual expected = do
  length actual @?= length expected
  for_ (zip actual expected) \(a, e) ->
    assertBool ("planes differ: " <> show (a, e)) $
      all (< 0.001) [abs (a.x - e.x), abs (a.y - e.y), abs (a.w - e.w), abs (a.h - e.h)]