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.Vulkan.Types (MonadVulkan, 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
  { 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
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

allocateCollection
  :: ( Traversable collection
     , MonadVulkan env m
     , HasLogFunc env
     , MonadThrow m
     , Resource.MonadResource m
     , HasCallStack
     )
  => Queues Vk.CommandPool
  -> collection Config
  -> m (Resource.ReleaseKey, collection Font)
allocateCollection :: forall (collection :: * -> *) env (m :: * -> *).
(Traversable collection, MonadVulkan env m, HasLogFunc env,
 MonadThrow m, MonadResource m, HasCallStack) =>
Queues CommandPool
-> collection Config -> m (ReleaseKey, collection Font)
allocateCollection Queues CommandPool
pools collection Config
collection = do
  collection (ReleaseKey, Font)
collected <- collection Config
-> (Config -> m (ReleaseKey, Font))
-> m (collection (ReleaseKey, Font))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for collection Config
collection ((Config -> m (ReleaseKey, Font))
 -> m (collection (ReleaseKey, Font)))
-> (Config -> m (ReleaseKey, Font))
-> m (collection (ReleaseKey, Font))
forall a b. (a -> b) -> a -> b
$
    (HasCallStack => Config -> m (ReleaseKey, Font))
-> Config -> m (ReleaseKey, Font)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Config -> m (ReleaseKey, Font))
 -> Config -> m (ReleaseKey, Font))
-> (HasCallStack => Config -> m (ReleaseKey, Font))
-> Config
-> m (ReleaseKey, Font)
forall a b. (a -> b) -> a -> b
$ Queues CommandPool -> Config -> m (ReleaseKey, Font)
forall env (m :: * -> *).
(HasCallStack, MonadVulkan env m, HasLogFunc env, MonadThrow m,
 MonadResource m) =>
Queues CommandPool -> Config -> m (ReleaseKey, Font)
allocateFont Queues CommandPool
pools
  ReleaseKey
key <- IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> m ReleaseKey) -> IO () -> m ReleaseKey
forall a b. (a -> b) -> a -> b
$ (ReleaseKey -> IO ()) -> collection ReleaseKey -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (collection ReleaseKey -> IO ()) -> collection ReleaseKey -> IO ()
forall a b. (a -> b) -> a -> b
$ ((ReleaseKey, Font) -> ReleaseKey)
-> collection (ReleaseKey, Font) -> collection ReleaseKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, Font) -> ReleaseKey
forall a b. (a, b) -> a
fst collection (ReleaseKey, Font)
collected
  pure (ReleaseKey
key, ((ReleaseKey, Font) -> Font)
-> collection (ReleaseKey, Font) -> collection Font
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, Font) -> Font
forall a b. (a, b) -> b
snd collection (ReleaseKey, Font)
collected)

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 (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- * Individual fonts

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

allocateFont
  :: ( HasCallStack
     , MonadVulkan env m
     , HasLogFunc env
     , MonadThrow m
     , Resource.MonadResource m
     )
  => Queues Vk.CommandPool
  -> Config
  -> m (Resource.ReleaseKey, Font)
allocateFont :: forall env (m :: * -> *).
(HasCallStack, MonadVulkan env m, HasLogFunc env, MonadThrow m,
 MonadResource m) =>
Queues CommandPool -> Config -> m (ReleaseKey, Font)
allocateFont Queues CommandPool
pools Config{Source
configTexture :: Source
configContainer :: Source
$sel:configTexture:Config :: Config -> Source
$sel:configContainer:Config :: Config -> Source
..} = do
  env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask

  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

  IO (Texture Flat)
createTexture <- m (Texture Flat) -> m (IO (Texture Flat))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (m (Texture Flat) -> m (IO (Texture Flat)))
-> m (Texture Flat) -> m (IO (Texture Flat))
forall a b. (a -> b) -> a -> b
$ (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, MonadThrow m, HasLogFunc env,
 Typeable a, HasCallStack) =>
Queues CommandPool -> Source -> m (Texture a)
Ktx1.load Queues CommandPool
pools Source
configTexture

  (ReleaseKey
textureKey, Texture Flat
texture) <- IO (Texture Flat)
-> (Texture Flat -> IO ()) -> m (ReleaseKey, Texture Flat)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    IO (Texture Flat)
createTexture
    (env -> Texture Flat -> IO ()
forall (io :: * -> *) context a.
(MonadIO io, HasVulkan context) =>
context -> Texture a -> io ()
Texture.destroy env
context)

  (ReleaseKey, Font) -> m (ReleaseKey, Font)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
textureKey, Font :: Container -> Texture Flat -> Font
Font{Texture Flat
Container
texture :: Texture Flat
container :: Container
$sel:container:Font :: Container
$sel:texture:Font :: Texture Flat
..})