{-# 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.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.Region qualified as Region
import Resource.Source (Source)
import Resource.Texture.Ktx2 qualified as Ktx2
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.Scene qualified as Scene
import Stage.Loader.Types (FrameResources(..), RunState(..))
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"

      Vector Font
fonts <- (Config -> RIO (App GlobalHandles (Maybe SwapchainResources)) Font)
-> Vector Config
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Vector Font)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse (Queues CommandPool
-> Config
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Font
forall env (m :: * -> *).
(HasCallStack, MonadVulkan env m, HasLogFunc env, MonadThrow m,
 MonadResource m) =>
Queues CommandPool -> Config -> m Font
Font.allocate Queues CommandPool
pools) [Item (Vector Config)
Config
smallFont, Item (Vector Config)
Config
largeFont]
      Vector (Texture Flat)
textures <- (Source
 -> RIO
      (App GlobalHandles (Maybe SwapchainResources)) (Texture Flat))
-> Vector Source
-> RIO
     (App GlobalHandles (Maybe SwapchainResources))
     (Vector (Texture Flat))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse (Queues CommandPool
-> Source
-> RIO
     (App GlobalHandles (Maybe SwapchainResources)) (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) [Item (Vector Source)
Source
bgPath, Item (Vector Source)
Source
spinnerPath]

      let
        fontContainers :: Vector Container
fontContainers = (Font -> Container) -> Vector Font -> Vector Container
forall a b. (a -> b) -> Vector a -> Vector b
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 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 a b. (a -> b) -> Vector a -> Vector b
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 = 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.
(HasCallStack, 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.
(HasCallStack, Vector v a) =>
v a -> Int -> a
! Int
1
          }

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

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
  }

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{Settings textures fonts
loaded -> StackStage
(Text -> StageSetupRIO ()) -> StageSetupRIO loaded
$sel:loadAction:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded
-> (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
$sel:nextStage:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> loaded -> StackStage
$sel:uiSettings:Setup :: forall (fonts :: * -> *) (textures :: * -> *) loaded.
Setup fonts textures loaded -> Settings textures fonts
loadAction :: (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
nextStage :: loaded -> StackStage
uiSettings :: Settings textures fonts
..} = ((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 = 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
        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"
      Collection Sampler
samplers <- ("max anisotropy" ::: Float)
-> ResourceT (StageRIO RunState) (Collection Sampler)
forall env (io :: * -> *).
MonadVulkan env io =>
("max anisotropy" ::: Float) -> ResourceT io (Collection Sampler)
Samplers.allocate (SwapchainResources -> "max anisotropy" ::: Float
forall a. HasSwapchain a => a -> "max anisotropy" ::: Float
Swapchain.getAnisotropy SwapchainResources
swapchain)
      Tagged Scene DsLayoutBindings
-> SampleCountFlagBits
-> RenderPasses
-> ResourceT (StageRIO RunState) Pipelines
forall st.
Tagged Scene DsLayoutBindings
-> SampleCountFlagBits
-> RenderPasses
-> ResourceT (StageRIO st) Pipelines
Basic.allocatePipelines
        (Collection Sampler -> Tagged Scene DsLayoutBindings
sceneBinds Collection Sampler
samplers)
        (SwapchainResources -> SampleCountFlagBits
forall a. HasSwapchain a => a -> SampleCountFlagBits
Swapchain.getMultisample SwapchainResources
swapchain)
        RenderPasses
rps

    sceneBinds :: Collection Sampler -> Tagged Scene DsLayoutBindings
sceneBinds Collection Sampler
samplers = Collection Sampler
-> Collection fonts textures (Int32, Texture Flat)
-> Maybe Any
-> Word32
-> Tagged Scene DsLayoutBindings
forall (samplers :: * -> *) (textures :: * -> *)
       (cubemaps :: * -> *) a b.
(Foldable samplers, Foldable textures, Foldable cubemaps) =>
samplers Sampler
-> textures a
-> cubemaps b
-> Word32
-> Tagged Scene DsLayoutBindings
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 = 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 = Stage.Scene
      { $sel:scBeforeLoop:Scene :: ResourceT (StageRIO RunState) ()
scBeforeLoop = () -> ResourceT (StageRIO RunState) ()
forall a. a -> ResourceT (StageRIO RunState) a
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 -> ResourceT
  (RIO (App GlobalHandles (Maybe SwapchainResources))) RunState
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
    ProjectionProcess 'Orthographic
rsProjectionP <- ResourceT
  (RIO (App GlobalHandles (Maybe SwapchainResources)))
  (ProjectionProcess 'Orthographic)
forall st (m :: * -> *).
(MonadReader (App GlobalHandles st) m, MonadResource m,
 MonadUnliftIO m) =>
m (ProjectionProcess 'Orthographic)
Camera.spawnOrthoPixelsCentered

    Process
rsSceneUiP <- ProjectionProcess 'Orthographic
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) Process
forall (m :: * -> *) projection.
(MonadResource m, MonadUnliftIO m, HasOutput projection,
 GetOutput projection ~ Projection 'Orthographic) =>
projection -> m Process
Scene.spawn ProjectionProcess 'Orthographic
rsProjectionP

    Indexed 'Staged Packed Vec2
rsQuadUV <- Maybe Text
-> Queues CommandPool
-> [Vertex Packed Vec2]
-> Maybe [Word32]
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources)))
     (Indexed 'Staged Packed Vec2)
forall env (m :: * -> *) pos attrs.
(MonadVulkan env m, Storable pos, Storable attrs) =>
Maybe Text
-> Queues CommandPool
-> [Vertex pos attrs]
-> Maybe [Word32]
-> m (Indexed 'Staged pos attrs)
Model.createStagedL (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rsQuadUV") 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
    Indexed 'Staged Packed Vec2
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) ()
forall {k1} {k2} env (m :: * -> *) (storage :: Store) (pos :: k1)
       (attrs :: k2).
(MonadVulkan env m, MonadResource m) =>
Indexed storage pos attrs -> m ()
Model.registerIndexed_ Indexed 'Staged Packed Vec2
rsQuadUV

    UI
rsUI <- RIO (App GlobalHandles (Maybe SwapchainResources)) (ReleaseKey, UI)
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) UI
forall (m :: * -> *) a.
MonadResource m =>
m (ReleaseKey, a) -> ResourceT m a
Region.local (RIO
   (App GlobalHandles (Maybe SwapchainResources)) (ReleaseKey, UI)
 -> ResourceT
      (RIO (App GlobalHandles (Maybe SwapchainResources))) UI)
-> RIO
     (App GlobalHandles (Maybe SwapchainResources)) (ReleaseKey, UI)
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) UI
forall a b. (a -> b) -> a -> b
$
      Queues CommandPool
-> Settings textures fonts
-> RIO
     (App GlobalHandles (Maybe SwapchainResources)) (ReleaseKey, UI)
forall (fonts :: * -> *) (textures :: * -> *) env.
Queues CommandPool
-> Settings fonts textures -> StageRIO env (ReleaseKey, UI)
UI.spawn Queues CommandPool
pools 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
          }

    Async ()
switcher <- RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) (Async ())
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
 -> ResourceT
      (RIO (App GlobalHandles (Maybe SwapchainResources))) (Async ()))
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) (Async ())
forall a b. (a -> b) -> a -> b
$ 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 a b.
RIO (App GlobalHandles (Maybe SwapchainResources)) a
-> (a -> RIO (App GlobalHandles (Maybe SwapchainResources)) b)
-> RIO (App GlobalHandles (Maybe SwapchainResources)) b
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 e a.
Exception e =>
e -> RIO (App GlobalHandles (Maybe SwapchainResources)) a
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 a b.
RIO (App GlobalHandles (Maybe SwapchainResources)) a
-> (a -> RIO (App GlobalHandles (Maybe SwapchainResources)) b)
-> RIO (App GlobalHandles (Maybe SwapchainResources)) b
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 e a.
Exception e =>
e -> RIO (App GlobalHandles (Maybe SwapchainResources)) a
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 ()
-> ResourceT
     (RIO (App GlobalHandles (Maybe SwapchainResources))) ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
switcher

    pure RunState{Process
UI
rsSceneUiP :: Process
rsUI :: UI
$sel:rsSceneUiP:RunState :: Process
$sel:rsUI:RunState :: UI
..}

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)
$sel:combined:Settings :: forall (fonts :: * -> *) (textures :: * -> *).
Settings fonts textures
-> Collection textures fonts (Int32, Texture Flat)
combined :: 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)
-> Vector ImageView
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO RunState) (FrameResource '[Scene])
forall (textures :: * -> *) (cubes :: * -> *) env (m :: * -> *).
(Traversable textures, Traversable cubes, MonadVulkan env m,
 MonadResource m) =>
Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> 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 a b.
(a -> b)
-> Collection textures fonts a -> Collection textures fonts b
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
    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 a b.
ResourceT (StageRIO RunState) a
-> (a -> ResourceT (StageRIO RunState) b)
-> ResourceT (StageRIO RunState) b
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
frSceneUi :: FrameResource '[Scene]
frUI :: Observer
$sel:frSceneUi:FrameResources :: FrameResource '[Scene]
$sel:frUI:FrameResources :: Observer
..}