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

  , Font(..)
  , allocate
  ) 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.Vulkan.Types (MonadVulkan, Queues)
import Resource.Font.EvanW qualified as EvanW
import Resource.Source (Source)
import Resource.Texture (Texture, Flat)
import Resource.Texture.Ktx2 qualified as Ktx2

-- * General collection tools

data Config = Config
  { Config -> Source
configContainer :: Source
  , Config -> Source
configTexture   :: Source
  }
  deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)

collectionTextures :: Foldable collection => collection Font -> Vector (Texture Flat)
collectionTextures :: forall (collection :: * -> *).
Foldable collection =>
collection Font -> Vector (Texture Flat)
collectionTextures = [Texture Flat] -> Vector (Texture Flat)
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList ([Texture Flat] -> Vector (Texture Flat))
-> (collection Font -> [Texture Flat])
-> collection Font
-> Vector (Texture Flat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Font -> Texture Flat) -> [Font] -> [Texture Flat]
forall a b. (a -> b) -> [a] -> [b]
map Font -> Texture Flat
texture ([Font] -> [Texture Flat])
-> (collection Font -> [Font]) -> collection Font -> [Texture Flat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. collection Font -> [Font]
forall a. collection a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- * Individual fonts

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

allocate
  :: ( HasCallStack
     , MonadVulkan env m
     , HasLogFunc env
     , MonadThrow m
     , Resource.MonadResource m
     )
  => Queues Vk.CommandPool
  -> Config
  -> m Font
allocate :: forall env (m :: * -> *).
(HasCallStack, MonadVulkan env m, HasLogFunc env, MonadThrow m,
 MonadResource m) =>
Queues CommandPool -> Config -> m Font
allocate Queues CommandPool
pools Config{Source
$sel:configContainer:Config :: Config -> Source
$sel:configTexture:Config :: Config -> Source
configContainer :: Source
configTexture :: Source
..} = do
  Container
container <- (HasCallStack => m Container) -> m Container
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m Container) -> m Container)
-> (HasCallStack => m Container) -> m Container
forall a b. (a -> b) -> a -> b
$
    Source -> m Container
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Source -> m Container
EvanW.load Source
configContainer

  Texture Flat
texture <- (HasCallStack => m (Texture Flat)) -> m (Texture Flat)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (Texture Flat)) -> m (Texture Flat))
-> (HasCallStack => m (Texture Flat)) -> m (Texture Flat)
forall a b. (a -> b) -> a -> b
$
    Queues CommandPool -> Source -> m (Texture Flat)
forall a env (m :: * -> *).
(TextureLayers a, MonadVulkan env m, MonadResource m, MonadThrow m,
 HasLogFunc env, Typeable a, HasCallStack) =>
Queues CommandPool -> Source -> m (Texture a)
Ktx2.load Queues CommandPool
pools Source
configTexture

  pure Font{Texture Flat
Container
$sel:texture:Font :: Texture Flat
$sel:container:Font :: Container
container :: Container
texture :: Texture Flat
..}