{-| Per-frame window loop shared by windowed applications.

The skeleton — read swapchain, run a frame inside @runFrame@, recreate on
'Vulkan.Utils.Swapchain.threwSwapchainError', advance — is the same for any
windowed Vulkan app. Each consumer only varies in:

* the per-swapchain state it holds (framebuffers, descriptor sets, …),
* the per-frame render action, and
* the "what to do on exit / per-frame metric" hooks.

'runWindowLoop' takes those four points as fields of a 'WindowLoop' record.
-}
module Vulkan.Utils.WindowLoop
  ( WindowLoop (..)
  , runWindowLoop
  , noWindowState
  , noOnFrame
  , noOnExit
  ) where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
  ( ReleaseKey
  , ResourceT
  , register
  , release
  )
import Data.IORef
import Data.Word (Word64)
import GHC.Clock (getMonotonicTimeNSec)
import qualified Vulkan.Core10 as Vk
import Vulkan.Utils.Frame (Frame (..), advanceFrame, drainFrames, initialFrame, runFrame)
import Vulkan.Utils.Swapchain (Swapchain, recreateSwapchain, threwSwapchainError)
import Vulkan.Utils.VulkanContext (VulkanContext (..))

data WindowLoop s = WindowLoop
  { forall s. WindowLoop s -> Swapchain -> ResourceT IO (s, ReleaseKey)
wlMkState :: Swapchain -> ResourceT IO (s, ReleaseKey)
  {- ^ Build per-swapchain state. The release key is fired when the
  swapchain is recreated and a fresh state replaces this one.
  -}
  , forall s. WindowLoop s -> s -> Frame -> ResourceT IO ()
wlRender :: s -> Frame -> ResourceT IO ()
  -- ^ Per-frame render action; runs inside @runFrame@.
  , forall s. WindowLoop s -> Word64 -> Word64 -> ResourceT IO ()
wlOnFrame :: Word64 -> Word64 -> ResourceT IO ()
  {- ^ Optional metric hook with start/end nanoseconds around 'runFrame'.
  Use 'noOnFrame' if you don't care.
  -}
  , forall s. WindowLoop s -> Frame -> ResourceT IO ()
wlOnExit :: Frame -> ResourceT IO ()
  -- ^ Fired once when the window closes. Use 'noOnExit' if you don't care.
  }

runWindowLoop
  :: VulkanContext
  -> Swapchain
  -> IO Vk.Extent2D
  -- ^ Get current drawable size (called on resize)
  -> IO Bool
  -- ^ Per-frame poller; 'True' means quit
  -> WindowLoop s
  -> ResourceT IO ()
runWindowLoop :: forall s.
VulkanContext
-> Swapchain
-> IO Extent2D
-> IO Bool
-> WindowLoop s
-> ResourceT IO ()
runWindowLoop VulkanContext
vc Swapchain
initialSC IO Extent2D
getSize IO Bool
shouldQuit WindowLoop{s -> Frame -> ResourceT IO ()
Word64 -> Word64 -> ResourceT IO ()
Swapchain -> ResourceT IO (s, ReleaseKey)
Frame -> ResourceT IO ()
wlMkState :: forall s. WindowLoop s -> Swapchain -> ResourceT IO (s, ReleaseKey)
wlRender :: forall s. WindowLoop s -> s -> Frame -> ResourceT IO ()
wlOnFrame :: forall s. WindowLoop s -> Word64 -> Word64 -> ResourceT IO ()
wlOnExit :: forall s. WindowLoop s -> Frame -> ResourceT IO ()
wlMkState :: Swapchain -> ResourceT IO (s, ReleaseKey)
wlRender :: s -> Frame -> ResourceT IO ()
wlOnFrame :: Word64 -> Word64 -> ResourceT IO ()
wlOnExit :: Frame -> ResourceT IO ()
..} = do
  initialState <- Swapchain -> ResourceT IO (s, ReleaseKey)
wlMkState Swapchain
initialSC
  scRef <- liftIO $ newIORef initialSC
  stRef <- liftIO $ newIORef initialState
  initial <- initialFrame vc initialSC
  let
    perFrame Frame
f = do
      currentSC <- IO Swapchain -> ResourceT IO Swapchain
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Swapchain -> ResourceT IO Swapchain)
-> IO Swapchain -> ResourceT IO Swapchain
forall a b. (a -> b) -> a -> b
$ IORef Swapchain -> IO Swapchain
forall a. IORef a -> IO a
readIORef IORef Swapchain
scRef
      (st, _) <- liftIO $ readIORef stRef
      let f' = Frame
f{fSwapchain = currentSC}
      startNs <- liftIO getMonotonicTimeNSec
      needsNew <-
        liftIO . threwSwapchainError $
          runFrame vc f' (wlRender st f')
      endNs <- liftIO getMonotonicTimeNSec
      wlOnFrame startNs endNs
      sc' <-
        if needsNew
          then do
            newSize <- liftIO getSize
            -- A swapchain recreation retires the old swapchain. Drain the
            -- graphics/present queue first so the old swapchain's pending
            -- presents — and this frame's GPU work behind the old
            -- per-swapchain state — all complete before we free the old
            -- per-image present-wait semaphores, the old swapchain, and the
            -- old state. A present-wait semaphore cannot otherwise be known
            -- idle (its present has no host-visible completion without
            -- VK_KHR_swapchain_maintenance1). Recreation is rare, so this
            -- one-shot wait is cheap.
            Vk.deviceWaitIdle (vcDevice vc)
            sc' <- recreateSwapchain (vcPhysicalDevice vc) (vcDevice vc) newSize currentSC
            (newSt, newKey) <- wlMkState sc'
            (_, oldKey) <- liftIO $ readIORef stRef
            release oldKey
            liftIO $ writeIORef scRef sc'
            liftIO $ writeIORef stRef (newSt, newKey)
            pure sc'
          else pure currentSC
      advanceFrame vc sc' f'

    loop Frame
f =
      IO Bool -> ResourceT IO Bool
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
shouldQuit ResourceT IO Bool
-> (Bool -> ResourceT IO (Maybe Frame))
-> ResourceT IO (Maybe Frame)
forall a b.
ResourceT IO a -> (a -> ResourceT IO b) -> ResourceT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> do
          Device -> ResourceT IO ()
forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle (VulkanContext -> Device
vcDevice VulkanContext
vc)
          Frame -> ResourceT IO ()
wlOnExit Frame
f
          IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ VulkanContext -> Frame -> IO ()
drainFrames VulkanContext
vc Frame
f
          Maybe Frame -> ResourceT IO (Maybe Frame)
forall a. a -> ResourceT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Frame
forall a. Maybe a
Nothing
        Bool
False -> Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Frame -> Maybe Frame)
-> ResourceT IO Frame -> ResourceT IO (Maybe Frame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Frame -> ResourceT IO Frame
perFrame Frame
f
  loopJust loop initial

-- | 'wlMkState' for callers that have no per-swapchain state.
noWindowState :: Swapchain -> ResourceT IO ((), ReleaseKey)
noWindowState :: Swapchain -> ResourceT IO ((), ReleaseKey)
noWindowState Swapchain
_ = do
  key <- IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  pure ((), key)

noOnFrame :: Word64 -> Word64 -> ResourceT IO ()
noOnFrame :: Word64 -> Word64 -> ResourceT IO ()
noOnFrame Word64
_ Word64
_ = () -> ResourceT IO ()
forall a. a -> ResourceT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

noOnExit :: Frame -> ResourceT IO ()
noOnExit :: Frame -> ResourceT IO ()
noOnExit Frame
_ = () -> ResourceT IO ()
forall a. a -> ResourceT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

loopJust :: (Monad m) => (a -> m (Maybe a)) -> a -> m ()
loopJust :: forall (m :: * -> *) a. Monad m => (a -> m (Maybe a)) -> a -> m ()
loopJust a -> m (Maybe a)
f a
x =
  a -> m (Maybe a)
f a
x m (Maybe a) -> (Maybe a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe a
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just a
x' -> (a -> m (Maybe a)) -> a -> m ()
forall (m :: * -> *) a. Monad m => (a -> m (Maybe a)) -> a -> m ()
loopJust a -> m (Maybe a)
f a
x'