Font.hs

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 fontData fontIndex =
  withLoader \font statePtr -> do
    loadFont fontData fontIndex font statePtr >>= \case
      Left err ->
        error $ show err
      Right LoadFontNeedsBlob{scratchSize, outputSize} ->
        placeBlob font statePtr scratchSize outputSize
      Right LoadFontReady ->
        pure fontData

createFont :: ByteString -> Int -> IO FontData
createFont fontSource fontIndex =
  withLoader \font statePtr -> do
    loadFont fontSource fontIndex font statePtr >>= \case
      Left err ->
        error $ show err
      Right LoadFontNeedsBlob{scratchSize, outputSize} -> do
        blobData <- placeBlob font statePtr scratchSize outputSize
        pure font{fontResources = [fontSource, blobData]}
      Right LoadFontReady ->
        pure font{fontResources = [fontSource]}

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

-- | Haskell-owned font data
data FontData = FontData
 { fontData :: ForeignPtr Word8
 , fontResources :: [ByteString]
 }
  deriving (Eq, Show)

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

getFontInfo :: Handles.Font -> IO Info
getFontInfo font =
  alloca \fontInfoPtr -> do
    ShapeDirect.kbts_GetFontInfo font fontInfoPtr
    Structs.FontInfo{strings=stringsArray, ..} <- peek fontInfoPtr
    strings <- catMaybes <$> zipWithM loadStrings (zip [0..Enums.FONT_INFO_STRING_ID_COUNT - 1] stringsArray) stringLengths
    pure Info{..}
  where
    loadStrings (ix, ptr) = \case
      0 -> pure Nothing
      len -> Just . (Enums.FontInfoStringId ix,) <$> Text.peekCStringLen (ptr, fromIntegral len)

data Info = Info
  { strings :: [(Enums.FontInfoStringId, Text)]
  , styleFlags :: Flags.FontStyleFlags
  , weight :: Enums.FontWeight
  , width :: Enums.FontWidth
  }
  deriving (Eq, 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 font = unitsPerEm font / capHeight font

-- | Get the height of font's capital letters, in the font's logical units.
{-# INLINE capHeight #-}
capHeight :: Num a => Handles.Font -> a
capHeight = fromIntegral . 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 = fromIntegral . Other.hs_GetUnitsPerEm

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

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

loadFont
  :: ByteString
  -> Int
  -> FontData
  -> Ptr ShapeDirect.LoadFontState
  -> IO (Either Enums.LoadFontError LoadFontResult)
loadFont ttfData fontIndex font statePtr =
  withFontData font \fontPtr ->
    alloca \scratchSizePtr ->
      alloca \outputSizePtr ->
        ByteString.unsafeUseAsCStringLen ttfData \(ttfDataPtr, ttfDataSize) -> do
          err <- ShapeDirect.kbts_LoadFont
            fontPtr
            statePtr
            (castPtr ttfDataPtr)
            (fromIntegral ttfDataSize)
            (fromIntegral fontIndex)
            scratchSizePtr
            outputSizePtr
          case err of
            Enums.LOAD_FONT_ERROR_NONE ->
              pure $ Right LoadFontReady
            Enums.LOAD_FONT_ERROR_NEED_TO_CREATE_BLOB -> do
              scratchSize <- peek scratchSizePtr
              outputSize <- peek outputSizePtr
              pure $ Right LoadFontNeedsBlob{..}
            _ ->
              pure $ Left err

placeBlob :: FontData -> Ptr ShapeDirect.LoadFontState -> Int -> Int -> IO ByteString
placeBlob font statePtr scratchSize outputSize =
  allocaBytes scratchSize \scratchPtr -> do
    outputData <- mallocForeignPtrBytes outputSize
    withForeignPtr outputData \outputPtr ->
      withFontData font \fontPtr -> do
        err <- ShapeDirect.kbts_PlaceBlob fontPtr statePtr scratchPtr (castPtr outputPtr)
        when (err /= Enums.LOAD_FONT_ERROR_NONE) $
          error $ show err
        pure $! ByteString.fromForeignPtr0 outputData outputSize