module Codec.Ktx2.Font where

import Codec.Compression.Zstd qualified as Zstd
import Codec.Ktx.KeyValue qualified as KVD
import Codec.Ktx2 qualified as Ktx2
import Codec.Ktx2.Read qualified as Ktx2
import Codec.Ktx2.Write qualified as Ktx2
import Control.Concurrent (MVar, newMVar, takeMVar)
import Control.Exception (bracket)
import Control.Monad
import Data.Aeson (encode, eitherDecodeFileStrict, eitherDecodeStrict)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.Foldable (toList)
import Data.IntMap (IntMap)
import Data.IntMap qualified as IntMap
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Traversable (for)
import Data.Vector.Generic qualified as Vector
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import GHC.Generics (Generic, Generic1)
import Graphics.MSDF.Atlas.Compact (Compact, compact)
import Graphics.MSDF.Atlas.Compact qualified as Compact
import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.FFI.Enums qualified as KBTS
import KB.Text.Shape.FFI.Handles (Font(..), intHandle)
import KB.Text.Shape.Font (FontData(..), createFont, destroyFont, withFontData)
import KB.Text.Shape.Font qualified as Font

pattern KTX_KEY_atlas :: Text
pattern $mKTX_KEY_atlas :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTX_KEY_atlas :: Text
KTX_KEY_atlas = "msdf-atlas"

pattern KTX_KEY_kbts :: Text
pattern $mKTX_KEY_kbts :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTX_KEY_kbts :: Text
KTX_KEY_kbts = "kbts-blob"

pattern KTX_KEY_kbts_version :: Text
pattern $mKTX_KEY_kbts_version :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTX_KEY_kbts_version :: Text
KTX_KEY_kbts_version = "kbts-version"

kbtsVersion :: Text
kbtsVersion :: Text
kbtsVersion = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
forall a. Show a => a -> String
show Version
KBTS.VERSION_CURRENT String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BlobVersion -> String
forall a. Show a => a -> String
show BlobVersion
KBTS.BLOB_VERSION_CURRENT

bundleFont
  :: FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> IO ()
bundleFont :: String -> String -> String -> String -> IO ()
bundleFont String
pathTtf String
pathJson String
pathKtx2 String
pathKtxf = do
  -- Layout{atlas=Atlas{aType}, glyphs} <- eitherDecodeFileStrict pathJson >>= either fail pure
  layout <- String -> IO (Either String Layout)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict String
pathJson IO (Either String Layout)
-> (Either String Layout -> IO Layout) -> IO Layout
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Layout)
-> (Layout -> IO Layout) -> Either String Layout -> IO Layout
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Layout
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Layout -> IO Layout
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  ttfData <- ByteString.readFile pathTtf
  kbtsData <- Font.extractBlob ttfData 0

  font <- createFont kbtsData 0
  capsScale <- withFontData font $ pure . Font.emToCaps
  destroyFont font

  sourceKtx <- Ktx2.fromFile pathKtx2
  let
    atlas = Float -> Compact -> Compact
capScalePlanes Float
capsScale (Compact -> Compact) -> Compact -> Compact
forall a b. (a -> b) -> a -> b
$ Layout -> Compact
compact Layout
layout
    atlasData = LazyByteString -> ByteString
ByteString.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Compact -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode Compact
atlas
    kvd =
      -- TODO: record atlas type (softmask, msdf, etc)
      -- Map.insert KTX_KEY_writer (KVD.text "msdf-atlas-0.1.0.0 / ktx-codec-0.0.2.1") $
      Text -> ByteString -> KeyValueData -> KeyValueData
KVD.insertBytes Text
KTX_KEY_atlas (Int -> ByteString -> ByteString
Zstd.compress Int
19 ByteString
atlasData) (KeyValueData -> KeyValueData) -> KeyValueData -> KeyValueData
forall a b. (a -> b) -> a -> b
$
      Text -> ByteString -> KeyValueData -> KeyValueData
KVD.insertBytes Text
KTX_KEY_kbts (Int -> ByteString -> ByteString
Zstd.compress Int
19 ByteString
kbtsData) (KeyValueData -> KeyValueData) -> KeyValueData -> KeyValueData
forall a b. (a -> b) -> a -> b
$
      Text -> Text -> KeyValueData -> KeyValueData
KVD.insertText Text
KTX_KEY_kbts_version Text
kbtsVersion (KeyValueData -> KeyValueData) -> KeyValueData -> KeyValueData
forall a b. (a -> b) -> a -> b
$ -- TODO: get from lib"
      (Text -> Text) -> KeyValueData -> KeyValueData
KVD.setWriterWith (Text
"ktx-font 0.1.0.0 / " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) Ktx2
sourceKtx.kvd
  Ktx2.toFile pathKtxf sourceKtx{Ktx2.kvd}

-- | Rescale planes to caps height instead of ems.
capScalePlanes :: Float -> Compact -> Compact
capScalePlanes :: Float -> Compact -> Compact
capScalePlanes Float
capsScale Compact
a = Compact
a
  { Compact._size = a._size / capsScale
  , Compact.planes = Vector.map (Compact.scaleBox capsScale) a.planes
  }

{- | Put already-loaded font to context.

The context will NOT keep a fontData reference.
-}
pushBundleFont :: TextShape.Context -> Bundle -> IO Int
pushBundleFont :: Context -> Bundle -> IO Int
pushBundleFont Context
ctx Bundle{FontData
fontData :: FontData
fontData :: Bundle -> FontData
fontData} =
  FontData -> (Font -> IO Int) -> IO Int
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
fontData ((Font -> IO Int) -> IO Int) -> (Font -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ Context -> Font -> IO Int
TextShape.pushFont Context
ctx

data Bundle = Bundle
  { Bundle -> FontData
fontData :: FontData -- ^ The bundle holds the font memory too.
  , Bundle -> Compact
atlas :: Compact -- ^ Glyph atlas data for the texture.
  }
  deriving (Bundle -> Bundle -> Bool
(Bundle -> Bundle -> Bool)
-> (Bundle -> Bundle -> Bool) -> Eq Bundle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bundle -> Bundle -> Bool
== :: Bundle -> Bundle -> Bool
$c/= :: Bundle -> Bundle -> Bool
/= :: Bundle -> Bundle -> Bool
Eq)

loadBundleFile :: FilePath -> IO Bundle
loadBundleFile :: String -> IO Bundle
loadBundleFile String
fontFile =
  IO FileContext
-> (FileContext -> IO ())
-> (FileContext -> IO Bundle)
-> IO Bundle
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO FileContext
forall (io :: * -> *). MonadIO io => String -> io FileContext
Ktx2.open String
fontFile) FileContext -> IO ()
forall (io :: * -> *). MonadIO io => FileContext -> io ()
Ktx2.close FileContext -> IO Bundle
forall a. ReadChunk a => Context a -> IO Bundle
loadBundle

loadBundleBytes :: ByteString -> IO Bundle
loadBundleBytes :: ByteString -> IO Bundle
loadBundleBytes ByteString
bytes =
  ByteString -> IO BytesContext
forall (io :: * -> *). MonadIO io => ByteString -> io BytesContext
Ktx2.bytes ByteString
bytes IO BytesContext -> (BytesContext -> IO Bundle) -> IO Bundle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BytesContext -> IO Bundle
forall a. ReadChunk a => Context a -> IO Bundle
loadBundle

loadBundle :: Ktx2.ReadChunk a => Ktx2.Context a -> IO Bundle
loadBundle :: forall a. ReadChunk a => Context a -> IO Bundle
loadBundle Context a
ktx = do
  kvd <- Context a -> IO KeyValueData
forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io KeyValueData
Ktx2.keyValueData Context a
ktx
  let
    bundled = (,,)
      (ByteString
 -> ByteString -> Text -> (ByteString, ByteString, Text))
-> Maybe ByteString
-> Maybe (ByteString -> Text -> (ByteString, ByteString, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> KeyValueData -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
KTX_KEY_atlas KeyValueData
kvd Maybe Value -> (Value -> Maybe ByteString) -> Maybe ByteString
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe ByteString
forall a. FromValue a => Value -> Maybe a
KVD.fromValue)
      Maybe (ByteString -> Text -> (ByteString, ByteString, Text))
-> Maybe ByteString
-> Maybe (Text -> (ByteString, ByteString, Text))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> KeyValueData -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
KTX_KEY_kbts KeyValueData
kvd Maybe Value -> (Value -> Maybe ByteString) -> Maybe ByteString
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe ByteString
forall a. FromValue a => Value -> Maybe a
KVD.fromValue)
      Maybe (Text -> (ByteString, ByteString, Text))
-> Maybe Text -> Maybe (ByteString, ByteString, Text)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> KeyValueData -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
KTX_KEY_kbts_version KeyValueData
kvd Maybe Value -> (Value -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Text
forall a. FromValue a => Value -> Maybe a
KVD.fromValue)

  (mtsdfZstd, kbtsZstd, kbtsVer) <-
    case bundled of
      Maybe (ByteString, ByteString, Text)
Nothing ->
        String -> IO (ByteString, ByteString, Text)
forall a. HasCallStack => String -> a
error String
"Missing KTXF metadata"
      Just (ByteString, ByteString, Text)
compressed ->
        (ByteString, ByteString, Text) -> IO (ByteString, ByteString, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString, ByteString, Text)
compressed

  unless (kbtsVer == kbtsVersion) $
    error $ "KBTS blob version mismatch: " <> show kbtsVer <> ", expected " <> show kbtsVersion

  atlas <-
    case Zstd.decompress mtsdfZstd of
      Zstd.Decompress ByteString
json ->
        (String -> IO Compact)
-> (Compact -> IO Compact) -> Either String Compact -> IO Compact
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Compact
forall a. HasCallStack => String -> a
error Compact -> IO Compact
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Compact -> IO Compact)
-> Either String Compact -> IO Compact
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Compact
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict ByteString
json
      Decompress
Zstd.Skip ->
        String -> IO Compact
forall a. HasCallStack => String -> a
error String
"Empty atlas data"
      Zstd.Error String
err ->
        String -> IO Compact
forall a. HasCallStack => String -> a
error (String -> IO Compact) -> String -> IO Compact
forall a b. (a -> b) -> a -> b
$ String
"Atlas decompression error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err

  fontData <-
    case Zstd.decompress kbtsZstd of
      Zstd.Decompress ByteString
fontData ->
        ByteString -> Int -> IO FontData
createFont ByteString
fontData Int
0
      Decompress
Zstd.Skip ->
        String -> IO FontData
forall a. HasCallStack => String -> a
error (String -> IO FontData) -> String -> IO FontData
forall a b. (a -> b) -> a -> b
$ String
"Empty font data"
      Zstd.Error String
err ->
        String -> IO FontData
forall a. HasCallStack => String -> a
error (String -> IO FontData) -> String -> IO FontData
forall a b. (a -> b) -> a -> b
$ String
"Font decompression error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err

  pure Bundle{..}

freeBundle :: Bundle -> IO ()
freeBundle :: Bundle -> IO ()
freeBundle Bundle{FontData
fontData :: Bundle -> FontData
fontData :: FontData
fontData} = FontData -> IO ()
destroyFont FontData
fontData

-- * Shaping contexts

data StackContext a = StackContext
  { forall a. StackContext a -> MVar Context
shapeContext :: MVar TextShape.Context
  , forall a. StackContext a -> IntMap a
bundled :: IntMap a
  , forall a. StackContext a -> IntMap Compact
atlases :: IntMap Compact -- XXX: Font.Handle ~ Ptr Font.Handle ~ Int
  }
  deriving stock ((forall a b. (a -> b) -> StackContext a -> StackContext b)
-> (forall a b. a -> StackContext b -> StackContext a)
-> Functor StackContext
forall a b. a -> StackContext b -> StackContext a
forall a b. (a -> b) -> StackContext a -> StackContext b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> StackContext a -> StackContext b
fmap :: forall a b. (a -> b) -> StackContext a -> StackContext b
$c<$ :: forall a b. a -> StackContext b -> StackContext a
<$ :: forall a b. a -> StackContext b -> StackContext a
Functor, (forall m. Monoid m => StackContext m -> m)
-> (forall m a. Monoid m => (a -> m) -> StackContext a -> m)
-> (forall m a. Monoid m => (a -> m) -> StackContext a -> m)
-> (forall a b. (a -> b -> b) -> b -> StackContext a -> b)
-> (forall a b. (a -> b -> b) -> b -> StackContext a -> b)
-> (forall b a. (b -> a -> b) -> b -> StackContext a -> b)
-> (forall b a. (b -> a -> b) -> b -> StackContext a -> b)
-> (forall a. (a -> a -> a) -> StackContext a -> a)
-> (forall a. (a -> a -> a) -> StackContext a -> a)
-> (forall a. StackContext a -> [a])
-> (forall a. StackContext a -> Bool)
-> (forall a. StackContext a -> Int)
-> (forall a. Eq a => a -> StackContext a -> Bool)
-> (forall a. Ord a => StackContext a -> a)
-> (forall a. Ord a => StackContext a -> a)
-> (forall a. Num a => StackContext a -> a)
-> (forall a. Num a => StackContext a -> a)
-> Foldable StackContext
forall a. Eq a => a -> StackContext a -> Bool
forall a. Num a => StackContext a -> a
forall a. Ord a => StackContext a -> a
forall m. Monoid m => StackContext m -> m
forall a. StackContext a -> Bool
forall a. StackContext a -> Int
forall a. StackContext a -> [a]
forall a. (a -> a -> a) -> StackContext a -> a
forall m a. Monoid m => (a -> m) -> StackContext a -> m
forall b a. (b -> a -> b) -> b -> StackContext a -> b
forall a b. (a -> b -> b) -> b -> StackContext a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => StackContext m -> m
fold :: forall m. Monoid m => StackContext m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> StackContext a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> StackContext a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> StackContext a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> StackContext a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> StackContext a -> b
foldr :: forall a b. (a -> b -> b) -> b -> StackContext a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> StackContext a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> StackContext a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> StackContext a -> b
foldl :: forall b a. (b -> a -> b) -> b -> StackContext a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> StackContext a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> StackContext a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> StackContext a -> a
foldr1 :: forall a. (a -> a -> a) -> StackContext a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> StackContext a -> a
foldl1 :: forall a. (a -> a -> a) -> StackContext a -> a
$ctoList :: forall a. StackContext a -> [a]
toList :: forall a. StackContext a -> [a]
$cnull :: forall a. StackContext a -> Bool
null :: forall a. StackContext a -> Bool
$clength :: forall a. StackContext a -> Int
length :: forall a. StackContext a -> Int
$celem :: forall a. Eq a => a -> StackContext a -> Bool
elem :: forall a. Eq a => a -> StackContext a -> Bool
$cmaximum :: forall a. Ord a => StackContext a -> a
maximum :: forall a. Ord a => StackContext a -> a
$cminimum :: forall a. Ord a => StackContext a -> a
minimum :: forall a. Ord a => StackContext a -> a
$csum :: forall a. Num a => StackContext a -> a
sum :: forall a. Num a => StackContext a -> a
$cproduct :: forall a. Num a => StackContext a -> a
product :: forall a. Num a => StackContext a -> a
Foldable, Functor StackContext
Foldable StackContext
(Functor StackContext, Foldable StackContext) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> StackContext a -> f (StackContext b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    StackContext (f a) -> f (StackContext a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> StackContext a -> m (StackContext b))
-> (forall (m :: * -> *) a.
    Monad m =>
    StackContext (m a) -> m (StackContext a))
-> Traversable StackContext
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
StackContext (m a) -> m (StackContext a)
forall (f :: * -> *) a.
Applicative f =>
StackContext (f a) -> f (StackContext a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StackContext a -> m (StackContext b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StackContext a -> f (StackContext b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StackContext a -> f (StackContext b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> StackContext a -> f (StackContext b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
StackContext (f a) -> f (StackContext a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
StackContext (f a) -> f (StackContext a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StackContext a -> m (StackContext b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> StackContext a -> m (StackContext b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
StackContext (m a) -> m (StackContext a)
sequence :: forall (m :: * -> *) a.
Monad m =>
StackContext (m a) -> m (StackContext a)
Traversable, (forall x. StackContext a -> Rep (StackContext a) x)
-> (forall x. Rep (StackContext a) x -> StackContext a)
-> Generic (StackContext a)
forall x. Rep (StackContext a) x -> StackContext a
forall x. StackContext a -> Rep (StackContext a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (StackContext a) x -> StackContext a
forall a x. StackContext a -> Rep (StackContext a) x
$cfrom :: forall a x. StackContext a -> Rep (StackContext a) x
from :: forall x. StackContext a -> Rep (StackContext a) x
$cto :: forall a x. Rep (StackContext a) x -> StackContext a
to :: forall x. Rep (StackContext a) x -> StackContext a
Generic, (forall a. StackContext a -> Rep1 StackContext a)
-> (forall a. Rep1 StackContext a -> StackContext a)
-> Generic1 StackContext
forall a. Rep1 StackContext a -> StackContext a
forall a. StackContext a -> Rep1 StackContext a
forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cfrom1 :: forall a. StackContext a -> Rep1 StackContext a
from1 :: forall a. StackContext a -> Rep1 StackContext a
$cto1 :: forall a. Rep1 StackContext a -> StackContext a
to1 :: forall a. Rep1 StackContext a -> StackContext a
Generic1)

{- | Create shaping context and push fonts from all the bundles.
-}
createStackContext :: Foldable t => t Bundle -> IO (StackContext ())
createStackContext :: forall (t :: * -> *).
Foldable t =>
t Bundle -> IO (StackContext ())
createStackContext t Bundle
bundles = do
  ctx <- IO Context
TextShape.createContext
  locals <- for (toList bundles) \Bundle{FontData
Compact
fontData :: Bundle -> FontData
atlas :: Bundle -> Compact
fontData :: FontData
atlas :: Compact
..} ->
    FontData -> (Font -> IO (Int, Compact)) -> IO (Int, Compact)
forall r. FontData -> (Font -> IO r) -> IO r
withFontData FontData
fontData \Font
font -> do
      _refs <- Context -> Font -> IO Int
TextShape.pushFont Context
ctx Font
font
      pure (intHandle font, atlas)
  let atlases = [(Int, Compact)] -> IntMap Compact
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, Compact)]
locals
  let bundled = (Compact -> ()) -> IntMap Compact -> IntMap ()
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (() -> Compact -> ()
forall a b. a -> b -> a
const ()) IntMap Compact
atlases
  shapeContext <- newMVar ctx
  pure StackContext{..}

{- | Update font annotations with the bundle collection annotated with update functions.

This may be used to attach more information, e.g. after all fonts were assigned texture slots.

The update collection should be a superset of what was initially bundled.
Otherwise you may see missing things downstream.
-}
mapWithBundle :: Foldable t => t (Bundle, a -> b) -> StackContext a -> StackContext b
mapWithBundle :: forall (t :: * -> *) a b.
Foldable t =>
t (Bundle, a -> b) -> StackContext a -> StackContext b
mapWithBundle t (Bundle, a -> b)
bundles StackContext{bundled :: forall a. StackContext a -> IntMap a
bundled = IntMap a
old, MVar Context
IntMap Compact
shapeContext :: forall a. StackContext a -> MVar Context
atlases :: forall a. StackContext a -> IntMap Compact
shapeContext :: MVar Context
atlases :: IntMap Compact
..} = StackContext{bundled :: IntMap b
bundled = IntMap b
new, MVar Context
IntMap Compact
shapeContext :: MVar Context
atlases :: IntMap Compact
shapeContext :: MVar Context
atlases :: IntMap Compact
..}
  where
    new :: IntMap b
new = [(Int, b)] -> IntMap b
forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
      (Bundle{fontData=Font.FontData{fontData}}, f) <- t (Bundle, a -> b) -> [(Bundle, a -> b)]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Bundle, a -> b)
bundles
      let key = Ptr Word8 -> Int
forall h a. Coercible h (Ptr a) => h -> Int
intHandle (Ptr Word8 -> Int) -> Ptr Word8 -> Int
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Ptr Word8
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr Word8
fontData
      case IntMap.lookup key old of
        Maybe a
Nothing -> [(Int, b)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just a
a -> (Int, b) -> [(Int, b)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
key, a -> b
f a
a)

{- | Destroy shaping context.

NB: Does NOT free the fonts as they may be shared with other stacks. Use `freeBundle` for that.
-}
destroyStackContext :: StackContext a -> IO ()
destroyStackContext :: forall a. StackContext a -> IO ()
destroyStackContext StackContext{MVar Context
shapeContext :: forall a. StackContext a -> MVar Context
shapeContext :: MVar Context
shapeContext} = MVar Context -> IO Context
forall a. MVar a -> IO a
takeMVar MVar Context
shapeContext IO Context -> (Context -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> IO ()
TextShape.destroyContext

{-# INLINE lookupBundled #-}
lookupBundled :: Font -> StackContext a -> Maybe a
lookupBundled :: forall a. Font -> StackContext a -> Maybe a
lookupBundled Font
font StackContext{MVar Context
IntMap a
IntMap Compact
shapeContext :: forall a. StackContext a -> MVar Context
bundled :: forall a. StackContext a -> IntMap a
atlases :: forall a. StackContext a -> IntMap Compact
shapeContext :: MVar Context
bundled :: IntMap a
atlases :: IntMap Compact
..} = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (Font -> Int
forall h a. Coercible h (Ptr a) => h -> Int
intHandle Font
font) IntMap a
bundled

{-# INLINE lookupAtlas #-}
lookupAtlas :: Font -> StackContext a -> Maybe Compact
lookupAtlas :: forall a. Font -> StackContext a -> Maybe Compact
lookupAtlas Font
font StackContext{IntMap Compact
atlases :: forall a. StackContext a -> IntMap Compact
atlases :: IntMap Compact
atlases} = Int -> IntMap Compact -> Maybe Compact
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (Font -> Int
forall h a. Coercible h (Ptr a) => h -> Int
intHandle Font
font) IntMap Compact
atlases

mapBundled :: (a -> b) -> StackContext a -> StackContext b
mapBundled :: forall a b. (a -> b) -> StackContext a -> StackContext b
mapBundled a -> b
f ctx :: StackContext a
ctx@StackContext{IntMap a
bundled :: forall a. StackContext a -> IntMap a
bundled :: IntMap a
bundled} = StackContext a
ctx
  { bundled = IntMap.map f bundled
  }