{-# LANGUAGE OverloadedLists #-}

module Stage.Loader.Setup
  ( bootstrap
  , stackStage
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Engine.Camera qualified as Camera
import Engine.Stage.Component qualified as Stage
import Engine.StageSwitch (trySwitchStage)
import Engine.Types (StackStage(..), StageSetupRIO)
import Engine.Types qualified as Engine
import Engine.UI.Layout qualified as Layout
import Engine.UI.Message qualified as Message
import Engine.Vulkan.Swapchain qualified as Swapchain
import Engine.Vulkan.Types (Queues)
import Engine.Worker qualified as Worker
import Geometry.Quad qualified as Quad
import Render.Basic qualified as Basic
import Render.DescSets.Set0 qualified as Set0
import Render.Samplers qualified as Samplers
import Resource.Collection qualified as Collection
import Resource.Combined.Textures qualified as CombinedTextures
import Resource.CommandBuffer (withPools)
import Resource.Font qualified as Font
import Resource.Model qualified as Model
import Resource.Source (Source)
import Resource.Texture qualified as Texture
import Resource.Texture.Ktx1 qualified as Ktx1
import RIO.State (gets)
import RIO.Vector.Partial ((!))
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk

import Stage.Loader.Render qualified as Render
import Stage.Loader.Types (FrameResources(..), RunState(..))
import Stage.Loader.Scene qualified as Scene
import Stage.Loader.UI qualified as UI

bootstrap
  :: Text
  -> (Font.Config, Font.Config)
  -> (Source, Source)
  -> ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
  -> (loaded -> StackStage)
  -> ( (Setup Vector Vector loaded -> Engine.StackStage)
     , Engine.StageSetupRIO (Setup Vector Vector loaded)
     )
bootstrap :: forall loaded.
Text
-> (Config, Config)
-> (Source, Source)
-> ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> (Setup Vector Vector loaded -> StackStage,
    StageSetupRIO (Setup Vector Vector loaded))
bootstrap Text
titleMessage (Config
smallFont, Config
largeFont) (Source
bgPath, Source
spinnerPath) (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage =
  (Setup Vector Vector loaded -> StackStage
forall (fonts :: * -> *) (textures :: * -> *) loaded.
(Traversable fonts, Traversable textures) =>
Setup fonts textures loaded -> StackStage
stackStageBootstrap, RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Setup Vector Vector loaded)
action)
  where
    action :: RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Setup Vector Vector loaded)
action = (Queues CommandPool
 -> RIO
      (App GlobalHandles (Maybe SwapchainResources))
      (Setup Vector Vector loaded))
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (Setup Vector Vector loaded)
forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m) =>
(Queues CommandPool -> m a) -> m a
withPools \Queues CommandPool
pools -> do
      Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Bootstrapping loader"

      let
        fontConfigs :: Vector Config
fontConfigs = [Item (Vector Config)
Config
smallFont, Item (Vector Config)
Config
largeFont] :: Vector Font.Config
      (ReleaseKey
fontKey, Vector Font
fonts) <- Queues CommandPool
-> Vector Config
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (ReleaseKey, Vector Font)
forall (collection :: * -> *) env (m :: * -> *).
(Traversable collection, MonadVulkan env m, HasLogFunc env,
 MonadThrow m, MonadResource m, HasCallStack) =>
Queues CommandPool
-> collection Config -> m (ReleaseKey, collection Font)
Font.allocateCollection Queues CommandPool
pools Vector Config
fontConfigs

      let
        texturePaths :: Vector Source
texturePaths = [Item (Vector Source)
Source
bgPath, Item (Vector Source)
Source
spinnerPath] :: Vector Source
      (ReleaseKey
textureKey, Vector (Texture Flat)
textures) <- TextureLoaderAction
  Source (RIO (App GlobalHandles (Maybe SwapchainResources))) Flat
-> Vector Source
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (ReleaseKey, Vector (Texture Flat))
forall (m :: * -> *) env (t :: * -> *) src layers.
(MonadResource m, MonadVulkan env m, Traversable t) =>
TextureLoaderAction src m layers
-> t src -> m (ReleaseKey, t (Texture layers))
Texture.allocateCollectionWith
        (Queues CommandPool
-> TextureLoaderAction
     Source (RIO (App GlobalHandles (Maybe SwapchainResources))) 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)
        Vector Source
texturePaths

      let
        fontContainers :: Vector Container
fontContainers = (Font -> Container) -> Vector Font -> Vector Container
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Font -> Container
Font.container Vector Font
fonts
        combinedTextures :: Collection Vector Vector (Int32, Texture Flat)
combinedTextures = Collection Vector Vector (Texture Flat)
-> Collection Vector Vector (Int32, Texture Flat)
forall (t :: * -> *) ix a.
(Traversable t, Num ix) =>
t a -> t (ix, a)
Collection.enumerate Collection :: forall (textures :: * -> *) (fonts :: * -> *) a.
textures a -> fonts a -> Collection textures fonts a
CombinedTextures.Collection
          { $sel:textures:Collection :: Vector (Texture Flat)
textures = Vector (Texture Flat)
textures
          , $sel:fonts:Collection :: Vector (Texture Flat)
fonts    = (Font -> Texture Flat) -> Vector Font -> Vector (Texture Flat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Font -> Texture Flat
Font.texture Vector Font
fonts
          }

      let
        uiSettings :: Settings Vector Vector
uiSettings = Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Text
-> Int32
-> Int32
-> Collection textures fonts (Int32, Texture Flat)
-> fonts Container
-> (forall a. fonts a -> a)
-> (forall a. fonts a -> a)
-> Settings fonts textures
UI.Settings
          { $sel:titleMessage:Settings :: Text
titleMessage = Text
titleMessage
          , $sel:backgroundIx:Settings :: Int32
backgroundIx = Int32
0
          , $sel:spinnerIx:Settings :: Int32
spinnerIx    = Int32
1

          , $sel:combined:Settings :: Collection Vector Vector (Int32, Texture Flat)
combined = Collection Vector Vector (Int32, Texture Flat)
combinedTextures
          , $sel:fonts:Settings :: Vector Container
fonts    = Vector Container
fontContainers

          , $sel:smallFont:Settings :: forall a. Vector a -> a
smallFont = \Vector a
fs -> Vector a
fs Vector a -> Int -> a
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
0
          , $sel:largeFont:Settings :: forall a. Vector a -> a
largeFont = \Vector a
fs -> Vector a
fs Vector a -> Int -> a
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
! Int
1
          }

      ReleaseKey
loaderKey <- IO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO ()
 -> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey)
-> IO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey
forall a b. (a -> b) -> a -> b
$
        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
          [ Item [ReleaseKey]
ReleaseKey
fontKey
          , Item [ReleaseKey]
ReleaseKey
textureKey
          ]

      Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Finished bootstrapping loader"
      pure Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> ReleaseKey
-> Setup fonts textures loaded
Setup{ReleaseKey
Settings Vector Vector
loaded -> StackStage
(Text -> StageSetupRIO ()) -> StageSetupRIO loaded
$sel:loaderKey:Setup :: ReleaseKey
$sel:uiSettings:Setup :: Settings Vector Vector
$sel:nextStage:Setup :: loaded -> StackStage
$sel:loadAction:Setup :: (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loaderKey :: ReleaseKey
uiSettings :: Settings Vector Vector
nextStage :: loaded -> StackStage
loadAction :: (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
..}

data Setup fonts textures loaded = Setup
  { forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded
-> (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction :: (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
  , forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> loaded -> StackStage
nextStage  :: loaded -> StackStage
  , forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> Settings textures fonts
uiSettings :: UI.Settings textures fonts
  , forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> ReleaseKey
loaderKey  :: Resource.ReleaseKey
  }

stackStageBootstrap
  :: (Traversable fonts, Traversable textures)
  => Setup fonts textures loaded -> StackStage
stackStageBootstrap :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
(Traversable fonts, Traversable textures) =>
Setup fonts textures loaded -> StackStage
stackStageBootstrap Setup{ReleaseKey
Settings textures fonts
loaded -> StackStage
(Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loaderKey :: ReleaseKey
uiSettings :: Settings textures fonts
nextStage :: loaded -> StackStage
loadAction :: (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
$sel:loaderKey:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> ReleaseKey
$sel:uiSettings:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> Settings textures fonts
$sel:nextStage:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> loaded -> StackStage
$sel:loadAction:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded
-> (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
..} = ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage) -> Settings textures fonts -> StackStage
forall (fonts :: * -> *) (textures :: * -> *) loaded.
(Traversable fonts, Traversable textures) =>
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage) -> Settings textures fonts -> StackStage
stackStage (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage Settings textures fonts
uiSettings

stackStage
  :: (Traversable fonts, Traversable textures)
  => ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
  -> (loaded -> StackStage)
  -> UI.Settings textures fonts
  -> StackStage
stackStage :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
(Traversable fonts, Traversable textures) =>
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage) -> Settings textures fonts -> StackStage
stackStage (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage Settings textures fonts
uiSettings =
  Stage RenderPasses Pipelines FrameResources RunState -> StackStage
forall rp p rr st. RenderPass rp => Stage rp p rr st -> StackStage
StackStage (Stage RenderPasses Pipelines FrameResources RunState
 -> StackStage)
-> Stage RenderPasses Pipelines FrameResources RunState
-> StackStage
forall a b. (a -> b) -> a -> b
$ ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> Stage RenderPasses Pipelines FrameResources RunState
forall (fonts :: * -> *) (textures :: * -> *) loaded.
(Traversable fonts, Traversable textures) =>
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> Stage RenderPasses Pipelines FrameResources RunState
loaderStage (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage Settings textures fonts
uiSettings

loaderStage
  :: (Traversable fonts, Traversable textures)
  => ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
  -> (loaded -> StackStage)
  -> UI.Settings textures fonts
  -> Basic.Stage FrameResources RunState
loaderStage :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
(Traversable fonts, Traversable textures) =>
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> Stage RenderPasses Pipelines FrameResources RunState
loaderStage (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage Settings textures fonts
uiSettings = Text
-> Rendering RenderPasses Pipelines RunState
-> Resources RenderPasses Pipelines RunState FrameResources
-> Maybe (Scene RenderPasses Pipelines RunState FrameResources)
-> Stage RenderPasses Pipelines FrameResources RunState
forall (t :: * -> *) rp p st rr.
Foldable t =>
Text
-> Rendering rp p st
-> Resources rp p st rr
-> t (Scene rp p st rr)
-> Stage rp p rr st
Stage.assemble Text
"Loader" Rendering RenderPasses Pipelines RunState
rendering Resources RenderPasses Pipelines RunState FrameResources
resources (Scene RenderPasses Pipelines RunState FrameResources
-> Maybe (Scene RenderPasses Pipelines RunState FrameResources)
forall a. a -> Maybe a
Just Scene RenderPasses Pipelines RunState FrameResources
scene)
  where
    rendering :: Rendering RenderPasses Pipelines RunState
rendering = Rendering :: forall rp p st.
(SwapchainResources -> ResourceT (StageRIO st) rp)
-> (SwapchainResources -> rp -> ResourceT (StageRIO st) p)
-> Rendering rp p st
Stage.Rendering
      { $sel:rAllocateRP:Rendering :: SwapchainResources -> ResourceT (StageRIO RunState) RenderPasses
rAllocateRP = SwapchainResources -> ResourceT (StageRIO RunState) RenderPasses
forall {swapchain} {env}.
(HasSwapchain swapchain, HasLogFunc env, HasVulkan env) =>
swapchain -> ResourceT (RIO env) RenderPasses
allocateRenderPass
      , $sel:rAllocateP:Rendering :: SwapchainResources
-> RenderPasses -> ResourceT (StageRIO RunState) Pipelines
rAllocateP = SwapchainResources
-> RenderPasses -> ResourceT (StageRIO RunState) Pipelines
allocatePipelines
      }

    allocateRenderPass :: swapchain -> ResourceT (RIO env) RenderPasses
allocateRenderPass swapchain
swapchain = do
      Settings -> swapchain -> ResourceT (RIO env) RenderPasses
forall swapchain env.
(HasSwapchain swapchain, HasLogFunc env, HasVulkan env) =>
Settings -> swapchain -> ResourceT (RIO env) RenderPasses
Basic.allocate
        Settings :: Word32 -> Word32 -> Settings
Basic.Settings
          { $sel:sShadowLayers:Settings :: Word32
sShadowLayers = Word32
1
          , $sel:sShadowSize:Settings :: Word32
sShadowSize   = Word32
1
          }
        swapchain
swapchain

    allocatePipelines :: SwapchainResources
-> RenderPasses -> ResourceT (StageRIO RunState) Pipelines
allocatePipelines SwapchainResources
swapchain RenderPasses
rps = do
      Utf8Builder -> ResourceT (StageRIO RunState) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Allocating loader pipelines"
      (ReleaseKey
_, Collection Sampler
samplers) <- ("max anisotropy" ::: Float)
-> ResourceT (StageRIO RunState) (ReleaseKey, Collection Sampler)
forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
("max anisotropy" ::: Float) -> m (ReleaseKey, Collection Sampler)
Samplers.allocate
        (SwapchainResources -> "max anisotropy" ::: Float
forall a. HasSwapchain a => a -> "max anisotropy" ::: Float
Swapchain.getAnisotropy SwapchainResources
swapchain)
      Tagged Scene DsBindings
-> SampleCountFlagBits
-> RenderPasses
-> ResourceT (StageRIO RunState) Pipelines
forall st.
Tagged Scene DsBindings
-> SampleCountFlagBits
-> RenderPasses
-> ResourceT (StageRIO st) Pipelines
Basic.allocatePipelines
        (Collection Sampler -> Tagged Scene DsBindings
sceneBinds Collection Sampler
samplers)
        (SwapchainResources -> SampleCountFlagBits
forall a. HasSwapchain a => a -> SampleCountFlagBits
Swapchain.getMultisample SwapchainResources
swapchain)
        RenderPasses
rps

    sceneBinds :: Collection Sampler -> Tagged Scene DsBindings
sceneBinds Collection Sampler
samplers = Collection Sampler
-> Collection fonts textures (Int32, Texture Flat)
-> Maybe Any
-> Word32
-> Tagged Scene DsBindings
forall (samplers :: * -> *) (textures :: * -> *)
       (cubemaps :: * -> *) a b.
(Foldable samplers, Foldable textures, Foldable cubemaps) =>
samplers Sampler
-> textures a -> cubemaps b -> Word32 -> Tagged Scene DsBindings
Set0.mkBindings
      Collection Sampler
samplers
      (Settings textures fonts
-> Collection fonts textures (Int32, Texture Flat)
forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures
-> Collection textures fonts (Int32, Texture Flat)
UI.combined Settings textures fonts
uiSettings)
      Maybe Any
forall a. Maybe a
Nothing
      Word32
0

    resources :: Resources RenderPasses Pipelines RunState FrameResources
resources = Resources :: forall rp p st rr.
StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
-> (Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr)
-> Resources rp p st rr
Stage.Resources
      { $sel:rInitialRS:Resources :: StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
rInitialRS = ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
forall loaded (textures :: * -> *) (fonts :: * -> *).
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
initialRunState (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage Settings textures fonts
uiSettings
      , $sel:rInitialRR:Resources :: Queues CommandPool
-> RenderPasses
-> Pipelines
-> ResourceT (StageRIO RunState) FrameResources
rInitialRR = Settings textures fonts
-> Queues CommandPool
-> RenderPasses
-> Pipelines
-> ResourceT (StageRIO RunState) FrameResources
forall (fonts :: * -> *) (textures :: * -> *).
(Traversable fonts, Traversable textures) =>
Settings fonts textures
-> Queues CommandPool
-> RenderPasses
-> Pipelines
-> ResourceT (StageRIO RunState) FrameResources
initialFrameResources Settings textures fonts
uiSettings
      }

    scene :: Scene RenderPasses Pipelines RunState FrameResources
scene = Scene :: forall rp p st rr.
ResourceT (StageRIO st) ()
-> (st -> rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer -> rr -> Word32 -> StageFrameRIO rp p rr st ())
-> Scene rp p st rr
Stage.Scene
      { $sel:scBeforeLoop:Scene :: ResourceT (StageRIO RunState) ()
scBeforeLoop = () -> ResourceT (StageRIO RunState) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , $sel:scUpdateBuffers:Scene :: RunState
-> FrameResources
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
scUpdateBuffers = RunState
-> FrameResources
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
Render.updateBuffers
      , $sel:scRecordCommands:Scene :: CommandBuffer
-> FrameResources
-> Word32
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
scRecordCommands = CommandBuffer
-> FrameResources
-> Word32
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
Render.recordCommands
      }

initialRunState
  :: ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
  -> (loaded -> StackStage)
  -> UI.Settings textures fonts
  -> StageSetupRIO (Resource.ReleaseKey, RunState)
initialRunState :: forall loaded (textures :: * -> *) (fonts :: * -> *).
((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
-> (loaded -> StackStage)
-> Settings textures fonts
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
initialRunState (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction loaded -> StackStage
nextStage Settings textures fonts
uiSettings =
  (Queues CommandPool
 -> StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState))
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m) =>
(Queues CommandPool -> m a) -> m a
withPools \Queues CommandPool
pools -> do
    (ReleaseKey
projectionKey, ProjectionProcess 'Orthographic
rsProjectionP) <- RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (ProjectionProcess 'Orthographic)
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (ReleaseKey, ProjectionProcess 'Orthographic)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered
      RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (ProjectionProcess 'Orthographic)
forall env. StageRIO env (ProjectionProcess 'Orthographic)
Camera.spawnOrthoPixelsCentered

    (ReleaseKey
sceneUiKey, Process
rsSceneUiP) <- RIO (App GlobalHandles (Maybe SwapchainResources)) Process
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (ReleaseKey, Process)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered (RIO (App GlobalHandles (Maybe SwapchainResources)) Process
 -> RIO
      (App GlobalHandles (Maybe SwapchainResources))
      (ReleaseKey, Process))
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Process
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (ReleaseKey, Process)
forall a b. (a -> b) -> a -> b
$
      ProjectionProcess 'Orthographic
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Process
forall (m :: * -> *) projection.
(MonadUnliftIO m, HasOutput projection,
 GetOutput projection ~ Projection 'Orthographic) =>
projection -> m Process
Scene.spawn ProjectionProcess 'Orthographic
rsProjectionP

    App GlobalHandles (Maybe SwapchainResources)
context <- RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (App GlobalHandles (Maybe SwapchainResources))
forall r (m :: * -> *). MonadReader r m => m r
ask

    Indexed 'Staged Packed Vec2
rsQuadUV <- App GlobalHandles (Maybe SwapchainResources)
-> Queues CommandPool
-> [Vertex Packed Vec2]
-> Maybe [Word32]
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (Indexed 'Staged Packed Vec2)
forall context pos attrs (io :: * -> *).
(HasVulkan context, Storable pos, Storable attrs,
 MonadUnliftIO io) =>
context
-> Queues CommandPool
-> [Vertex pos attrs]
-> Maybe [Word32]
-> io (Indexed 'Staged pos attrs)
Model.createStagedL App GlobalHandles (Maybe SwapchainResources)
context Queues CommandPool
pools (Quad (Vertex Packed Vec2) -> [Vertex Packed Vec2]
forall pos attrs. Quad (Vertex pos attrs) -> [Vertex pos attrs]
Quad.toVertices Quad (Vertex Packed Vec2)
Quad.texturedQuad) Maybe [Word32]
forall a. Maybe a
Nothing
    ReleaseKey
quadKey <- IO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO ()
 -> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey)
-> IO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey
forall a b. (a -> b) -> a -> b
$ App GlobalHandles (Maybe SwapchainResources)
-> Indexed 'Staged Packed Vec2 -> IO ()
forall context (io :: * -> *) (storage :: Store) pos attrs.
(HasVulkan context, MonadUnliftIO io) =>
context -> Indexed storage pos attrs -> io ()
Model.destroyIndexed App GlobalHandles (Maybe SwapchainResources)
context Indexed 'Staged Packed Vec2
rsQuadUV

    (ReleaseKey
screenKey, BoxProcess
screenBoxP) <- RIO (App GlobalHandles (Maybe SwapchainResources)) BoxProcess
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (ReleaseKey, BoxProcess)
forall (m :: * -> *) a.
(MonadResource m, HasWorker a) =>
m a -> m (ReleaseKey, a)
Worker.registered RIO (App GlobalHandles (Maybe SwapchainResources)) BoxProcess
forall st. StageRIO st BoxProcess
Layout.trackScreen

    (ReleaseKey
uiKey, UI
rsUI) <- Queues CommandPool
-> BoxProcess
-> Settings textures fonts
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, UI)
forall (fonts :: * -> *) (textures :: * -> *) env.
Queues CommandPool
-> BoxProcess
-> Settings fonts textures
-> StageRIO env (ReleaseKey, UI)
UI.spawn Queues CommandPool
pools BoxProcess
screenBoxP Settings textures fonts
uiSettings

    let
      updateProgress :: Text -> StageSetupRIO ()
updateProgress Text
text = do
        Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageSetupRIO ())
-> Utf8Builder -> StageSetupRIO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loader: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
text
        Var Input
-> (GetInput (Var Input) -> GetInput (Var Input))
-> StageSetupRIO ()
forall (m :: * -> *) var.
(MonadIO m, HasInput var) =>
var -> (GetInput var -> GetInput var) -> m ()
Worker.pushInput (UI -> Var Input
UI.progressInput UI
rsUI) \GetInput (Var Input)
msg -> GetInput (Var Input)
Input
msg
          { $sel:inputText:Input :: Text
Message.inputText = Text
text
          }

    ReleaseKey
releaseKeys <- IO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO ()
 -> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey)
-> IO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) ReleaseKey
forall a b. (a -> b) -> a -> b
$
      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
        [ Item [ReleaseKey]
ReleaseKey
projectionKey
        , Item [ReleaseKey]
ReleaseKey
sceneUiKey
        , Item [ReleaseKey]
ReleaseKey
quadKey
        , Item [ReleaseKey]
ReleaseKey
screenKey
        , Item [ReleaseKey]
ReleaseKey
uiKey
        ]

    Async ()
switcher <- StageSetupRIO ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async do
      Async loaded
loader <- StageSetupRIO loaded
-> RIO
     (App GlobalHandles (Maybe SwapchainResources)) (Async loaded)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async do
        Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Starting load action"
        StageSetupRIO loaded
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (Either SomeException loaded)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction Text -> StageSetupRIO ()
updateProgress) RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Either SomeException loaded)
-> (Either SomeException loaded -> StageSetupRIO loaded)
-> StageSetupRIO loaded
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left (SomeException
e :: SomeException) -> do
            Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> StageSetupRIO ())
-> Utf8Builder -> StageSetupRIO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Load action failed with " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
            SomeException -> StageSetupRIO loaded
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
          Right loaded
r -> do
            Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Load action finished"
            pure loaded
r

      Async loaded -> StageSetupRIO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async loaded
loader
      -- threadDelay 1e6
      Async loaded
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (Either SomeException loaded)
forall (m :: * -> *) a.
MonadIO m =>
Async a -> m (Either SomeException a)
waitCatch Async loaded
loader RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Either SomeException loaded)
-> (Either SomeException loaded -> StageSetupRIO ())
-> StageSetupRIO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
oopsie -> do
          Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Loader failed"
          SomeException -> StageSetupRIO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
oopsie
        Right loaded
loaded -> do
          Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Loader signalled a stage change"

          Text -> StageSetupRIO ()
updateProgress Text
"Done!"
          Bool
switched <- NextStage -> StageRIO (Maybe SwapchainResources) Bool
forall rs. NextStage -> StageRIO rs Bool
trySwitchStage (NextStage -> StageRIO (Maybe SwapchainResources) Bool)
-> (StackStage -> NextStage)
-> StackStage
-> StageRIO (Maybe SwapchainResources) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackStage -> NextStage
Engine.Replace (StackStage -> StageRIO (Maybe SwapchainResources) Bool)
-> StackStage -> StageRIO (Maybe SwapchainResources) Bool
forall a b. (a -> b) -> a -> b
$
            loaded -> StackStage
nextStage loaded
loaded
          Bool -> StageSetupRIO () -> StageSetupRIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
switched (StageSetupRIO () -> StageSetupRIO ())
-> StageSetupRIO () -> StageSetupRIO ()
forall a b. (a -> b) -> a -> b
$
            Utf8Builder -> StageSetupRIO ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Loader switch failed"

    -- XXX: propagate exceptions from loader threads
    Async () -> StageSetupRIO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
switcher

    pure (ReleaseKey
releaseKeys, RunState :: Process -> UI -> RunState
RunState{Process
UI
$sel:rsUI:RunState :: UI
$sel:rsSceneUiP:RunState :: Process
rsUI :: UI
rsSceneUiP :: Process
..})

initialFrameResources
  :: (Traversable fonts, Traversable textures)
  => UI.Settings fonts textures
  -> Queues Vk.CommandPool
  -> Basic.RenderPasses
  -> Basic.Pipelines
  -> ResourceT (Engine.StageRIO RunState) FrameResources
initialFrameResources :: forall (fonts :: * -> *) (textures :: * -> *).
(Traversable fonts, Traversable textures) =>
Settings fonts textures
-> Queues CommandPool
-> RenderPasses
-> Pipelines
-> ResourceT (StageRIO RunState) FrameResources
initialFrameResources UI.Settings{Collection textures fonts (Int32, Texture Flat)
combined :: Collection textures fonts (Int32, Texture Flat)
$sel:combined:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures
-> Collection textures fonts (Int32, Texture Flat)
combined} Queues CommandPool
_pools RenderPasses
_passes Pipelines
pipelines = do
  FrameResource '[Scene]
frSceneUi <- Tagged '[Scene] DescriptorSetLayout
-> Collection textures fonts (Texture Flat)
-> Maybe (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO RunState) (FrameResource '[Scene])
forall (textures :: * -> *) (cubes :: * -> *) env (m :: * -> *).
(Traversable textures, Traversable cubes, MonadVulkan env m) =>
Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT m (FrameResource '[Scene])
Set0.allocate
    (Pipelines -> Tagged '[Scene] DescriptorSetLayout
forall (f :: * -> *).
PipelinesF f -> Tagged '[Scene] DescriptorSetLayout
Basic.getSceneLayout Pipelines
pipelines)
    (((Int32, Texture Flat) -> Texture Flat)
-> Collection textures fonts (Int32, Texture Flat)
-> Collection textures fonts (Texture Flat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int32, Texture Flat) -> Texture Flat
forall a b. (a, b) -> b
snd Collection textures fonts (Int32, Texture Flat)
combined)
    Maybe (Texture CubeMap)
forall a. Maybe a
Nothing
    Maybe (Allocated 'Coherent Sun)
forall a. Maybe a
Nothing
    "shadow maps" ::: Vector ImageView
forall a. Monoid a => a
mempty -- XXX: no shadows on loader
    Maybe (Allocated 'Coherent Material)
forall a. Maybe a
Nothing

  Observer
frUI <- (RunState -> UI) -> ResourceT (StageRIO RunState) UI
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RunState -> UI
rsUI ResourceT (StageRIO RunState) UI
-> (UI -> ResourceT (StageRIO RunState) Observer)
-> ResourceT (StageRIO RunState) Observer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    UI -> ResourceT (StageRIO RunState) Observer
forall st. UI -> ResourceT (StageRIO st) Observer
UI.newObserver

  pure FrameResources :: FrameResource '[Scene] -> Observer -> FrameResources
FrameResources{FrameResource '[Scene]
Observer
$sel:frUI:FrameResources :: Observer
$sel:frSceneUi:FrameResources :: FrameResource '[Scene]
frUI :: Observer
frSceneUi :: FrameResource '[Scene]
..}