keid-render-basic-0.1.2.0: src/Resource/Font.hs

module Resource.Font
  ( Config(..)
  , allocateCollection
  , collectionTextures

  , Font(..)
  , allocateFont

  ) where

import RIO

import GHC.Stack (withFrozenCallStack)
import RIO.Vector qualified as Vector
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk

import Engine.Types (StageRIO)
import Engine.Vulkan.Types (Queues)
import Resource.Font.EvanW qualified as EvanW
import Resource.Source (Source)
import Resource.Texture (Texture, Flat)
import Resource.Texture qualified as Texture
import Resource.Texture.Ktx1 qualified as Ktx1

-- * General collection tools

data Config = Config
  { configContainer :: Source
  , configTexture   :: Source
  }
  deriving (Show)

allocateCollection
  :: ( Traversable collection
     , HasCallStack
     )
  => Queues Vk.CommandPool
  -> collection Config
  -> StageRIO st (Resource.ReleaseKey, collection Font)
allocateCollection pools collection = do
  collected <- for collection $
    withFrozenCallStack $ allocateFont pools
  key <- Resource.register $ traverse_ Resource.release $ fmap fst collected
  pure (key, fmap snd collected)

collectionTextures :: Foldable collection => collection Font -> Vector (Texture Flat)
collectionTextures = Vector.fromList . map texture . toList

-- * Individual fonts

data Font = Font
  { container :: EvanW.Container
  , texture   :: Texture Flat
  }

allocateFont
  :: HasCallStack
  => Queues Vk.CommandPool
  -> Config
  -> StageRIO st (Resource.ReleaseKey, Font)
allocateFont pools Config{..} = do
  context <- ask

  container <- withFrozenCallStack $
    EvanW.load configContainer

  createTexture <- toIO . withFrozenCallStack $
    Ktx1.load pools configTexture

  (textureKey, texture) <- Resource.allocate
    createTexture
    (Texture.destroy context)

  pure (textureKey, Font{..})