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
  { 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
     , HasCallStack
     )
  => Queues Vk.CommandPool
  -> collection Config
  -> StageRIO st (Resource.ReleaseKey, collection Font)
allocateCollection :: Queues CommandPool
-> collection Config -> StageRIO st (ReleaseKey, collection Font)
allocateCollection Queues CommandPool
pools collection Config
collection = do
  collection (ReleaseKey, Font)
collected <- collection Config
-> (Config -> RIO (App GlobalHandles st) (ReleaseKey, Font))
-> RIO (App GlobalHandles st) (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 -> RIO (App GlobalHandles st) (ReleaseKey, Font))
 -> RIO (App GlobalHandles st) (collection (ReleaseKey, Font)))
-> (Config -> RIO (App GlobalHandles st) (ReleaseKey, Font))
-> RIO (App GlobalHandles st) (collection (ReleaseKey, Font))
forall a b. (a -> b) -> a -> b
$
    (HasCallStack =>
 Config -> RIO (App GlobalHandles st) (ReleaseKey, Font))
-> Config -> RIO (App GlobalHandles st) (ReleaseKey, Font)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack =>
  Config -> RIO (App GlobalHandles st) (ReleaseKey, Font))
 -> Config -> RIO (App GlobalHandles st) (ReleaseKey, Font))
-> (HasCallStack =>
    Config -> RIO (App GlobalHandles st) (ReleaseKey, Font))
-> Config
-> RIO (App GlobalHandles st) (ReleaseKey, Font)
forall a b. (a -> b) -> a -> b
$ Queues CommandPool
-> Config -> RIO (App GlobalHandles st) (ReleaseKey, Font)
forall st.
HasCallStack =>
Queues CommandPool -> Config -> StageRIO st (ReleaseKey, Font)
allocateFont Queues CommandPool
pools
  ReleaseKey
key <- IO () -> RIO (App GlobalHandles st) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> RIO (App GlobalHandles st) ReleaseKey)
-> IO () -> RIO (App GlobalHandles st) 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 :: 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
  => Queues Vk.CommandPool
  -> Config
  -> StageRIO st (Resource.ReleaseKey, Font)
allocateFont :: Queues CommandPool -> Config -> StageRIO st (ReleaseKey, Font)
allocateFont Queues CommandPool
pools Config{Source
configTexture :: Source
configContainer :: Source
$sel:configTexture:Config :: Config -> Source
$sel:configContainer:Config :: Config -> Source
..} = do
  App GlobalHandles st
context <- RIO (App GlobalHandles st) (App GlobalHandles st)
forall r (m :: * -> *). MonadReader r m => m r
ask

  Container
container <- (HasCallStack => RIO (App GlobalHandles st) Container)
-> RIO (App GlobalHandles st) Container
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => RIO (App GlobalHandles st) Container)
 -> RIO (App GlobalHandles st) Container)
-> (HasCallStack => RIO (App GlobalHandles st) Container)
-> RIO (App GlobalHandles st) Container
forall a b. (a -> b) -> a -> b
$
    Source -> RIO (App GlobalHandles st) Container
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Source -> m Container
EvanW.load Source
configContainer

  IO (Texture Flat)
createTexture <- RIO (App GlobalHandles st) (Texture Flat)
-> RIO (App GlobalHandles st) (IO (Texture Flat))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (RIO (App GlobalHandles st) (Texture Flat)
 -> RIO (App GlobalHandles st) (IO (Texture Flat)))
-> (RIO (App GlobalHandles st) (Texture Flat)
    -> RIO (App GlobalHandles st) (Texture Flat))
-> RIO (App GlobalHandles st) (Texture Flat)
-> RIO (App GlobalHandles st) (IO (Texture Flat))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RIO (App GlobalHandles st) (Texture Flat)
-> RIO (App GlobalHandles st) (Texture Flat)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (RIO (App GlobalHandles st) (Texture Flat)
 -> RIO (App GlobalHandles st) (IO (Texture Flat)))
-> RIO (App GlobalHandles st) (Texture Flat)
-> RIO (App GlobalHandles st) (IO (Texture Flat))
forall a b. (a -> b) -> a -> b
$
    Queues CommandPool
-> Source -> RIO (App GlobalHandles st) (Texture Flat)
forall a st.
(TextureLayers a, Typeable a, HasCallStack) =>
Queues CommandPool -> Source -> StageRIO st (Texture a)
Ktx1.load Queues CommandPool
pools Source
configTexture

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

  (ReleaseKey, Font) -> StageRIO st (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
..})