kb-text-shape-0.1.0.0: bench/Bench.hs

{-# LANGUAGE OverloadedRecordDot #-}

import Control.Monad
import Data.Char
import Foreign
import Prelude hiding (id)

import UnliftIO.Async (pooledForConcurrently_)
import Control.Exception (bracket)
import Data.ByteString qualified as ByteString
import Data.Text (Text)
import Data.Text qualified as Text

import KB.Text.Shape.FFI.API.Direct qualified as ShapeDirect
import KB.Text.Shape.FFI.Allocator (Allocator)
import KB.Text.Shape.FFI.Allocator qualified as Allocator
import KB.Text.Shape.FFI.Enums qualified as Enums
import KB.Text.Shape.FFI.Handles qualified as Handles
import KB.Text.Shape.FFI.Iterators qualified as Iterators
import KB.Text.Shape.FFI.Structs qualified as Structs

import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.Font qualified as TextShape

testFontTtf :: FilePath
testFontTtf = "test/Ubuntu-R.ttf"

testFontBlob :: FilePath
testFontBlob = "test/Ubuntu-R.blob"

testText :: Text
testText = "Hello, ሰላም።, שלמלך, नमस्ते world!"

testCodepoints :: [Char]
testCodepoints = Text.unpack testText

main :: IO ()
main = do
  mainBurnContext
  mainBurnDirect

mainBurnContext :: IO ()
mainBurnContext = do
  pooledForConcurrently_ [0..100] $ \t -> TextShape.withContext \ctx -> do
    putStrLn $ "Batch " <> show t <> " starting"
    _font <- TextShape.pushFontFromFile ctx testFontBlob 0
    forM_ [0 :: Int .. 10000] \ix -> do
      !_ <- length . show <$> TextShape.run ctx (TextShape.text_ testText)
      pure ()

mainBurnDirect :: IO ()
mainBurnDirect = do
  fontData <- ByteString.readFile testFontBlob
  font <- TextShape.createFont fontData 0
  pooledForConcurrently_ [0 :: Int .. 100000] \ix -> do
    !_ <- length . show <$> oneshot font 42 testCodepoints
    pure ()
  TextShape.destroyFont font
  fontData `seq`pure ()

oneshot :: TextShape.FontData -> Int -> [Char] -> IO [TextShape.Glyph]
oneshot fontData userId codepoints =
  TextShape.withFontData fontData \font ->
    withShapeConfig font script language \shapeConfig ->
      withGlyphStorage \glyphStoragePtr -> do
        withGlyphConfig \glyphConfig ->
          pushCodepoints font glyphStoragePtr glyphConfig userId codepoints
        shapeDirect shapeConfig glyphStoragePtr
  where
    script = Enums.SCRIPT_DONT_KNOW
    language = Enums.LANGUAGE_DONT_KNOW

withShapeConfig font script language =
  bracket
    (ShapeDirect.kbts_CreateShapeConfig font script language nullFunPtr nullPtr)
    ShapeDirect.kbts_DestroyShapeConfig

withGlyphStorage :: (Ptr Structs.GlyphStorage -> IO b) -> IO b
withGlyphStorage action = alloca @Structs.GlyphStorage \ptr -> do
  fillBytes ptr 0 (sizeOf (undefined :: Structs.GlyphStorage))
  action ptr

withGlyphConfig :: (Handles.GlyphConfig -> IO c) -> IO c
withGlyphConfig =
  bracket
  (ShapeDirect.kbts_CreateGlyphConfig nullPtr 0 nullFunPtr nullPtr)
  ShapeDirect.kbts_DestroyGlyphConfig

pushCodepoints :: (Foldable t, Integral a) => TextShape.Font -> Ptr Structs.GlyphStorage -> Handles.GlyphConfig -> a -> t Char -> IO ()
pushCodepoints font glyphStoragePtr glyphConfig userId = mapM_ \codepoint ->
  ShapeDirect.kbts_PushGlyph
    glyphStoragePtr
    font
    (fromIntegral $ ord codepoint)
    glyphConfig
    (fromIntegral userId)

shapeDirect :: Handles.ShapeConfig -> Ptr Structs.GlyphStorage -> IO [TextShape.Glyph]
shapeDirect shapeConfig glyphStoragePtr =
  alloca \glyphItPtr -> do
    !err <- ShapeDirect.kbts_ShapeDirect
      shapeConfig
      glyphStoragePtr
      Enums.DIRECTION_DONT_KNOW
      nullFunPtr
      nullPtr
      glyphItPtr
    when (err /= Enums.SHAPE_ERROR_NONE) $
      error $ show err
    alloca \glyphOutPtr ->
      iterateGlyphs glyphOutPtr glyphItPtr

-- some copypasta from unexported parts

iterateGlyphs :: Ptr (Ptr Structs.Glyph) -> Ptr Structs.GlyphIterator -> IO [TextShape.Glyph]
iterateGlyphs glyphOutPtr it = stepWhile step fetch
  where
    step = (/= 0) <$> Iterators.kbts_GlyphIteratorNext it glyphOutPtr
    fetch = do
      peek glyphOutPtr >>= peek >>= TextShape.stripGlyph

stepWhile :: Monad m => m Bool -> m a -> m [a]
stepWhile step fetch = do
  result <- step
  if result then do
    x <- fetch
    (x :) <$> stepWhile step fetch
  else
    pure []