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 GHC.Clock (getMonotonicTimeNSec)

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, optionsMaxFPS)
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
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Stage stack finished"
    forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe SwapchainResources
Nothing ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just SwapchainResources
oldSR ->
        forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (SwapchainResources -> RefCounted
srRelease SwapchainResources
oldSR)
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
    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
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Setting up stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (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) <- forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage (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 <- forall s (m :: * -> *). MonadState s m => m s
get
    StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (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) 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
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Resuming stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (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) <- forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage (forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
stKey, st
state))
    Maybe SwapchainResources
oldSR <- forall s (m :: * -> *). MonadState s m => m s
get
    StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (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) 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
  forall s (m :: * -> *). MonadState s m => s -> m ()
put (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 forall a. a -> [a] -> [a]
: StageStack
rest)
    StagePush StackStage
frozenStage StackStage
nextStage -> do
      case StackStage
frozenStage of
        StackStage{} ->
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Restarting stage pushed"
        StackStageContinue{} ->
          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 forall a. a -> [a] -> [a]
: StackStage
frozenStage forall a. a -> [a] -> [a]
: StageStack
rest)
  where
    releaseStage :: Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
label = do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
label
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! 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.
        -}
        forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
        forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageRelease
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
label 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 <- forall (m :: * -> *) a. MonadIO m => a -> m (SomeRef a)
newSomeRef st
rs
  App{InternalState
ProcessContext
SomeRef env
LogFunc
GlobalHandles
appLogFunc :: forall env st. App env st -> LogFunc
appProcessContext :: forall env st. App env st -> ProcessContext
appResources :: forall env st. App env st -> InternalState
appState :: forall env st. App env st -> SomeRef st
appState :: SomeRef env
appEnv :: GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: forall env st. App env st -> env
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let
    stageApp :: App GlobalHandles st
stageApp = App
      { appState :: SomeRef st
appState = SomeRef st
freshStateVar
      , InternalState
ProcessContext
LogFunc
GlobalHandles
appLogFunc :: LogFunc
appProcessContext :: ProcessContext
appResources :: InternalState
appEnv :: GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: GlobalHandles
..
      }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
key, 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
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Starting stage: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle

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

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

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Stage finished: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running time: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Double
seconds
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Average FPS: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
frames forall a. Fractional a => a -> a -> a
/ Double
seconds)
    forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
Frame.fStageResources Frame rp p rr
finalFrame)
    pure
      ( 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)
  -> Maybe Int
  -> 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)
-> Maybe Int
-> 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
..} Maybe Int
maxFPSM Frame rp p rr
frame = do
  Word64
startTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
GLFW.pollEvents

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

  if Bool
quit then
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall f. LoopAction f
LoopQuit
  else
    forall rs. StageRIO rs (Maybe NextStage)
getNextStage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe NextStage
Nothing -> do
        Bool
needsNewSwapchain <- forall (f :: * -> *). MonadUnliftIO f => f () -> f Bool
threwSwapchainError do
          Engine.GlobalHandles{Options
ghOptions :: Options
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghOptions} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env st. App env st -> env
appEnv
          let recyclerWait :: Maybe Int
recyclerWait = Options -> Maybe Int
optionsRecyclerWait Options
ghOptions
          st
rs <- forall s (m :: * -> *). MonadState s m => m s
get
          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 (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 <- 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

        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
maxFPSM \Int
maxFPS -> do
          -- Wait until the end of allocated time.
          Word64
endTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
          let elapsedUS :: Int
elapsedUS = (forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ Word64
endTime forall a. Num a => a -> a -> a
- Word64
startTime) forall a. Integral a => a -> a -> a
`div` Int
1e3 :: Int
              fpsCapUS :: Int
fpsCapUS = Int
1e6 forall a. Integral a => a -> a -> a
`div` Int
maxFPS
              waitUS :: Int
waitUS = Int
fpsCapUS forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
min Int
fpsCapUS Int
elapsedUS
          forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
waitUS

        pure $ forall f. f -> LoopAction f
LoopNextFrame Frame rp p rr
nextFrame
      Just NextStage
Finish ->
        -- XXX: finish the stage and proceed with the remaining stack
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall f. LoopAction f
LoopQuit
      Just (Replace StackStage
nextStage) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f. f -> StackStage -> LoopAction f
LoopReplaceStage Frame rp p rr
frame StackStage
nextStage
      Just (PushRestart StackStage
nextStage) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f. f -> StackStage -> StackStage -> LoopAction f
LoopPushStage Frame rp p rr
frame (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 <- 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 $ 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 <- forall s (m :: * -> *). MonadState s m => m s
get
  pure $ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    LoopNextFrame f
nextFrame ->
      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 ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
current, StageAction
StageDone)
    LoopReplaceStage f
lastFrame StackStage
nextStage ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StageAction
StageReplace StackStage
nextStage)
    LoopPushStage f
lastFrame StackStage
frozenStage StackStage
nextStage ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StackStage -> StageAction
StagePush StackStage
frozenStage StackStage
nextStage)