module Main (main) where
import Data.Char (ord)
import Foreign
import Prelude hiding (id)
import Control.Exception (bracket)
import Control.Monad (foldM, when)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.ByteString.Unsafe qualified as ByteString
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Test.Tasty.Bench
import KB.Text.Shape.FFI.API.Direct qualified as ShapeDirect
import KB.Text.Shape.FFI.API.Segmentation qualified as Segmentation
import KB.Text.Shape.FFI.Enums qualified as Enums
import KB.Text.Shape.FFI.Handles qualified as Handles
import KB.Text.Shape.FFI.Structs qualified as Structs
import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.Font qualified as Font
main :: IO ()
main = do
ttfData <- ByteString.readFile testFontTtf
blobData <- Font.extractBlob ttfData 0
ctx <- TextShape.createContext
_ctxFont <- TextShape.pushFontFromMemory ctx blobData 0
fontData <- Font.createFont blobData 0
Font.withFontData fontData \font ->
withShapeConfig font \config ->
withScratchpad config \scratchpad ->
defaultMain
[ bgroup "font loading"
[ bench "extractBlob" $ nfIO $
Font.extractBlob ttfData 0
, bench "createFont from TTF" $ whnfIO do
loaded <- Font.createFont ttfData 0
Font.destroyFont loaded
, bcompare "$NF == \"createFont from TTF\"" $
bench "createFont from blob" $ whnfIO do
loaded <- Font.createFont blobData 0
Font.destroyFont loaded
]
, bgroup "context shaping"
[ bench "latin" $ whnfIO $ shapeVia ctx "Hello, world!"
, bcompare "$NF == \"latin\"" $
bench "multi-script" $ whnfIO $ shapeVia ctx testText
, bench "long text" $ whnfIO $ shapeVia ctx longText
]
, bgroup "direct shaping"
[ bench "cold oneshot" $ whnfIO $ oneshot font testCodepoints
, bcompare "$NF == \"cold oneshot\"" $
bench "warm scratchpad" $ whnfIO $ warmShot font scratchpad testCodepoints
]
, bgroup "segmentation"
[ bench "BreakEntireStringUtf8" $ whnfIO $ breakUtf8 longUtf8
, bench "incremental breaks" $ whnfIO $ breakIncremental longString
]
, bgroup "glyph mapping"
[ bench "kbts_CodepointToGlyphId" $ whnfIO $
ShapeDirect.kbts_CodepointToGlyphId font (fromIntegral (ord 'A'))
]
]
TextShape.destroyContext ctx
Font.destroyFont fontData
testFontTtf :: FilePath
testFontTtf = "test/Ubuntu-R.ttf"
-- | Latin, Ethiopic, Hebrew and Devanagari runs.
testText :: Text
testText = "Hello, ሰላም።, שלמלך, नमस्ते world!"
testCodepoints :: [Char]
testCodepoints = Text.unpack testText
longText :: Text
longText = Text.replicate 64 testText
longString :: [Char]
longString = Text.unpack longText
longUtf8 :: ByteString
longUtf8 = Text.encodeUtf8 longText
-- | Segment and shape through the context API, forcing the glyphs via 'show'.
shapeVia :: TextShape.Context -> Text -> IO Int
shapeVia ctx text = length . show <$> TextShape.run ctx (TextShape.text_ text)
-- | Direct shaping with the full per-call setup: config, scratchpad, storage.
oneshot :: Handles.Font -> [Char] -> IO Int
oneshot font codepoints =
withShapeConfig font \config ->
withScratchpad config \scratchpad ->
-- Glyphs keep the config pointer, it has to outlive the shaping.
withGlyphConfig config \glyphConfig ->
withGlyphStorage \storagePtr -> do
pushCodepoints font storagePtr glyphConfig codepoints
drainShape scratchpad storagePtr
-- | Direct shaping reusing a pre-built config and scratchpad.
warmShot :: Handles.Font -> Handles.ShapeScratchpad -> [Char] -> IO Int
warmShot font scratchpad codepoints =
withGlyphStorage \storagePtr -> do
pushCodepoints font storagePtr (Handles.GlyphConfig nullPtr) codepoints
drainShape scratchpad storagePtr
drainShape :: Handles.ShapeScratchpad -> Ptr Structs.GlyphStorage -> IO Int
drainShape scratchpad storagePtr =
alloca \glyphItPtr -> do
err <- ShapeDirect.kbts_ShapeDirect scratchpad storagePtr Enums.DIRECTION_DONT_KNOW glyphItPtr
when (err /= Enums.SHAPE_ERROR_NONE) $
error $ show err
alloca \glyphOutPtr ->
length . show <$> TextShape.iterateGlyphs glyphOutPtr glyphItPtr
breakUtf8 :: ByteString -> IO Int
breakUtf8 utf8 =
ByteString.unsafeUseAsCStringLen utf8 \(textPtr, len) -> do
let capacity = 4 * len + 16
allocaArray capacity \breaksPtr ->
alloca \breakCountPtr ->
allocaArray len \flagsPtr ->
alloca \flagCountPtr -> do
Segmentation.kbts_BreakEntireStringUtf8
Enums.DIRECTION_DONT_KNOW
Enums.JAPANESE_LINE_BREAK_STYLE_NORMAL
mempty
textPtr
(fromIntegral len)
breaksPtr
(fromIntegral capacity)
breakCountPtr
flagsPtr
(fromIntegral len)
flagCountPtr
fromIntegral <$> peek breakCountPtr
breakIncremental :: [Char] -> IO Int
breakIncremental text =
allocaBytes Handles.sizeOfBreakState \raw -> do
fillBytes raw 0 Handles.sizeOfBreakState
let state = Handles.BreakState (castPtr raw)
Segmentation.kbts_BreakBegin state Enums.DIRECTION_DONT_KNOW Enums.JAPANESE_LINE_BREAK_STYLE_NORMAL mempty
alloca \breakPtr -> do
let drain !n = do
more <- Segmentation.kbts_Break state breakPtr
if more /= 0 then drain (n + 1) else pure n
feed !n (c, isLast) = do
Segmentation.kbts_BreakAddCodepoint state (fromIntegral (ord c)) 1 (if isLast then 1 else 0)
drain n
foldM feed (0 :: Int) $ zip text (replicate (length text - 1) False <> [True])
-- * Fixtures
withShapeConfig :: Handles.Font -> (Handles.ShapeConfig -> IO r) -> IO r
withShapeConfig font =
bracket
(ShapeDirect.kbts_CreateShapeConfig font Enums.SCRIPT_DONT_KNOW Enums.LANGUAGE_DONT_KNOW nullFunPtr nullPtr)
ShapeDirect.kbts_DestroyShapeConfig
withScratchpad :: Handles.ShapeConfig -> (Handles.ShapeScratchpad -> IO r) -> IO r
withScratchpad config =
bracket
(ShapeDirect.kbts_CreateShapeScratchpad config nullFunPtr nullPtr)
ShapeDirect.kbts_DestroyShapeScratchpad
withGlyphConfig :: Handles.ShapeConfig -> (Handles.GlyphConfig -> IO r) -> IO r
withGlyphConfig shapeConfig =
bracket
(ShapeDirect.kbts_CreateGlyphConfig shapeConfig nullPtr 0 nullFunPtr nullPtr)
ShapeDirect.kbts_DestroyGlyphConfig
withGlyphStorage :: (Ptr Structs.GlyphStorage -> IO r) -> IO r
withGlyphStorage action =
alloca @Structs.GlyphStorage \ptr -> do
_ok <- ShapeDirect.kbts_InitializeGlyphStorage ptr nullFunPtr nullPtr
result <- action ptr
ShapeDirect.kbts_FreeAllGlyphs ptr
pure result
pushCodepoints :: Handles.Font -> Ptr Structs.GlyphStorage -> Handles.GlyphConfig -> [Char] -> IO ()
pushCodepoints font storagePtr glyphConfig = mapM_ \c ->
ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) glyphConfig 0