module KB.Text.Shape.Font
  ( -- * Distillation
    extractBlob

    -- * Loading
  , FontData(..)
  , createFont
  , destroyFont

    -- * Using
  , withFontData
  , Handles.Font

    -- * Querying
  , getFontInfo
  , Info(..)

    -- ** Font metrics
  , emToCaps
  , capHeight
  , unitsPerEm

  -- * Loading internals
  , withLoader
  , loadFont
  , LoadFontResult(..)
  , placeBlob
  ) where

import Prelude hiding (id)
import Foreign

import Control.Monad (when, zipWithM)
import Data.ByteString (ByteString)
import Data.ByteString.Internal qualified as ByteString
import Data.ByteString.Unsafe qualified as ByteString
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Data.Text.Foreign qualified as Text

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.Flags qualified as Flags
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

-- | Extract and pre-process font data needed for shaping.
extractBlob
  :: ByteString -- ^ TTF font data
  -> Int -- ^ Font index (use 0 for the first/only font)
  -> IO ByteString -- ^ KBTS blob data
extractBlob :: ByteString -> Int -> IO ByteString
extractBlob ByteString
fontData Int
fontIndex =
  (FontData -> Ptr LoadFontState -> IO ByteString) -> IO ByteString
forall a. (FontData -> Ptr LoadFontState -> IO a) -> IO a
withLoader \FontData
font Ptr LoadFontState
statePtr -> do
    ByteString
-> Int
-> FontData
-> Ptr LoadFontState
-> IO (Either LoadFontError LoadFontResult)
loadFont ByteString
fontData Int
fontIndex FontData
font Ptr LoadFontState
statePtr IO (Either LoadFontError LoadFontResult)
-> (Either LoadFontError LoadFontResult -> IO ByteString)
-> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left LoadFontError
err ->
        [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ LoadFontError -> [Char]
forall a. Show a => a -> [Char]
show LoadFontError
err
      Right LoadFontNeedsBlob{Int
scratchSize :: Int
scratchSize :: LoadFontResult -> Int
scratchSize, Int
outputSize :: Int
outputSize :: LoadFontResult -> Int
outputSize} ->
        FontData -> Ptr LoadFontState -> Int -> Int -> IO ByteString
placeBlob FontData
font Ptr LoadFontState
statePtr Int
scratchSize Int
outputSize
      Right LoadFontResult
LoadFontReady ->
        ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
fontData

createFont :: ByteString -> Int -> IO FontData
createFont :: ByteString -> Int -> IO FontData
createFont ByteString
fontSource Int
fontIndex =
  (FontData -> Ptr LoadFontState -> IO FontData) -> IO FontData
forall a. (FontData -> Ptr LoadFontState -> IO a) -> IO a
withLoader \FontData
font Ptr LoadFontState
statePtr -> do
    ByteString
-> Int
-> FontData
-> Ptr LoadFontState
-> IO (Either LoadFontError LoadFontResult)
loadFont ByteString
fontSource Int
fontIndex FontData
font Ptr LoadFontState
statePtr IO (Either LoadFontError LoadFontResult)
-> (Either LoadFontError LoadFontResult -> IO FontData)
-> IO FontData
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left LoadFontError
err ->
        [Char] -> IO FontData
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO FontData) -> [Char] -> IO FontData
forall a b. (a -> b) -> a -> b
$ LoadFontError -> [Char]
forall a. Show a => a -> [Char]
show LoadFontError
err
      Right LoadFontNeedsBlob{Int
scratchSize :: LoadFontResult -> Int
scratchSize :: Int
scratchSize, Int
outputSize :: LoadFontResult -> Int
outputSize :: Int
outputSize} -> do
        ByteString
blobData <- FontData -> Ptr LoadFontState -> Int -> Int -> IO ByteString
placeBlob FontData
font Ptr LoadFontState
statePtr Int
scratchSize Int
outputSize
        FontData -> IO FontData
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FontData
font{fontResources = [fontSource, blobData]}
      Right LoadFontResult
LoadFontReady ->
        FontData -> IO FontData
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FontData
font{fontResources = [fontSource]}

destroyFont :: FontData -> IO ()
destroyFont :: FontData -> IO ()
destroyFont FontData
font = FontData -> (Font -> IO ()) -> IO ()
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
font Font -> IO ()
ShapeDirect.kbts_FreeFont

-- | Haskell-owned font data
data FontData = FontData
 { FontData -> ForeignPtr Word8
fontData :: ForeignPtr Word8
 , FontData -> [ByteString]
fontResources :: [ByteString]
 }
  deriving (FontData -> FontData -> Bool
(FontData -> FontData -> Bool)
-> (FontData -> FontData -> Bool) -> Eq FontData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FontData -> FontData -> Bool
== :: FontData -> FontData -> Bool
$c/= :: FontData -> FontData -> Bool
/= :: FontData -> FontData -> Bool
Eq, Int -> FontData -> ShowS
[FontData] -> ShowS
FontData -> [Char]
(Int -> FontData -> ShowS)
-> (FontData -> [Char]) -> ([FontData] -> ShowS) -> Show FontData
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FontData -> ShowS
showsPrec :: Int -> FontData -> ShowS
$cshow :: FontData -> [Char]
show :: FontData -> [Char]
$cshowList :: [FontData] -> ShowS
showList :: [FontData] -> ShowS
Show)

-- | Use the font handle from a loaded font
withFontData :: FontData -> (Handles.Font -> IO r) -> IO r
withFontData :: forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData{ForeignPtr Word8
fontData :: FontData -> ForeignPtr Word8
fontData :: ForeignPtr Word8
fontData} Font -> IO r
action = ForeignPtr Word8 -> (Ptr Word8 -> IO r) -> IO r
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fontData (Font -> IO r
action (Font -> IO r) -> (Ptr Word8 -> Font) -> Ptr Word8 -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Font -> Font
Handles.Font (Ptr Font -> Font) -> (Ptr Word8 -> Ptr Font) -> Ptr Word8 -> Font
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> Ptr Font
forall a b. Ptr a -> Ptr b
castPtr)

getFontInfo :: Handles.Font -> IO Info
getFontInfo :: Font -> IO Info
getFontInfo Font
font =
  (Ptr FontInfo -> IO Info) -> IO Info
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr FontInfo
fontInfoPtr -> do
    Font -> Ptr FontInfo -> IO ()
ShapeDirect.kbts_GetFontInfo Font
font Ptr FontInfo
fontInfoPtr
    Structs.FontInfo{strings :: FontInfo -> [Ptr CChar]
strings=[Ptr CChar]
stringsArray, [Word16]
FontWidth
FontWeight
FontStyleFlags
stringLengths :: [Word16]
styleFlags :: FontStyleFlags
weight :: FontWeight
width :: FontWidth
width :: FontInfo -> FontWidth
weight :: FontInfo -> FontWeight
styleFlags :: FontInfo -> FontStyleFlags
stringLengths :: FontInfo -> [Word16]
..} <- Ptr FontInfo -> IO FontInfo
forall a. Storable a => Ptr a -> IO a
peek Ptr FontInfo
fontInfoPtr
    [(FontInfoStringId, Text)]
strings <- [Maybe (FontInfoStringId, Text)] -> [(FontInfoStringId, Text)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (FontInfoStringId, Text)] -> [(FontInfoStringId, Text)])
-> IO [Maybe (FontInfoStringId, Text)]
-> IO [(FontInfoStringId, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Ptr CChar) -> Word16 -> IO (Maybe (FontInfoStringId, Text)))
-> [(Int, Ptr CChar)]
-> [Word16]
-> IO [Maybe (FontInfoStringId, Text)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Int, Ptr CChar) -> Word16 -> IO (Maybe (FontInfoStringId, Text))
forall {a}.
Integral a =>
(Int, Ptr CChar) -> a -> IO (Maybe (FontInfoStringId, Text))
loadStrings ([Int] -> [Ptr CChar] -> [(Int, Ptr CChar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
Enums.FONT_INFO_STRING_ID_COUNT Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Ptr CChar]
stringsArray) [Word16]
stringLengths
    Info -> IO Info
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Info{[(FontInfoStringId, Text)]
FontWidth
FontWeight
FontStyleFlags
styleFlags :: FontStyleFlags
weight :: FontWeight
width :: FontWidth
strings :: [(FontInfoStringId, Text)]
width :: FontWidth
weight :: FontWeight
styleFlags :: FontStyleFlags
strings :: [(FontInfoStringId, Text)]
..}
  where
    loadStrings :: (Int, Ptr CChar) -> a -> IO (Maybe (FontInfoStringId, Text))
loadStrings (Int
ix, Ptr CChar
ptr) = \case
      a
0 -> Maybe (FontInfoStringId, Text)
-> IO (Maybe (FontInfoStringId, Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FontInfoStringId, Text)
forall a. Maybe a
Nothing
      a
len -> (FontInfoStringId, Text) -> Maybe (FontInfoStringId, Text)
forall a. a -> Maybe a
Just ((FontInfoStringId, Text) -> Maybe (FontInfoStringId, Text))
-> (Text -> (FontInfoStringId, Text))
-> Text
-> Maybe (FontInfoStringId, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> FontInfoStringId
Enums.FontInfoStringId Int
ix,) (Text -> Maybe (FontInfoStringId, Text))
-> IO Text -> IO (Maybe (FontInfoStringId, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO Text
Text.peekCStringLen (Ptr CChar
ptr, a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len)

data Info = Info
  { Info -> [(FontInfoStringId, Text)]
strings :: [(Enums.FontInfoStringId, Text)]
  , Info -> FontStyleFlags
styleFlags :: Flags.FontStyleFlags
  , Info -> FontWeight
weight :: Enums.FontWeight
  , Info -> FontWidth
width :: Enums.FontWidth
  }
  deriving (Info -> Info -> Bool
(Info -> Info -> Bool) -> (Info -> Info -> Bool) -> Eq Info
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Info -> Info -> Bool
== :: Info -> Info -> Bool
$c/= :: Info -> Info -> Bool
/= :: Info -> Info -> Bool
Eq, Int -> Info -> ShowS
[Info] -> ShowS
Info -> [Char]
(Int -> Info -> ShowS)
-> (Info -> [Char]) -> ([Info] -> ShowS) -> Show Info
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Info -> ShowS
showsPrec :: Int -> Info -> ShowS
$cshow :: Info -> [Char]
show :: Info -> [Char]
$cshowList :: [Info] -> ShowS
showList :: [Info] -> ShowS
Show)

{- | Scaling factor to go from font-specific Em units to a cap-height normalized units.

This results in more consistent font sizing when using multiple fonts.
You may even have a chance to align something vertically!
-}
{-# INLINE emToCaps #-}
emToCaps :: Fractional a => Handles.Font -> a
emToCaps :: forall a. Fractional a => Font -> a
emToCaps Font
font = Font -> a
forall a. Num a => Font -> a
unitsPerEm Font
font a -> a -> a
forall a. Fractional a => a -> a -> a
/ Font -> a
forall a. Num a => Font -> a
capHeight Font
font

-- | Get the height of font's capital letters, in the font's logical units.
{-# INLINE capHeight #-}
capHeight :: Num a => Handles.Font -> a
capHeight :: forall a. Num a => Font -> a
capHeight = Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> a) -> (Font -> Word16) -> Font -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> Word16
Other.hs_GetCapHeight

-- | Get the font's "Em square" size, in the font's logical units.
{-# INLINE unitsPerEm #-}
unitsPerEm :: Num a => Handles.Font -> a
unitsPerEm :: forall a. Num a => Font -> a
unitsPerEm = Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> a) -> (Font -> Word16) -> Font -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> Word16
Other.hs_GetUnitsPerEm

withLoader :: (FontData -> Ptr ShapeDirect.LoadFontState -> IO a) -> IO a
withLoader :: forall a. (FontData -> Ptr LoadFontState -> IO a) -> IO a
withLoader FontData -> Ptr LoadFontState -> IO a
action = do
  ForeignPtr Word8
fontData <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
Handles.sizeOfFontData
  let font :: FontData
font = FontData{ForeignPtr Word8
fontData :: ForeignPtr Word8
fontData :: ForeignPtr Word8
fontData, fontResources :: [ByteString]
fontResources = []}
  FontData -> (Font -> IO ()) -> IO ()
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
font \(Handles.Font Ptr Font
fontPtr) ->
    Ptr Font -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr Font
fontPtr Word8
0x00 Int
Handles.sizeOfFontData
  (Ptr LoadFontState -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr LoadFontState
statePtr -> do
    Ptr LoadFontState -> Word8 -> Int -> IO ()
forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr LoadFontState
statePtr Word8
0x00 (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ LoadFontState -> Int
forall a. Storable a => a -> Int
sizeOf (LoadFontState
forall a. HasCallStack => a
undefined :: ShapeDirect.LoadFontState)
    FontData -> Ptr LoadFontState -> IO a
action FontData
font Ptr LoadFontState
statePtr

data LoadFontResult
  = LoadFontReady
  | LoadFontNeedsBlob { LoadFontResult -> Int
scratchSize :: Int, LoadFontResult -> Int
outputSize :: Int}

loadFont
  :: ByteString
  -> Int
  -> FontData
  -> Ptr ShapeDirect.LoadFontState
  -> IO (Either Enums.LoadFontError LoadFontResult)
loadFont :: ByteString
-> Int
-> FontData
-> Ptr LoadFontState
-> IO (Either LoadFontError LoadFontResult)
loadFont ByteString
ttfData Int
fontIndex FontData
font Ptr LoadFontState
statePtr =
  FontData
-> (Font -> IO (Either LoadFontError LoadFontResult))
-> IO (Either LoadFontError LoadFontResult)
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
font \Font
fontPtr ->
    (Ptr Int -> IO (Either LoadFontError LoadFontResult))
-> IO (Either LoadFontError LoadFontResult)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr Int
scratchSizePtr ->
      (Ptr Int -> IO (Either LoadFontError LoadFontResult))
-> IO (Either LoadFontError LoadFontResult)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr Int
outputSizePtr ->
        ByteString
-> (CStringLen -> IO (Either LoadFontError LoadFontResult))
-> IO (Either LoadFontError LoadFontResult)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
ByteString.unsafeUseAsCStringLen ByteString
ttfData \(Ptr CChar
ttfDataPtr, Int
ttfDataSize) -> do
          LoadFontError
err <- Font
-> Ptr LoadFontState
-> Ptr ()
-> CInt
-> CInt
-> Ptr Int
-> Ptr Int
-> IO LoadFontError
ShapeDirect.kbts_LoadFont
            Font
fontPtr
            Ptr LoadFontState
statePtr
            (Ptr CChar -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ttfDataPtr)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ttfDataSize)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fontIndex)
            Ptr Int
scratchSizePtr
            Ptr Int
outputSizePtr
          case LoadFontError
err of
            LoadFontError
Enums.LOAD_FONT_ERROR_NONE ->
              Either LoadFontError LoadFontResult
-> IO (Either LoadFontError LoadFontResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LoadFontError LoadFontResult
 -> IO (Either LoadFontError LoadFontResult))
-> Either LoadFontError LoadFontResult
-> IO (Either LoadFontError LoadFontResult)
forall a b. (a -> b) -> a -> b
$ LoadFontResult -> Either LoadFontError LoadFontResult
forall a b. b -> Either a b
Right LoadFontResult
LoadFontReady
            LoadFontError
Enums.LOAD_FONT_ERROR_NEED_TO_CREATE_BLOB -> do
              Int
scratchSize <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
scratchSizePtr
              Int
outputSize <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
outputSizePtr
              Either LoadFontError LoadFontResult
-> IO (Either LoadFontError LoadFontResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LoadFontError LoadFontResult
 -> IO (Either LoadFontError LoadFontResult))
-> Either LoadFontError LoadFontResult
-> IO (Either LoadFontError LoadFontResult)
forall a b. (a -> b) -> a -> b
$ LoadFontResult -> Either LoadFontError LoadFontResult
forall a b. b -> Either a b
Right LoadFontNeedsBlob{Int
scratchSize :: Int
outputSize :: Int
scratchSize :: Int
outputSize :: Int
..}
            LoadFontError
_ ->
              Either LoadFontError LoadFontResult
-> IO (Either LoadFontError LoadFontResult)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LoadFontError LoadFontResult
 -> IO (Either LoadFontError LoadFontResult))
-> Either LoadFontError LoadFontResult
-> IO (Either LoadFontError LoadFontResult)
forall a b. (a -> b) -> a -> b
$ LoadFontError -> Either LoadFontError LoadFontResult
forall a b. a -> Either a b
Left LoadFontError
err

placeBlob :: FontData -> Ptr ShapeDirect.LoadFontState -> Int -> Int -> IO ByteString
placeBlob :: FontData -> Ptr LoadFontState -> Int -> Int -> IO ByteString
placeBlob FontData
font Ptr LoadFontState
statePtr Int
scratchSize Int
outputSize =
  Int -> (Ptr () -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
scratchSize \Ptr ()
scratchPtr -> do
    ForeignPtr Word8
outputData <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
outputSize
    ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
outputData \Ptr Word8
outputPtr ->
      FontData -> (Font -> IO ByteString) -> IO ByteString
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
font \Font
fontPtr -> do
        LoadFontError
err <- Font -> Ptr LoadFontState -> Ptr () -> Ptr () -> IO LoadFontError
ShapeDirect.kbts_PlaceBlob Font
fontPtr Ptr LoadFontState
statePtr Ptr ()
scratchPtr (Ptr Word8 -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
outputPtr)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LoadFontError
err LoadFontError -> LoadFontError -> Bool
forall a. Eq a => a -> a -> Bool
/= LoadFontError
Enums.LOAD_FONT_ERROR_NONE) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ LoadFontError -> [Char]
forall a. Show a => a -> [Char]
show LoadFontError
err
        ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! ForeignPtr Word8 -> Int -> ByteString
ByteString.fromForeignPtr0 ForeignPtr Word8
outputData Int
outputSize