module Main (main) where
import Control.Monad
import Data.Char (chr, ord)
import Data.IORef
import Foreign hiding (void)
import Foreign.C (CInt)
import Prelude hiding (id)
import Control.Exception (bracket, evaluate)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.ByteString.Unsafe qualified as ByteString
import Data.List (sort)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Foreign qualified as Text
import Test.Tasty
import Test.Tasty.HUnit
import KB.Text.Shape.FFI.API.Context qualified as ShapeContext
import KB.Text.Shape.FFI.API.Direct qualified as ShapeDirect
import KB.Text.Shape.FFI.API.Other qualified as Other
import KB.Text.Shape.FFI.API.Segmentation qualified as Segmentation
import KB.Text.Shape.FFI.Allocator qualified as Allocator
import KB.Text.Shape.FFI.Enums qualified as Enums
import KB.Text.Shape.FFI.Flags qualified as Flags
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 Font
testFontTtf :: FilePath
testFontTtf = "test/Ubuntu-R.ttf"
-- | Written on suite startup; also serves as the bench fixture.
testFontKbts :: FilePath
testFontKbts = "test/Ubuntu-R.kbts"
-- | Latin, Ethiopic, Hebrew and Devanagari runs. Ubuntu-R only has glyphs for the Latin parts.
testText :: Text
testText = "Hello, ሰላם።, שלמלך, नमस्ते world!"
main :: IO ()
main = do
ttfData <- ByteString.readFile testFontTtf
blobData <- Font.extractBlob ttfData 0
ByteString.writeFile testFontKbts blobData
defaultMain $ testGroup "kb-text-shape"
[ fontTests ttfData blobData
, contextTests ttfData blobData
, directTests ttfData
, segmentationTests
, scriptTests
, coverageTests ttfData
, allocatorTests ttfData
]
-- * Fonts
fontTests :: ByteString -> ByteString -> TestTree
fontTests ttfData blobData = testGroup "fonts"
[ testCase "kbts_FontCount sees one font in the TTF" $
ByteString.unsafeUseAsCStringLen ttfData \(ptr, len) -> do
count <- evaluate $ ShapeDirect.kbts_FontCount (castPtr ptr) (fromIntegral len)
count @?= 1
, testCase "createFont produces a valid font" $
withFont ttfData \font -> do
valid <- evaluate $ ShapeDirect.kbts_FontIsValid font
assertBool "kbts_FontIsValid" (valid /= 0)
, testCase "extractBlob output loads without another blob pass" $ do
assertBool "blob is not empty" . not $ ByteString.null blobData
Font.withLoader \font statePtr ->
Font.loadFont blobData 0 font statePtr >>= \case
Right Font.LoadFontReady -> pure ()
Right Font.LoadFontNeedsBlob{} -> assertFailure "blob wants another blob pass"
Left err -> assertFailure $ "blob failed to load: " <> show err
, testCase "garbage font data is not counted as a font" $
-- NB: this is as far as input validation goes, fonts are trusted input!
ByteString.unsafeUseAsCStringLen (ByteString.replicate 1024 0x2A) \(ptr, len) -> do
count <- evaluate $ ShapeDirect.kbts_FontCount (castPtr ptr) (fromIntegral len)
count @?= 0
, testCase "getFontInfo reports style and metrics" $
withFont ttfData \font -> do
info <- Font.getFontInfo font
info.strings @?= [] -- Ubuntu-R has no LanguageId=0 name records
info.styleFlags @?= Flags.FONT_STYLE_FLAG_REGULAR
info.weight @?= Enums.FONT_WEIGHT_NORMAL
info.width @?= Enums.FONT_WIDTH_NORMAL
info.unitsPerEm @?= 1000
info.capitalHeight @?= 693
info.ascent @?= 932
info.descent @?= (-189)
info.lineGap @?= 0
(info.xMin, info.yMin, info.xMax, info.yMax) @?= (-211, -195, 1266, 958)
, testCase "getFontInfo agrees between TTF and blob" $
withFont ttfData \ttf ->
withFont blobData \blob -> do
ttfInfo <- Font.getFontInfo ttf
blobInfo <- Font.getFontInfo blob
blobInfo @?= ttfInfo
, testCase "kbts_GetFontInfo (v1) agrees with the extended query" $
withFont ttfData \font ->
alloca \infoPtr -> do
ShapeDirect.kbts_GetFontInfo font infoPtr
Structs.FontInfo{styleFlags, weight, width} <- peek infoPtr
info2 <- Font.getFontInfo font
(styleFlags, weight, width) @?= (info2.styleFlags, info2.weight, info2.width)
]
-- * Context API
contextTests :: ByteString -> ByteString -> TestTree
contextTests ttfData blobData = testGroup "context API"
[ testCase "font stack refcounting" $
TextShape.withContext \ctx -> do
font <- TextShape.pushFontFromMemory ctx ttfData 0
uses <- TextShape.pushFont ctx font
uses @?= 2
pop1 <- TextShape.popFont ctx
pop1 @?= (1, font)
pop0 <- TextShape.popFont ctx
pop0 @?= (0, font)
, testCase "pushFontFromFile loads from disk" $
TextShape.withContext \ctx -> do
_font <- TextShape.pushFontFromFile ctx testFontTtf 0
glyphs <- shapeText ctx "Abc"
map (.codepoint) glyphs @?= "Abc"
, testCase "pushFontFromFile loads a pre-distilled blob" $ do
ttfGlyphs <- TextShape.withContext \ctx -> do
_font <- TextShape.pushFontFromFile ctx testFontTtf 0
shapeText ctx "Abc"
blobGlyphs <- TextShape.withContext \ctx -> do
_font <- TextShape.pushFontFromFile ctx testFontKbts 0
shapeText ctx "Abc"
blobGlyphs @?= ttfGlyphs
, testCase "simple latin text is one LTR run" $
withFontContext ttfData \ctx _font -> do
results <- TextShape.run ctx $ TextShape.text_ "Hello!"
(r, glyphs) <- expectOneRun results
r.script @?= Enums.SCRIPT_LATIN
r.direction @?= Enums.DIRECTION_LTR
r.paragraphDirection @?= Enums.DIRECTION_LTR
map (.codepoint) glyphs @?= "Hello!"
map (.codepointIndex) glyphs @?= [0 .. 5]
assertBool "all glyphs mapped" $ all (\g -> g.id /= 0) glyphs
assertBool "positive advances" $ all (\g -> g.gpos.advanceX > 0) glyphs
shapeError <- evaluate $ ShapeContext.kbts_ShapeError ctx.handle
shapeError @?= Enums.SHAPE_ERROR_NONE
, testCase "char_ feeds single codepoints" $
withFontContext ttfData \ctx _font -> do
results <- TextShape.run ctx do
TextShape.char_ 'A'
TextShape.char_ 'b'
concatMap (map (.codepoint) . snd) results @?= "Ab"
, testCase "multi-script text segments into runs" $
withFontContext ttfData \ctx _font -> do
results <- TextShape.run ctx $ TextShape.text_ testText
let runs = map fst results
assertBool "several runs" (length runs >= 4)
forM_ [Enums.SCRIPT_LATIN, Enums.SCRIPT_ETHIOPIC, Enums.SCRIPT_HEBREW, Enums.SCRIPT_DEVANAGARI] \script ->
assertBool ("has a run of " <> show script) $
script `elem` map (.script) runs
forM_ runs \r ->
r.paragraphDirection @?= Enums.DIRECTION_LTR
-- all input made it through, in logical order per run
let allIndices = concatMap (map (.codepointIndex) . snd) results
sort allIndices @?= [0 .. Text.length testText - 1]
, testCase "RTL runs are flipped to visual order" $
withFontContext ttfData \ctx _font -> do
results <- TextShape.run ctx $ TextShape.text_ testText
let rtl = [ x | x@(r, _) <- results, r.direction == Enums.DIRECTION_RTL ]
assertBool "has RTL runs" . not $ null rtl
forM_ rtl \(r, glyphs) -> do
r.script @?= Enums.SCRIPT_HEBREW
let indices = map (.codepointIndex) glyphs
indices @?= reverse (sort indices)
, testCase "TTF and blob shape identically" $ do
ttfResults <- withFontContext ttfData \ctx _font ->
TextShape.run ctx $ TextShape.text_ testText
blobResults <- withFontContext blobData \ctx _font ->
TextShape.run ctx $ TextShape.text_ testText
-- font handles differ between contexts, compare everything else
let strip (r, glyphs) = ((r.script, r.direction, r.paragraphDirection, r.flags), glyphs)
map strip blobResults @?= map strip ttfResults
, testCase "withFont_ splits the text into font runs" $
TextShape.withContext \ctx -> do
fontA <- TextShape.pushFontFromMemory ctx ttfData 0
fontB <- TextShape.pushFontFromMemory ctx ttfData 0
assertBool "two loads give distinct handles" (fontA /= fontB)
results <- TextShape.run ctx do
TextShape.text_ "abc"
TextShape.withFont_ fontA $ TextShape.text_ "def"
TextShape.text_ "ghi"
concatMap (map (.codepoint) . snd) results @?= "abcdefghi"
-- XXX: characterizes an upstream quirk: the font is sampled when
-- pending breaks flush, not when codepoints are fed, so mid-input
-- font switches land about one segment too early.
-- Expected [(B, "abc"), (A, "def"), (B, "ghi")], but 2.24 gives:
let named font
| font == fontA = 'A'
| font == fontB = 'B'
| otherwise = '?'
[ (named r.font, map (.codepoint) glyphs) | (r, glyphs) <- results ]
@?= [('A', "abc"), ('B', "defghi")]
, testCase "bottom-to-top font priority flag reverses the stack" $
bracket (TextShape.createContextWith Flags.SHAPE_CONTEXT_FLAG_FONT_PRIORITY_BOTTOM_TO_TOP) TextShape.destroyContext \ctx -> do
fontA <- TextShape.pushFontFromMemory ctx ttfData 0
fontB <- TextShape.pushFontFromMemory ctx ttfData 0
assertBool "two loads give distinct handles" (fontA /= fontB)
results <- TextShape.run ctx $ TextShape.text_ "abc"
map (\(r, _) -> r.font) results @?= [fontA]
, testCase "context works in caller-provided fixed memory" $
withFont ttfData \font -> do
contextSize <- evaluate ShapeContext.kbts_SizeOfShapeContext
assertBool "context size is known" (contextSize > 0)
let size = fromIntegral contextSize + 4 * 1024 * 1024
allocaBytes size \mem -> do
handle <- ShapeContext.kbts_PlaceShapeContextFixedMemory2 (castPtr mem) (fromIntegral size) Flags.SHAPE_CONTEXT_FLAG_NONE
assertBool "context placed" (handle /= Handles.ShapeContext nullPtr)
fonts <- newIORef mempty
let ctx = TextShape.Context{handle, fonts}
_uses <- TextShape.pushFont ctx font
glyphs <- shapeText ctx "Fixed"
map (.codepoint) glyphs @?= "Fixed"
-- fixed-memory contexts own no external allocations, nothing to destroy
, testCase "feature overrides toggle ligatures" $
withFontContext ttfData \ctx _font -> do
ligated <- shapeText ctx "fi"
length ligated @?= 1
assertBool "ligature flag set" $
all (\g -> g.flags .&. Flags.GLYPH_FLAG_LIGATURE /= mempty) ligated
plain <- concatMap snd <$> TextShape.run ctx do
TextShape.withFeature_ Enums.FEATURE_TAG_liga 0 $
TextShape.text_ "fi"
map (.codepoint) plain @?= "fi"
, testCase "feature stack pop reports the removal" $
withFontContext ttfData \ctx _font -> do
popped <- newIORef (-1)
_results <- TextShape.run ctx do
TextShape.pushFeature_ Enums.FEATURE_TAG_liga 1
TextShape.text_ "fi"
TextShape.popFeature_ Enums.FEATURE_TAG_liga >>= writeIORef popped
-- XXX: upstream kbts_ShapePopFeature loses the found-and-removed
-- result, it is always 0 as of 2.24.
readIORef popped >>= (@?= 0)
, testCase "shaped codepoints can be retrieved by index" $
withFontContext ttfData \ctx _font -> do
_results <- TextShape.run ctx $ TextShape.text_ "Hi"
alloca \cpPtr -> do
found <- ShapeContext.kbts_ShapeGetShapeCodepoint ctx.handle 1 cpPtr
assertBool "codepoint 1 found" (found /= 0)
cp <- peek cpPtr
cp.codepoint @?= ord 'i'
cp.userId @?= 1
cp.featureOverrideCount @?= 0
, testCase "codepoint iterator walks the input" $
withFontContext ttfData \ctx _font -> do
collected <- newIORef []
_results <- TextShape.run ctx do
TextShape.text_ "abc"
alloca \itPtr -> alloca \cpPtr -> alloca \ixPtr -> do
ShapeContext.hs_ShapeCurrentCodepointsIterator ctx.handle itPtr
valid <- ShapeContext.kbts_ShapeCodepointIteratorIsValid itPtr
assertBool "iterator is valid" (valid /= 0)
let go acc = do
more <- ShapeContext.kbts_ShapeCodepointIteratorNext itPtr cpPtr ixPtr
if more /= 0
then do
cp <- peek cpPtr
ix <- peek ixPtr
go $ (fromIntegral ix, chr cp.codepoint) : acc
else pure $ reverse acc
go [] >>= writeIORef collected
readIORef collected >>= (@?= [(0 :: Int, 'a'), (1, 'b'), (2, 'c')])
]
-- * Direct API
directTests :: ByteString -> TestTree
directTests ttfData = testGroup "direct API"
[ testCase "direct shaping matches the context pipeline" $
withShapeSetup ttfData \font _config scratchpad -> do
direct <- directShape font scratchpad nullGlyphConfig "Hello!"
viaContext <- withFontContext ttfData \ctx _font -> shapeText ctx "Hello!"
map (.id) direct @?= map (.id) viaContext
map (.gpos) direct @?= map (.gpos) viaContext
, testCase "a scratchpad can be reused across shaping calls" $
withShapeSetup ttfData \font _config scratchpad -> do
one <- directShape font scratchpad nullGlyphConfig "abc"
two <- directShape font scratchpad nullGlyphConfig "abc"
two @?= one
, testCase "scratchpad in caller-provided fixed memory" $
withFont ttfData \font ->
withShapeConfig font \config -> do
need <- evaluate $ ShapeDirect.kbts_SizeOfShapeScratchpad config
assertBool "scratchpad size is known" (need > 0)
let size = fromIntegral need + 4 * 1024 * 1024
allocaBytes size \mem -> do
scratchpad <- ShapeDirect.kbts_PlaceShapeScratchpadFixedMemory config (castPtr mem) (fromIntegral size)
assertBool "scratchpad placed" (scratchpad /= Handles.ShapeScratchpad nullPtr)
glyphs <- directShape font scratchpad nullGlyphConfig "Fixed"
map (.codepoint) glyphs @?= "Fixed"
, testCase "scratchpad placed at caller memory, allocating dynamically" $
withFont ttfData \font ->
withShapeConfig font \config -> do
need <- evaluate $ ShapeDirect.kbts_SizeOfShapeScratchpad config
allocaBytes (fromIntegral need) \mem -> do
scratchpad <- ShapeDirect.kbts_PlaceShapeScratchpad config (castPtr mem) nullFunPtr nullPtr
assertBool "scratchpad placed" (scratchpad /= Handles.ShapeScratchpad nullPtr)
glyphs <- directShape font scratchpad nullGlyphConfig "Placed"
map (.codepoint) glyphs @?= "Placed"
ShapeDirect.kbts_DestroyShapeScratchpad scratchpad
, testCase "shape config placed in caller memory" $
withFont ttfData \font -> do
size <- evaluate $ ShapeDirect.kbts_SizeOfShapeConfig font Enums.SCRIPT_LATIN Enums.LANGUAGE_DONT_KNOW
assertBool "config size is known" (size > 0)
allocaBytes (fromIntegral size) \mem -> do
config <- ShapeDirect.kbts_PlaceShapeConfig font Enums.SCRIPT_LATIN Enums.LANGUAGE_DONT_KNOW (castPtr mem)
assertBool "config placed" (config /= Handles.ShapeConfig nullPtr)
withScratchpad config \scratchpad -> do
glyphs <- directShape font scratchpad nullGlyphConfig "Placed"
map (.codepoint) glyphs @?= "Placed"
, testCase "glyph storage in caller-provided fixed memory" $
withShapeSetup ttfData \font _config scratchpad -> do
let size = 1024 * 1024
allocaBytes size \mem ->
alloca @Structs.GlyphStorage \storagePtr -> do
ok <- ShapeDirect.kbts_InitializeGlyphStorageFixedMemory storagePtr (castPtr mem) (fromIntegral size)
assertBool "storage initialized" (ok /= 0)
forM_ ("abc" :: String) \c -> do
glyphPtr <- ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) nullGlyphConfig 0
assertBool "glyph pushed" (glyphPtr /= nullPtr)
glyphs <- shapeStorage scratchpad storagePtr
map (.codepoint) glyphs @?= "abc"
, testCase "glyph configs accept feature overrides" $
withShapeSetup ttfData \font config scratchpad -> do
let overrides =
[ Structs.FeatureOverride Enums.FEATURE_TAG_liga 0
, Structs.FeatureOverride Enums.FEATURE_TAG_smcp 1
, Structs.FeatureOverride Enums.FEATURE_TAG_salt 3 -- non-binary values are stored explicitly
]
withArrayLen overrides \count overridesPtr -> do
size <- evaluate $ ShapeDirect.kbts_SizeOfGlyphConfig config overridesPtr (fromIntegral count)
assertBool "glyph config size is known" (size > 0)
allocaBytes (fromIntegral size) \mem -> do
placed <- ShapeDirect.kbts_PlaceGlyphConfig config overridesPtr (fromIntegral count) (castPtr mem)
assertBool "glyph config placed" (placed /= nullGlyphConfig)
glyphs <- directShape font scratchpad placed "fine"
map (.codepoint) glyphs @?= "fine"
bracket
(ShapeDirect.kbts_CreateGlyphConfig config overridesPtr (fromIntegral count) nullFunPtr nullPtr)
ShapeDirect.kbts_DestroyGlyphConfig
\created -> do
assertBool "glyph config created" (created /= nullGlyphConfig)
glyphs <- directShape font scratchpad created "fine"
map (.codepoint) glyphs @?= "fine"
, testCase "codepoint to glyph mapping" $
withFont ttfData \font -> do
glyphIdA <- ShapeDirect.kbts_CodepointToGlyphId font (fromIntegral (ord 'A'))
assertBool "'A' is mapped" (glyphIdA > 0)
glyphIdHan <- ShapeDirect.kbts_CodepointToGlyphId font 0x6C49
glyphIdHan @?= 0
alloca @Structs.Glyph \glyphPtr -> do
ShapeDirect.hs_CodepointToGlyph font (fromIntegral (ord 'A')) nullGlyphConfig 7 glyphPtr
glyph <- peek glyphPtr
glyph.codepoint @?= fromIntegral (ord 'A')
fromIntegral glyph.id @?= glyphIdA
glyph.userIdOrCodepointIndex @?= 7
, testCase "clearing active glyphs empties the iterator" $
withShapeSetup ttfData \font _config _scratchpad ->
withGlyphStorage \storagePtr -> do
forM_ ("abc" :: String) \c ->
void $ ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) nullGlyphConfig 0
alloca \itPtr -> do
ShapeDirect.hs_ActiveGlyphIterator storagePtr itPtr
valid <- evaluate $ Iterators.kbts_GlyphIteratorIsValid itPtr
assertBool "iterator over pushed glyphs is valid" (valid /= 0)
ShapeDirect.kbts_ClearActiveGlyphs storagePtr
alloca \itPtr -> do
ShapeDirect.hs_ActiveGlyphIterator storagePtr itPtr
alloca \outPtr -> do
more <- Iterators.kbts_GlyphIteratorNext itPtr outPtr
more @?= 0
]
-- * Segmentation
segmentationTests :: TestTree
segmentationTests = testGroup "segmentation"
[ testCase "guess text properties (UTF-8)" $ do
guessUtf8 "hello there" >>= (@?= (Enums.DIRECTION_LTR, Enums.SCRIPT_LATIN))
guessUtf8 "שלום" >>= (@?= (Enums.DIRECTION_RTL, Enums.SCRIPT_HEBREW))
, testCase "guess text properties (UTF-32)" $ do
guessUtf32 "hello" >>= (@?= (Enums.DIRECTION_LTR, Enums.SCRIPT_LATIN))
guessUtf32 "مرحبا" >>= (@?= (Enums.DIRECTION_RTL, Enums.SCRIPT_ARABIC))
, testCase "guess text properties (generic entry point)" $ do
let text = "hello" :: Text
Text.withCStringLen text \(ptr, len) ->
alloca \directionPtr -> alloca \scriptPtr -> do
poke directionPtr Enums.DIRECTION_DONT_KNOW
poke scriptPtr Enums.SCRIPT_DONT_KNOW
Segmentation.kbts_GuessTextProperties (castPtr ptr) (fromIntegral len) Enums.TEXT_FORMAT_UTF8 directionPtr scriptPtr
direction <- peek directionPtr
script <- peek scriptPtr
(direction, script) @?= (Enums.DIRECTION_LTR, Enums.SCRIPT_LATIN)
, testCase "BreakEntireStringUtf32 finds words and hard line breaks" $ do
breaks <- breakEntireUtf32 "one two\nthree"
assertBool "found breaks" . not $ null breaks
assertBool "found a word break" $
any (\b -> hasBreakFlag b.flags Flags.BREAK_FLAG_WORD) breaks
let hard = [ b.position | b <- breaks, hasBreakFlag b.flags Flags.BREAK_FLAG_LINE_HARD ]
hard @?= [8]
, testCase "incremental break state agrees with the entire-string API" $ do
let text = "one two\nthree four"
whole <- breakEntireUtf32 text
incremental <- breakIncremental text
-- The entire-string API merges the flags of same-position breaks, but
-- its output needs another merge pass: a late-arriving break can get
-- merged into a zeroed hole (see 'withBreakBuffers') instead of the
-- real record, splitting the position across two records.
mergeBreaks incremental @?= mergeBreaks whole
, testCase "BreakEntireStringUtf8 agrees with UTF-32 on ASCII" $ do
let text = "one two\nthree four"
utf32 <- breakEntireUtf32 text
utf8 <- breakEntireUtf8 text
let key b = (b.position, b.flags)
map key utf8 @?= map key utf32
]
-- * Scripts
scriptTests :: TestTree
scriptTests = testGroup "scripts"
[ testCase "kbts_ScriptDirection" $ do
Other.kbts_ScriptDirection Enums.SCRIPT_LATIN @?= Enums.DIRECTION_LTR
Other.kbts_ScriptDirection Enums.SCRIPT_HEBREW @?= Enums.DIRECTION_RTL
Other.kbts_ScriptDirection Enums.SCRIPT_ARABIC @?= Enums.DIRECTION_RTL
, testCase "kbts_ScriptIsComplex" $ do
Other.kbts_ScriptIsComplex Enums.SCRIPT_LATIN @?= 0
assertBool "arabic is complex" $ Other.kbts_ScriptIsComplex Enums.SCRIPT_ARABIC /= 0
assertBool "devanagari is complex" $ Other.kbts_ScriptIsComplex Enums.SCRIPT_DEVANAGARI /= 0
, testCase "kbts_ScriptTagToScript decodes FOURCC tags" $ do
Other.kbts_ScriptTagToScript (fourcc "latn") @?= Enums.SCRIPT_LATIN
Other.kbts_ScriptTagToScript (fourcc "hebr") @?= Enums.SCRIPT_HEBREW
Other.kbts_ScriptTagToScript (fourcc "dev2") @?= Enums.SCRIPT_DEVANAGARI -- kbts uses the v2 Indic tags
]
-- * Font coverage
coverageTests :: ByteString -> TestTree
coverageTests ttfData = testGroup "font coverage"
[ testCase "latin text is covered" $
coverage "Hello" >>= (@?= True)
, testCase "CJK text is not covered" $
coverage "汉字" >>= (@?= False)
]
where
coverage :: String -> IO Bool
coverage text =
withFont ttfData \font ->
alloca @Structs.FontCoverageTest \testPtr -> do
fillBytes testPtr 0 $ sizeOf (undefined :: Structs.FontCoverageTest)
Other.kbts_FontCoverageTestBegin testPtr font
forM_ text \c ->
Other.kbts_FontCoverageTestCodepoint testPtr (fromIntegral (ord c))
covered <- Other.kbts_FontCoverageTestEnd testPtr
pure $ covered /= 0
-- * Allocator callback
allocatorTests :: ByteString -> TestTree
allocatorTests ttfData = testGroup "allocator"
[ testCase "haskell allocator drives a scratchpad lifecycle" $
withFont ttfData \font ->
withShapeConfig font \config -> do
allocCount <- newIORef (0 :: Int)
liveSet <- newIORef (Set.empty :: Set (Ptr ()))
Allocator.withAllocator (countingAllocator allocCount liveSet) \allocFn -> do
scratchpad <- ShapeDirect.kbts_CreateShapeScratchpad config allocFn nullPtr
assertBool "scratchpad created" (scratchpad /= Handles.ShapeScratchpad nullPtr)
glyphs <- directShape font scratchpad nullGlyphConfig "Hello, world"
map (.codepoint) glyphs @?= "Hello, world"
ShapeDirect.kbts_DestroyShapeScratchpad scratchpad
allocs <- readIORef allocCount
assertBool "allocator was exercised" (allocs > 0)
live <- readIORef liveSet
live @?= Set.empty
]
countingAllocator :: IORef Int -> IORef (Set (Ptr ())) -> Allocator.Allocator
countingAllocator allocCount liveSet _data opPtr = do
op <- peek opPtr
case op.kind of
Allocator.OP_KIND_ALLOCATE -> do
ptr <- mallocBytes $ fromIntegral op.size
modifyIORef' allocCount (+ 1)
modifyIORef' liveSet $ Set.insert ptr
poke opPtr op{Allocator.pointer = ptr}
Allocator.OP_KIND_FREE -> do
modifyIORef' liveSet $ Set.delete op.pointer
free op.pointer
other ->
error $ "unexpected allocator op: " <> show other
-- * Fixtures
-- | A loaded standalone font.
withFont :: ByteString -> (Handles.Font -> IO r) -> IO r
withFont bytes action =
bracket (Font.createFont bytes 0) Font.destroyFont \fontData ->
Font.withFontData fontData action
-- | A shaping context with one font pushed.
withFontContext :: ByteString -> (TextShape.Context -> Handles.Font -> IO r) -> IO r
withFontContext bytes action =
TextShape.withContext \ctx -> do
font <- TextShape.pushFontFromMemory ctx bytes 0
action ctx font
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
-- | Font, shape config and scratchpad for direct shaping.
withShapeSetup :: ByteString -> (Handles.Font -> Handles.ShapeConfig -> Handles.ShapeScratchpad -> IO r) -> IO r
withShapeSetup bytes action =
withFont bytes \font ->
withShapeConfig font \config ->
withScratchpad config \scratchpad ->
action font config scratchpad
withGlyphStorage :: (Ptr Structs.GlyphStorage -> IO r) -> IO r
withGlyphStorage action =
alloca @Structs.GlyphStorage \ptr -> do
ok <- ShapeDirect.kbts_InitializeGlyphStorage ptr nullFunPtr nullPtr
assertBool "glyph storage initialized" (ok /= 0)
result <- action ptr
ShapeDirect.kbts_FreeAllGlyphs ptr
pure result
nullGlyphConfig :: Handles.GlyphConfig
nullGlyphConfig = Handles.GlyphConfig nullPtr
-- * Helpers
shapeText :: TextShape.Context -> Text -> IO [TextShape.Glyph]
shapeText ctx text = concatMap snd <$> TextShape.run ctx (TextShape.text_ text)
expectOneRun :: [(TextShape.Run, [TextShape.Glyph])] -> IO (TextShape.Run, [TextShape.Glyph])
expectOneRun = \case
[x] -> pure x
other -> assertFailure $ "expected one run, got " <> show (length other)
directShape :: Handles.Font -> Handles.ShapeScratchpad -> Handles.GlyphConfig -> String -> IO [TextShape.Glyph]
directShape font scratchpad glyphConfig text =
withGlyphStorage \storagePtr -> do
forM_ text \c ->
ShapeDirect.kbts_PushGlyph storagePtr font (fromIntegral (ord c)) glyphConfig 0
shapeStorage scratchpad storagePtr
shapeStorage :: Handles.ShapeScratchpad -> Ptr Structs.GlyphStorage -> IO [TextShape.Glyph]
shapeStorage scratchpad storagePtr =
alloca \itPtr -> do
err <- ShapeDirect.kbts_ShapeDirect scratchpad storagePtr Enums.DIRECTION_DONT_KNOW itPtr
err @?= Enums.SHAPE_ERROR_NONE
alloca \outPtr -> TextShape.iterateGlyphs outPtr itPtr
guessUtf8 :: Text -> IO (Enums.Direction, Enums.Script)
guessUtf8 text =
Text.withCStringLen text \(ptr, len) ->
alloca \directionPtr -> alloca \scriptPtr -> do
poke directionPtr Enums.DIRECTION_DONT_KNOW
poke scriptPtr Enums.SCRIPT_DONT_KNOW
Segmentation.kbts_GuessTextPropertiesUtf8 ptr (fromIntegral len) directionPtr scriptPtr
(,) <$> peek directionPtr <*> peek scriptPtr
guessUtf32 :: String -> IO (Enums.Direction, Enums.Script)
guessUtf32 text =
withArrayLen (map (fromIntegral . ord) text :: [CInt]) \len ptr ->
alloca \directionPtr -> alloca \scriptPtr -> do
poke directionPtr Enums.DIRECTION_DONT_KNOW
poke scriptPtr Enums.SCRIPT_DONT_KNOW
Segmentation.kbts_GuessTextPropertiesUtf32 ptr (fromIntegral len) directionPtr scriptPtr
(,) <$> peek directionPtr <*> peek scriptPtr
hasBreakFlag :: Flags.BreakFlags -> Flags.BreakFlags -> Bool
hasBreakFlag flags flag = flags .&. flag == flag
-- | Collect breaks with 1-per-codepoint positions and a generous output capacity.
breakEntireUtf32 :: String -> IO [Structs.Break]
breakEntireUtf32 text =
withArrayLen (map (fromIntegral . ord) text :: [CInt]) \len codepointsPtr ->
withBreakBuffers len \breaksPtr breakCountPtr flagsPtr flagCountPtr -> do
Segmentation.kbts_BreakEntireStringUtf32
Enums.DIRECTION_DONT_KNOW
Enums.JAPANESE_LINE_BREAK_STYLE_NORMAL
mempty
(castPtr codepointsPtr)
(fromIntegral len)
breaksPtr
(fromIntegral $ breakCapacity len)
breakCountPtr
flagsPtr
(fromIntegral len)
flagCountPtr
breakEntireUtf8 :: String -> IO [Structs.Break]
breakEntireUtf8 text =
Text.withCStringLen (Text.pack text) \(textPtr, len) ->
withBreakBuffers len \breaksPtr breakCountPtr flagsPtr flagCountPtr -> do
Segmentation.kbts_BreakEntireStringUtf8
Enums.DIRECTION_DONT_KNOW
Enums.JAPANESE_LINE_BREAK_STYLE_NORMAL
mempty
textPtr
(fromIntegral len)
breaksPtr
(fromIntegral $ breakCapacity len)
breakCountPtr
flagsPtr
(fromIntegral len)
flagCountPtr
breakCapacity :: Int -> Int
breakCapacity len = 4 * len + 16
{- | Prepare output buffers for a @BreakEntireString*@ call and read them back.
NB: as of 2.24 upstream advances its write cursor (and the final count) even
when a break gets merged into a previously written position, leaving unwritten
holes in the output array. The buffer is pre-zeroed so the holes are inert,
and dropped here since a real break always carries at least one flag.
-}
withBreakBuffers
:: Int
-> (Ptr Structs.Break -> Ptr CInt -> Ptr Flags.BreakFlags -> Ptr CInt -> IO ())
-> IO [Structs.Break]
withBreakBuffers len fill =
allocaArray capacity \breaksPtr ->
alloca \breakCountPtr ->
allocaArray len \flagsPtr ->
alloca \flagCountPtr -> do
fillBytes breaksPtr 0 $ capacity * sizeOf (undefined :: Structs.Break)
fill breaksPtr breakCountPtr flagsPtr flagCountPtr
count <- peek breakCountPtr
breaks <- peekArray (min capacity (fromIntegral count)) breaksPtr
pure $ filter (\b -> b.flags /= mempty) breaks
where
capacity = breakCapacity len
-- | Merge same-position breaks the way @kbts_BreakEntireString@ does.
mergeBreaks :: [Structs.Break] -> [(Int, Flags.BreakFlags)]
mergeBreaks = foldl insert []
where
insert acc b =
case break (\(position, _flags) -> position == b.position) acc of
(before, (position, flags) : next) -> before <> ((position, flags <> b.flags) : next)
(_, []) -> acc <> [(b.position, b.flags)]
breakIncremental :: String -> IO [Structs.Break]
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 acc = do
more <- Segmentation.kbts_Break state breakPtr
if more /= 0
then do
b <- peek breakPtr
drain $ b : acc
else pure acc
feed acc (c, isLast) = do
Segmentation.kbts_BreakAddCodepoint state (fromIntegral (ord c)) 1 (if isLast then 1 else 0)
drain acc
annotated = zip text $ map (== length text) [1 ..]
reverse <$> foldM feed [] annotated
fourcc :: String -> Other.ScriptTag
fourcc = \case
[a, b, c, d] -> Other.ScriptTag $
fromIntegral (ord a)
.|. fromIntegral (ord b) `shiftL` 8
.|. fromIntegral (ord c) `shiftL` 16
.|. fromIntegral (ord d) `shiftL` 24
other -> error $ "fourcc: expected 4 characters, got " <> show other