module KB.Text.Shape.Font
  ( extractBlob

  , FontData(..)
  , withFontData
  , Handles.Font
  , createFont
  , destroyFont

  , getFontInfo
  , Structs.FontInfo

  , emToCaps
  , capHeight
  , unitsPerEm

  , 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 -> Int -> IO ByteString
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
        blobData <- FontData -> Ptr LoadFontState -> Int -> Int -> IO ByteString
placeBlob FontData
font Ptr LoadFontState
statePtr Int
scratchSize Int
outputSize
        pure 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

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=stringsArray, ..} <- Ptr FontInfo -> IO FontInfo
forall a. Storable a => Ptr a -> IO a
peek Ptr FontInfo
fontInfoPtr
    strings <- catMaybes <$> zipWithM loadStrings (zip [0..Enums.FONT_INFO_STRING_ID_COUNT - 1] stringsArray) stringLengths
    pure Info{..}
  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

-- | 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)

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)

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
  fontData <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
Handles.sizeOfFontData
  let font = FontData{ForeignPtr Word8
fontData :: ForeignPtr Word8
fontData :: ForeignPtr Word8
fontData, fontResources :: [ByteString]
fontResources = []}
  withFontData 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
  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
          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 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
              scratchSize <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
scratchSizePtr
              outputSize <- peek outputSizePtr
              pure $ Right LoadFontNeedsBlob{..}
            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
    outputData <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
outputSize
    withForeignPtr outputData \Ptr Word8
outputPtr ->
      FontData -> (Font -> IO ByteString) -> IO ByteString
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
font \Font
fontPtr -> do
        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)
        when (err /= Enums.LOAD_FONT_ERROR_NONE) $
          error $ show err
        pure $! ByteString.fromForeignPtr0 outputData outputSize