WindowLoop.hs

{-| 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
  , noRecycledResources
  , 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 (..), InitRecycledResources, advanceFrame, drainFrames, initialFrame, runFrame)
import Vulkan.Utils.Swapchain (Swapchain, recreateSwapchain, threwSwapchainError)
import Vulkan.Utils.VulkanContext (VulkanContext (..))

data WindowLoop s rr = WindowLoop
  { 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.
  -}
  , wlMkRecycled :: InitRecycledResources (ResourceT IO) rr
  , wlRender :: s -> Frame rr -> ResourceT IO ()
  -- ^ Per-frame render action; runs inside @runFrame@.
  , wlOnFrame :: Word64 -> Word64 -> ResourceT IO ()
  {- ^ Optional metric hook with start/end nanoseconds around 'runFrame'.
  Use 'noOnFrame' if you don't care.
  -}
  , wlOnExit :: Frame rr -> ResourceT IO ()
  -- ^ Fired once when the window closes. Use 'noOnExit' if you don't care.
  }

runWindowLoop
  :: VulkanContext rr
  -> Swapchain
  -> IO Vk.Extent2D
  -- ^ Get current drawable size (called on resize)
  -> IO Bool
  -- ^ Per-frame poller; 'True' means quit
  -> WindowLoop s rr
  -> ResourceT IO ()
runWindowLoop vc initialSC getSize shouldQuit WindowLoop{..} = do
  initialState <- wlMkState initialSC
  scRef <- liftIO $ newIORef initialSC
  stRef <- liftIO $ newIORef initialState
  initial <- initialFrame vc initialSC wlMkRecycled
  let
    perFrame f = do
      currentSC <- liftIO $ readIORef scRef
      (st, _) <- liftIO $ readIORef stRef
      let f' = 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
            -- Free the old state before building its replacement: recreation
            -- already retired the old swapchain's images, so the new state may
            -- be handed their recycled handles — any bookkeeping the old state
            -- keys on them must be gone before wlMkState re-wraps.
            (_, oldKey) <- liftIO $ readIORef stRef
            release oldKey
            (newSt, newKey) <- wlMkState sc'
            liftIO $ writeIORef scRef sc'
            liftIO $ writeIORef stRef (newSt, newKey)
            pure sc'
          else pure currentSC
      advanceFrame vc sc' f'

    loop f =
      liftIO shouldQuit >>= \case
        True -> do
          Vk.deviceWaitIdle (vcDevice vc)
          wlOnExit f
          liftIO $ drainFrames vc f
          pure Nothing
        False -> Just <$> perFrame f
  loopJust loop initial

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

noRecycledResources :: (Applicative m) => InitRecycledResources m ()
noRecycledResources _vc _dbIx _pools = pure ()

noOnFrame :: Word64 -> Word64 -> ResourceT IO ()
noOnFrame _ _ = pure ()

noOnExit :: Frame rr -> ResourceT IO ()
noOnExit _ = pure ()

loopJust :: (Monad m) => (a -> m (Maybe a)) -> a -> m ()
loopJust f x =
  f x >>= \case
    Nothing -> pure ()
    Just x' -> loopJust f x'