{-# LANGUAGE OverloadedRecordDot #-}
import Control.Monad
import Data.Char
import Foreign
import Prelude hiding (id)
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 Font
testFontTtf :: FilePath
testFontTtf = "test/Ubuntu-R.ttf"
testFontBlob :: FilePath
testFontBlob = "test/Ubuntu-R.kbts"
testText :: Text
testText = "Hello, ሰላም።, שלמלך, नमस्ते world!"
testCodepoints :: [Char]
testCodepoints = Text.unpack testText
main :: IO ()
main = do
putStrLn "mainSimple"
mainSimple
putStrLn ""
putStrLn "mainContext - ttf"
ttfGlyphs <- mainContext testFontTtf
putStrLn ""
putStrLn "mainDistill"
mainDistill
putStrLn ""
putStrLn "mainContext - blob"
blobGlyphs <- mainContext testFontBlob
putStrLn ""
if ttfGlyphs == blobGlyphs then
putStrLn "Context/Blob works"
else
error "Context/Blob didn't quite work"
putStrLn ""
putStrLn "mainAllocatorDirect - ttf"
ttfGlyphsDirect <- mainAllocatorDirect testFontTtf 0
putStrLn ""
putStrLn "mainAllocatorDirect - blob"
blobGlyphsDirect <- mainAllocatorDirect testFontBlob 0
putStrLn ""
if ttfGlyphsDirect == blobGlyphsDirect then
putStrLn "Direct/Blob works"
else
error "Direct/Blob didn't quite work"
mainFontInfo
mainSimple :: IO ()
mainSimple = do
TextShape.withContext \ctx -> do
_fallback <- TextShape.pushFontFromFile ctx testFontTtf 0
_main <- TextShape.pushFontFromFile ctx testFontBlob 0
results <- TextShape.run ctx do
TextShape.text_ "A bunch of characters"
TextShape.char_ '!'
forM_ results \(run, glyphs) -> do
forM_ glyphs \glyph ->
print (run.font, glyph.id, glyph.gpos.advanceX)
mainContext :: FilePath -> IO [(TextShape.Run, [TextShape.Glyph])]
mainContext fontFile =
TextShape.withContext \ctx -> do
putStrLn $ "Loading font from " <> fontFile
font <- TextShape.pushFontFromFile ctx fontFile 0
2 <- TextShape.pushFont ctx font -- used 2 times
results <- TextShape.run ctx do
TextShape.text_ testText
TextShape.char_ '!'
writeFile "test/runs-and-glyphs.dump" $ show results
forM results \(run, glyphs) -> do
print run
(run,) <$> dumpGlyphs glyphs
dumpGlyphs :: [TextShape.Glyph] -> IO [TextShape.Glyph]
dumpGlyphs =
mapM \g@TextShape.Glyph{codepoint, id=id, advanceX, codepointIndex} -> do
putStrLn $ (if id == 0 then '-' else '+') : ' ' : codepoint : " | " <> show id <> ", " <> show advanceX <> " $" <> show codepointIndex
pure g
mainAllocatorDirect :: FilePath -> Int -> IO [TextShape.Glyph]
mainAllocatorDirect fontFile fontIndex = do
fontData <- ByteString.readFile fontFile
font <- Font.createFont fontData fontIndex
glyphs <- oneshot font 42 testCodepoints
Font.destroyFont font
dumpGlyphs glyphs
oneshot :: Font.FontData -> Int -> [Char] -> IO [TextShape.Glyph]
oneshot fontData userId codepoints =
Font.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
mainDistill :: IO ()
mainDistill = do
ttfData <- ByteString.readFile testFontTtf
putStrLn $ "Distilling " <> show (ByteString.length ttfData `div` 1024) <> "Kb of TTF"
blobData <- Font.extractBlob ttfData 0
putStrLn $ "Distilled into " <> show (ByteString.length blobData `div` 1024) <> "Kb blob"
ByteString.writeFile testFontBlob blobData
mainFontInfo :: IO ()
mainFontInfo =
TextShape.withContext \ctx -> do
putStrLn "TTF:"
ttf <- TextShape.pushFontFromFile ctx testFontTtf 0
Font.getFontInfo ttf >>= print
putStrLn "Blob:"
blob <- TextShape.pushFontFromFile ctx testFontBlob 0
Font.getFontInfo blob >>= print
putStrLn $ "Units per em: " <> show (Font.unitsPerEm blob)
putStrLn $ "Cap height: " <> show (Font.capHeight blob)
putStrLn $ "em2caps factor: " <> show (Font.emToCaps blob :: Float)
-- 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 []
------
_debugAllocator :: Allocator
_debugAllocator = hallocator opAllocate opFree
where
opAllocate size = do
putStrLn $ "debugAllocator: request for " <> show size
callocBytes size
opFree ptr = do
putStrLn $ "debugAllocator: release " <> show ptr
free ptr
hallocator
:: (Int -> IO (Ptr ()))
-> (Ptr () -> IO ())
-> Allocator
hallocator opAllocate opFree adPtr opPtr = do
op <- peek opPtr
case op.kind of
Allocator.OP_KIND_ALLOCATE -> do
ptr <- opAllocate (fromIntegral op.size)
poke opPtr op{Allocator.pointer=ptr} -- Ugh...
Allocator.OP_KIND_FREE ->
opFree op.pointer
_huh ->
error . mappend "Allocator.OP_KIND_???: " $ show (adPtr, op)