{-# LANGUAGE OverloadedLists #-}

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

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Engine.StageSwitch (trySwitchStage)
import Engine.Types (StackStage(..), Stage(..), StageSetupRIO)
import Engine.Types qualified as Engine
import Engine.UI.Layout qualified as Layout
import Engine.UI.Message qualified as Message
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 :: 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, StageSetupRIO (Setup Vector Vector loaded)
action)
  where
    action :: StageSetupRIO (Setup Vector Vector loaded)
action = (Queues CommandPool -> StageSetupRIO (Setup Vector Vector loaded))
-> StageSetupRIO (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
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, Vector Font)
forall (collection :: * -> *) st.
(Traversable collection, HasCallStack) =>
Queues CommandPool
-> collection Config -> StageRIO st (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 st.
(TextureLayers a, Typeable a, HasCallStack) =>
Queues CommandPool -> Source -> StageRIO st (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
$
        (ReleaseKey -> IO ()) -> [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
          [ 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
  { Setup fonts textures loaded
-> (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
loadAction :: (Text -> StageSetupRIO ()) -> StageSetupRIO loaded
  , Setup fonts textures loaded -> loaded -> StackStage
nextStage  :: loaded -> StackStage
  , Setup fonts textures loaded -> Settings textures fonts
uiSettings :: UI.Settings textures fonts
  , Setup fonts textures loaded -> ReleaseKey
loaderKey  :: Resource.ReleaseKey
  }

stackStageBootstrap
  :: (Traversable fonts, Traversable textures)
  => Setup fonts textures loaded -> StackStage
stackStageBootstrap :: 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 :: ((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 :: ((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 = Stage :: forall rp p rr st a.
Text
-> (SwapchainResources -> rp -> ResourceT (StageRIO st) p)
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
-> (Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr)
-> StageRIO st a
-> (st -> rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
    -> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> (a -> StageRIO st ())
-> Stage rp p rr st
Stage
  { $sel:sTitle:Stage :: Text
sTitle = Text
"Loader"

  , $sel:sAllocateP:Stage :: SwapchainResources
-> RenderPasses -> ResourceT (StageRIO RunState) Pipelines
sAllocateP  = SwapchainResources
-> RenderPasses -> ResourceT (StageRIO RunState) Pipelines
allocatePipelines
  , $sel:sInitialRS:Stage :: StageRIO (Maybe SwapchainResources) (ReleaseKey, RunState)
sInitialRS  = ((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:sInitialRR:Stage :: Queues CommandPool
-> RenderPasses
-> Pipelines
-> ResourceT (StageRIO RunState) FrameResources
sInitialRR  = 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
  , $sel:sBeforeLoop:Stage :: StageRIO RunState ()
sBeforeLoop = () -> StageRIO RunState ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  , $sel:sUpdateBuffers:Stage :: RunState
-> FrameResources
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
sUpdateBuffers  = RunState
-> FrameResources
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
Render.updateBuffers
  , $sel:sRecordCommands:Stage :: CommandBuffer
-> FrameResources
-> ("image index" ::: Word32)
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
sRecordCommands = CommandBuffer
-> FrameResources
-> ("image index" ::: Word32)
-> StageFrameRIO RenderPasses Pipelines FrameResources RunState ()
Render.recordCommands

  , $sel:sAfterLoop:Stage :: () -> StageRIO RunState ()
sAfterLoop    = () -> StageRIO RunState ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  }
  where
    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) <- SwapchainResources
-> ResourceT (StageRIO RunState) (ReleaseKey, Collection Sampler)
forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m, HasSwapchain a) =>
a -> m (ReleaseKey, Collection Sampler)
Samplers.allocate SwapchainResources
swapchain
      Tagged Scene DsBindings
-> SwapchainResources
-> RenderPasses
-> ResourceT (StageRIO RunState) Pipelines
forall swapchain st.
HasSwapchain swapchain =>
Tagged Scene DsBindings
-> swapchain -> RenderPasses -> ResourceT (StageRIO st) Pipelines
Basic.allocatePipelines (Collection Sampler -> Tagged Scene DsBindings
sceneBinds Collection Sampler
samplers) SwapchainResources
swapchain RenderPasses
rps

    sceneBinds :: Collection Sampler -> Tagged Scene DsBindings
sceneBinds Collection Sampler
samplers = Collection Sampler
-> Collection fonts textures (Int32, Texture Flat)
-> Maybe Any
-> ("image index" ::: Word32)
-> Tagged Scene DsBindings
forall (samplers :: * -> *) (textures :: * -> *)
       (cubemaps :: * -> *) a b.
(Foldable samplers, Foldable textures, Foldable cubemaps) =>
samplers Sampler
-> textures a
-> cubemaps b
-> ("image index" ::: 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
      "image index" ::: Word32
0

initialRunState
  :: ((Text -> StageSetupRIO ()) -> StageSetupRIO loaded)
  -> (loaded -> StackStage)
  -> UI.Settings textures fonts
  -> StageSetupRIO (Resource.ReleaseKey, RunState)
initialRunState :: ((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
    ProjectionProcess
rsProjectionP <- RIO
  (App GlobalHandles (Maybe SwapchainResources)) ProjectionProcess
forall s (m :: * -> *).
MonadReader (App GlobalHandles s) m =>
m ProjectionProcess
Engine.getScreenP

    (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
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Process
forall (m :: * -> *) projection.
(MonadUnliftIO m, HasOutput projection,
 GetOutput projection ~ Projection) =>
projection -> m Process
Scene.spawn ProjectionProcess
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 ["image index" ::: 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 ["image index" ::: 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 ["image index" ::: 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
$
      (ReleaseKey -> IO ()) -> [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
        [ 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 :: ProjectionProcess -> Process -> UI -> RunState
RunState{ProjectionProcess
Process
UI
$sel:rsUI:RunState :: UI
$sel:rsSceneUiP:RunState :: Process
$sel:rsProjectionP:RunState :: ProjectionProcess
rsUI :: UI
rsSceneUiP :: Process
rsProjectionP :: ProjectionProcess
..})

initialFrameResources
  :: (Traversable fonts, Traversable textures)
  => UI.Settings fonts textures
  -> Queues Vk.CommandPool
  -> Basic.RenderPasses
  -> Basic.Pipelines
  -> ResourceT (Engine.StageRIO RunState) FrameResources
initialFrameResources :: 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 :: * -> *) st.
(Traversable textures, Traversable cubes) =>
Tagged '[Scene] DescriptorSetLayout
-> textures (Texture Flat)
-> cubes (Texture CubeMap)
-> Maybe (Allocated 'Coherent Sun)
-> ("shadow maps" ::: Vector ImageView)
-> Maybe (Allocated 'Coherent Material)
-> ResourceT (StageRIO st) (FrameResource '[Scene])
Set0.allocate
    (Pipelines -> 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]
..}