module Engine.Run
  ( runStack
  , run
  , step
  ) where

import RIO

import Graphics.UI.GLFW qualified as GLFW
import RIO.App (App(..), appEnv)
import RIO.State (get, put)
import UnliftIO.Resource (ReleaseKey, release)
import Vulkan.Core10 qualified as Vk

import Engine.DataRecycler (DataRecycler(..))
import Engine.DataRecycler qualified as DataRecycler
import Engine.Frame qualified as Frame
import Engine.Render (renderFrame)
import Engine.StageSwitch (getNextStage)
import Engine.Types (Frame, NextStage(..), RecycledResources, StageStack, StackStage(..), Stage(..), StageRIO)
import Engine.Types qualified as Engine
import Engine.Types.Options (optionsRecyclerWait)
import Engine.Types.RefCounted (releaseRefCounted)
import Engine.Vulkan.Swapchain (SwapchainResources(srRelease), threwSwapchainError)
import Engine.Vulkan.Types (RenderPass, getDevice)

runStack :: StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack :: StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack = \case
  [] -> do
    Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Stage stack finished"
    RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Maybe SwapchainResources)
forall s (m :: * -> *). MonadState s m => m s
get RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Maybe SwapchainResources)
-> (Maybe SwapchainResources
    -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe SwapchainResources
Nothing ->
        () -> StageRIO (Maybe SwapchainResources) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just SwapchainResources
oldSR ->
        RefCounted -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (SwapchainResources -> RefCounted
srRelease SwapchainResources
oldSR)
    (App GlobalHandles (Maybe SwapchainResources) -> Device)
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles (Maybe SwapchainResources) -> Device
forall a. HasVulkan a => a -> Device
getDevice RIO (App GlobalHandles (Maybe SwapchainResources)) Device
-> (Device -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Device -> StageRIO (Maybe SwapchainResources) ()
forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
    Int -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
0.5e6 -- XXX: this is arbitrary and may not always satisfy the validator

  StackStage Stage rp p rr st
stage : StageStack
rest -> do
    Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO (Maybe SwapchainResources) ())
-> Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Setting up stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Stage rp p rr st -> Text
forall rp p rr st. Stage rp p rr st -> Text
sTitle Stage rp p rr st
stage)
    (ReleaseKey
stageRelease, StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner) <- StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
-> StageRIO
     (Maybe SwapchainResources)
     (ReleaseKey,
      StageRIO st StageResult
      -> StageRIO (Maybe SwapchainResources) StageResult)
forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage (Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sInitialRS Stage rp p rr st
stage)
    Maybe SwapchainResources
oldSR <- RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Maybe SwapchainResources)
forall s (m :: * -> *). MonadState s m => m s
get
    StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
forall rp p rr st.
RenderPass rp =>
Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
run Maybe SwapchainResources
oldSR ReleaseKey
stageRelease Stage rp p rr st
stage) StageRIO (Maybe SwapchainResources) StageResult
-> (StageResult -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReleaseKey
-> StageStack
-> StageResult
-> StageRIO (Maybe SwapchainResources) ()
proceed ReleaseKey
stageRelease StageStack
rest

  StackStageContinue ReleaseKey
stKey st
state Stage rp p rr st
stage : StageStack
rest -> do
    Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO (Maybe SwapchainResources) ())
-> Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Resuming stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Stage rp p rr st -> Text
forall rp p rr st. Stage rp p rr st -> Text
sTitle Stage rp p rr st
stage)
    (ReleaseKey
stageRelease, StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner) <- StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
-> StageRIO
     (Maybe SwapchainResources)
     (ReleaseKey,
      StageRIO st StageResult
      -> StageRIO (Maybe SwapchainResources) StageResult)
forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage ((ReleaseKey, st)
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
stKey, st
state))
    Maybe SwapchainResources
oldSR <- RIO
  (App GlobalHandles (Maybe SwapchainResources))
  (Maybe SwapchainResources)
forall s (m :: * -> *). MonadState s m => m s
get
    StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
forall rp p rr st.
RenderPass rp =>
Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
run Maybe SwapchainResources
oldSR ReleaseKey
stageRelease Stage rp p rr st
stage) StageRIO (Maybe SwapchainResources) StageResult
-> (StageResult -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReleaseKey
-> StageStack
-> StageResult
-> StageRIO (Maybe SwapchainResources) ()
proceed ReleaseKey
stageRelease StageStack
rest

type StageResult = (SwapchainResources, StageAction)

proceed :: ReleaseKey -> StageStack -> StageResult -> StageRIO (Maybe SwapchainResources) ()
proceed :: ReleaseKey
-> StageStack
-> StageResult
-> StageRIO (Maybe SwapchainResources) ()
proceed ReleaseKey
stageRelease StageStack
rest (SwapchainResources
oldSR, StageAction
stageAction) = do
  Maybe SwapchainResources -> StageRIO (Maybe SwapchainResources) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (SwapchainResources -> Maybe SwapchainResources
forall a. a -> Maybe a
Just SwapchainResources
oldSR)
  case StageAction
stageAction of
    StageAction
StageDone -> do
      Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
"Stage done"
      StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack StageStack
rest
    StageReplace StackStage
nextStage -> do
      Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
"Stage replaced"
      StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack (StackStage
nextStage StackStage -> StageStack -> StageStack
forall a. a -> [a] -> [a]
: StageStack
rest)
    StagePush StackStage
frozenStage StackStage
nextStage -> do
      case StackStage
frozenStage of
        StackStage{} ->
          Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Restarting stage pushed"
        StackStageContinue{} ->
          Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Frozen stage pushed"
      StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack (StackStage
nextStage StackStage -> StageStack -> StageStack
forall a. a -> [a] -> [a]
: StackStage
frozenStage StackStage -> StageStack -> StageStack
forall a. a -> [a] -> [a]
: StageStack
rest)
  where
    releaseStage :: Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
label = do
      Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
label
      RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> StageRIO (Maybe SwapchainResources) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
 -> StageRIO (Maybe SwapchainResources) ())
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$! StageRIO (Maybe SwapchainResources) ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async do
        {-
          XXX: wait for the current render job to finish.

          Since the new frames wouldn't be submitted until the control flow
          gets back to the render loop, this should be enough of a signal that
          the stage resources aren't used anymore.

          The call is costly, but its effects aren't seen.
        -}
        (App GlobalHandles (Maybe SwapchainResources) -> Device)
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles (Maybe SwapchainResources) -> Device
forall a. HasVulkan a => a -> Device
getDevice RIO (App GlobalHandles (Maybe SwapchainResources)) Device
-> (Device -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Device -> StageRIO (Maybe SwapchainResources) ()
forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
        ReleaseKey -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageRelease
        Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> StageRIO (Maybe SwapchainResources) ())
-> Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
label Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", released"

prepareStage
  :: StageRIO env (ReleaseKey, st)
  -> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage :: forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage StageRIO env (ReleaseKey, st)
initialRS = do
  (ReleaseKey
key, st
rs) <- StageRIO env (ReleaseKey, st)
initialRS
  SomeRef st
freshStateVar <- st -> RIO (App GlobalHandles env) (SomeRef st)
forall (m :: * -> *) a. MonadIO m => a -> m (SomeRef a)
newSomeRef st
rs
  App{InternalState
LogFunc
SomeRef env
ProcessContext
GlobalHandles
appState :: forall env st. App env st -> SomeRef st
appResources :: forall env st. App env st -> InternalState
appProcessContext :: forall env st. App env st -> ProcessContext
appLogFunc :: forall env st. App env st -> LogFunc
appState :: SomeRef env
appEnv :: GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: forall env st. App env st -> env
..} <- RIO (App GlobalHandles env) (App GlobalHandles env)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let
    stageApp :: App GlobalHandles st
stageApp = App :: forall env st.
LogFunc
-> ProcessContext
-> InternalState
-> env
-> SomeRef st
-> App env st
App
      { appState :: SomeRef st
appState = SomeRef st
freshStateVar
      , InternalState
LogFunc
ProcessContext
GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: GlobalHandles
..
      }
  (ReleaseKey, StageRIO st a -> StageRIO env a)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
key, App GlobalHandles st -> StageRIO st a -> StageRIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO App GlobalHandles st
stageApp)

run
  :: RenderPass rp
  => Maybe SwapchainResources
  -> ReleaseKey
  -> Stage rp p rr st
  -> StageRIO st StageResult
run :: forall rp p rr st.
RenderPass rp =>
Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
run Maybe SwapchainResources
oldSR ReleaseKey
stKey stage :: Stage rp p rr st
stage@Stage{Text
StageRIO st a
StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
st -> rr -> StageFrameRIO rp p rr st ()
a -> StageRIO st ()
CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
$sel:sAfterLoop:Stage :: ()
$sel:sRecordCommands:Stage :: forall rp p rr st.
Stage rp p rr st
-> CommandBuffer
-> rr
-> ("image index" ::: Word32)
-> StageFrameRIO rp p rr st ()
$sel:sUpdateBuffers:Stage :: forall rp p rr st.
Stage rp p rr st -> st -> rr -> StageFrameRIO rp p rr st ()
$sel:sBeforeLoop:Stage :: ()
$sel:sInitialRR:Stage :: forall rp p rr st.
Stage rp p rr st
-> Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr
$sel:sAllocateP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> rp -> ResourceT (StageRIO st) p
$sel:sAllocateRP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> ResourceT (StageRIO st) rp
sAfterLoop :: a -> StageRIO st ()
sRecordCommands :: CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
sUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st ()
sBeforeLoop :: StageRIO st a
sInitialRR :: Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sAllocateP :: SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
sAllocateRP :: SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
sTitle :: Text
$sel:sInitialRS:Stage :: forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
$sel:sTitle:Stage :: forall rp p rr st. Stage rp p rr st -> Text
..} = do
  Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Starting stage: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle

  DataRecycler (RecycledResources rr)
recycler <- RIO (App GlobalHandles st) (DataRecycler (RecycledResources rr))
forall (m :: * -> *) a. MonadIO m => m (DataRecycler a)
DataRecycler.new

  Frame rp p rr
startFrame <- Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
forall rr rp p st.
Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
Frame.initial Maybe SwapchainResources
oldSR (DataRecycler (RecycledResources rr)
-> DumpResource (RecycledResources rr)
forall a. DataRecycler a -> DumpResource a
drDump DataRecycler (RecycledResources rr)
recycler) Stage rp p rr st
stage

  Engine.GlobalHandles{Window
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
ghWindow :: Window
ghWindow} <- (App GlobalHandles st -> GlobalHandles)
-> RIO (App GlobalHandles st) GlobalHandles
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles st -> GlobalHandles
forall env st. App env st -> env
appEnv
  Bool
quit <- IO Bool -> RIO (App GlobalHandles st) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO (App GlobalHandles st) Bool)
-> IO Bool -> RIO (App GlobalHandles st) Bool
forall a b. (a -> b) -> a -> b
$ Window -> IO Bool
GLFW.windowShouldClose Window
ghWindow
  if Bool
quit then do
    Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Forcing stage unwind for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
    pure
      ( Frame rp p rr -> SwapchainResources
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
Frame.fSwapchainResources Frame rp p rr
startFrame
      , StageAction
StageDone
      )
  else do
    Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Entering stage loop: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
    Double
startTime <- RIO (App GlobalHandles st) Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
    (Frame rp p rr
finalFrame, StageAction
stageAction) <- StageRIO st a
-> (a -> StageRIO st ())
-> (a -> RIO (App GlobalHandles st) (Frame rp p rr, StageAction))
-> RIO (App GlobalHandles st) (Frame rp p rr, StageAction)
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket StageRIO st a
sBeforeLoop a -> StageRIO st ()
sAfterLoop \a
_stagePrivates ->
      (Frame rp p rr -> StageRIO st (LoopAction (Frame rp p rr)))
-> Frame rp p rr
-> RIO (App GlobalHandles st) (Frame rp p rr, StageAction)
forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop (ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
forall rp p rr st.
RenderPass rp =>
ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
step ReleaseKey
stKey Stage rp p rr st
stage DataRecycler (RecycledResources rr)
recycler) Frame rp p rr
startFrame
    Double
endTime <- RIO (App GlobalHandles st) Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
    let
      frames :: Word64
frames  = Frame rp p rr -> Word64
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
Frame.fIndex Frame rp p rr
finalFrame
      seconds :: Double
seconds = Double
endTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
startTime

    Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Stage finished: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
    Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running time: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Double -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Double
seconds
    Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Average FPS: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Double -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
frames Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
seconds)
    RefCounted -> StageRIO st ()
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (RefCounted -> StageRIO st ()) -> RefCounted -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ (RefCounted, InternalState) -> RefCounted
forall a b. (a, b) -> a
fst (Frame rp p rr -> (RefCounted, InternalState)
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
Frame.fStageResources Frame rp p rr
finalFrame)
    pure
      ( Frame rp p rr -> SwapchainResources
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
Frame.fSwapchainResources Frame rp p rr
finalFrame
      , StageAction
stageAction
      )

step
  :: RenderPass rp
  => ReleaseKey
  -> Stage rp p rr st
  -> DataRecycler (RecycledResources rr)
  -> Frame rp p rr
  -> StageRIO st (LoopAction (Frame rp p rr))
step :: forall rp p rr st.
RenderPass rp =>
ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
step ReleaseKey
stKey stage :: Stage rp p rr st
stage@Stage{Text
StageRIO st a
StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
st -> rr -> StageFrameRIO rp p rr st ()
a -> StageRIO st ()
CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
sAfterLoop :: a -> StageRIO st ()
sRecordCommands :: CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
sUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st ()
sBeforeLoop :: StageRIO st a
sInitialRR :: Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sAllocateP :: SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
sAllocateRP :: SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
sTitle :: Text
$sel:sAfterLoop:Stage :: ()
$sel:sRecordCommands:Stage :: forall rp p rr st.
Stage rp p rr st
-> CommandBuffer
-> rr
-> ("image index" ::: Word32)
-> StageFrameRIO rp p rr st ()
$sel:sUpdateBuffers:Stage :: forall rp p rr st.
Stage rp p rr st -> st -> rr -> StageFrameRIO rp p rr st ()
$sel:sBeforeLoop:Stage :: ()
$sel:sInitialRR:Stage :: forall rp p rr st.
Stage rp p rr st
-> Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr
$sel:sAllocateP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> rp -> ResourceT (StageRIO st) p
$sel:sAllocateRP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> ResourceT (StageRIO st) rp
$sel:sInitialRS:Stage :: forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
$sel:sTitle:Stage :: forall rp p rr st. Stage rp p rr st -> Text
..} DataRecycler{WaitResource (RecycledResources rr)
DumpResource (RecycledResources rr)
$sel:drWait:DataRecycler :: forall a. DataRecycler a -> WaitResource a
drWait :: WaitResource (RecycledResources rr)
drDump :: DumpResource (RecycledResources rr)
$sel:drDump:DataRecycler :: forall a. DataRecycler a -> DumpResource a
..} Frame rp p rr
frame = do
  IO () -> StageRIO st ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
GLFW.pollEvents

  -- XXX: hard unwind all the stages, rendering nothing
  Bool
quit <- IO Bool -> RIO (App GlobalHandles st) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO (App GlobalHandles st) Bool)
-> IO Bool -> RIO (App GlobalHandles st) Bool
forall a b. (a -> b) -> a -> b
$ Window -> IO Bool
GLFW.windowShouldClose (Frame rp p rr -> Window
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
Frame.fWindow Frame rp p rr
frame)

  if Bool
quit then
    LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopAction (Frame rp p rr)
forall f. LoopAction f
LoopQuit
  else
    StageRIO st (Maybe NextStage)
forall rs. StageRIO rs (Maybe NextStage)
getNextStage StageRIO st (Maybe NextStage)
-> (Maybe NextStage -> StageRIO st (LoopAction (Frame rp p rr)))
-> StageRIO st (LoopAction (Frame rp p rr))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe NextStage
Nothing -> do
        Bool
needsNewSwapchain <- StageRIO st () -> RIO (App GlobalHandles st) Bool
forall (f :: * -> *). MonadUnliftIO f => f () -> f Bool
threwSwapchainError do
          Engine.GlobalHandles{Options
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghOptions :: Options
ghOptions} <- (App GlobalHandles st -> GlobalHandles)
-> RIO (App GlobalHandles st) GlobalHandles
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles st -> GlobalHandles
forall env st. App env st -> env
appEnv
          let recyclerWait :: Maybe Int
recyclerWait = Options -> Maybe Int
optionsRecyclerWait Options
ghOptions
          st
rs <- RIO (App GlobalHandles st) st
forall s (m :: * -> *). MonadState s m => m s
get
          DumpResource (RecycledResources rr)
-> Maybe Int
-> StageFrameRIO rp p rr st ()
-> Frame rp p rr
-> StageRIO st ()
forall env rr rp p a.
(HasLogFunc env, HasVulkan env, MonadResource (RIO env)) =>
(RecycledResources rr -> IO ())
-> Maybe Int
-> RIO (env, Frame rp p rr) a
-> Frame rp p rr
-> RIO env a
Frame.run DumpResource (RecycledResources rr)
drDump Maybe Int
recyclerWait ((rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
    -> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
forall rp rr p st.
RenderPass rp =>
(rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
    -> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
renderFrame (st -> rr -> StageFrameRIO rp p rr st ()
sUpdateBuffers st
rs) CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
sRecordCommands) Frame rp p rr
frame
        Frame rp p rr
nextFrame <- WaitResource (RecycledResources rr)
-> Frame rp p rr
-> Bool
-> RIO (App GlobalHandles st) (Frame rp p rr)
forall env rp rr p.
(HasLogFunc env, HasVulkan env, MonadResource (RIO env),
 RenderPass rp) =>
WaitResource (RecycledResources rr)
-> Frame rp p rr -> Bool -> RIO env (Frame rp p rr)
Frame.advance WaitResource (RecycledResources rr)
drWait Frame rp p rr
frame Bool
needsNewSwapchain

        pure $ Frame rp p rr -> LoopAction (Frame rp p rr)
forall f. f -> LoopAction f
LoopNextFrame Frame rp p rr
nextFrame
      Just NextStage
Finish ->
        -- XXX: finish the stage and proceed with the remaining stack
        LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopAction (Frame rp p rr)
forall f. LoopAction f
LoopQuit
      Just (Replace StackStage
nextStage) ->
        LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoopAction (Frame rp p rr)
 -> StageRIO st (LoopAction (Frame rp p rr)))
-> LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall a b. (a -> b) -> a -> b
$ Frame rp p rr -> StackStage -> LoopAction (Frame rp p rr)
forall f. f -> StackStage -> LoopAction f
LoopReplaceStage Frame rp p rr
frame StackStage
nextStage
      Just (PushRestart StackStage
nextStage) ->
        LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoopAction (Frame rp p rr)
 -> StageRIO st (LoopAction (Frame rp p rr)))
-> LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall a b. (a -> b) -> a -> b
$ Frame rp p rr
-> StackStage -> StackStage -> LoopAction (Frame rp p rr)
forall f. f -> StackStage -> StackStage -> LoopAction f
LoopPushStage Frame rp p rr
frame (Stage rp p rr st -> StackStage
forall rp p rr st. RenderPass rp => Stage rp p rr st -> StackStage
StackStage Stage rp p rr st
stage) StackStage
nextStage
      Just (PushFreeze StackStage
nextStage) -> do
        StackStage
frozen <- ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
forall rp p rr st.
RenderPass rp =>
ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
freeze ReleaseKey
stKey Stage rp p rr st
stage
        pure $ Frame rp p rr
-> StackStage -> StackStage -> LoopAction (Frame rp p rr)
forall f. f -> StackStage -> StackStage -> LoopAction f
LoopPushStage Frame rp p rr
frame StackStage
frozen StackStage
nextStage

freeze :: RenderPass rp => ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
freeze :: forall rp p rr st.
RenderPass rp =>
ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
freeze ReleaseKey
stKey Stage rp p rr st
stage = do
  st
st <- RIO (App GlobalHandles st) st
forall s (m :: * -> *). MonadState s m => m s
get
  pure $ ReleaseKey -> st -> Stage rp p rr st -> StackStage
forall rp p rr st.
RenderPass rp =>
ReleaseKey -> st -> Stage rp p rr st -> StackStage
StackStageContinue ReleaseKey
stKey st
st Stage rp p rr st
stage

data StageAction
  = StageReplace StackStage
  | StagePush StackStage StackStage
  | StageDone

data LoopAction f
  = LoopNextFrame f
  | LoopReplaceStage f StackStage
  | LoopPushStage f StackStage StackStage
  | LoopQuit

{-# INLINE stageLoop #-}
stageLoop :: (f -> StageRIO st (LoopAction f)) -> f -> StageRIO st (f, StageAction)
stageLoop :: forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop f -> StageRIO st (LoopAction f)
action f
current =
  f -> StageRIO st (LoopAction f)
action f
current StageRIO st (LoopAction f)
-> (LoopAction f -> RIO (App GlobalHandles st) (f, StageAction))
-> RIO (App GlobalHandles st) (f, StageAction)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LoopNextFrame f
nextFrame ->
      (f -> StageRIO st (LoopAction f))
-> f -> RIO (App GlobalHandles st) (f, StageAction)
forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop f -> StageRIO st (LoopAction f)
action f
nextFrame
    LoopAction f
LoopQuit ->
      (f, StageAction) -> RIO (App GlobalHandles st) (f, StageAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
current, StageAction
StageDone)
    LoopReplaceStage f
lastFrame StackStage
nextStage ->
      (f, StageAction) -> RIO (App GlobalHandles st) (f, StageAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StageAction
StageReplace StackStage
nextStage)
    LoopPushStage f
lastFrame StackStage
frozenStage StackStage
nextStage ->
      (f, StageAction) -> RIO (App GlobalHandles st) (f, StageAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StackStage -> StageAction
StagePush StackStage
frozenStage StackStage
nextStage)