{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}

-- |
-- Module      : WGPU.Internal.SwapChain
-- Description : Swap chain.
module WGPU.Internal.SwapChain
  ( -- * Types
    SwapChain,
    SwapChainDescriptor (..),
    PresentMode (..),

    -- * Functions
    getSwapChainPreferredFormat,
    createSwapChain,
    getSwapChainCurrentTextureView,
    swapChainPresent,
  )
where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Text (Text)
import Data.Word (Word32)
import Foreign (Ptr, nullPtr)
import WGPU.Internal.Adapter (Adapter, wgpuAdapter)
import WGPU.Internal.Device (Device, deviceInst, wgpuDevice)
import WGPU.Internal.Instance (Instance, wgpuHsInstance)
import WGPU.Internal.Memory
  ( ToRaw,
    evalContT,
    freeHaskellFunPtr,
    newEmptyMVar,
    putMVar,
    raw,
    rawPtr,
    showWithPtr,
    takeMVar,
  )
import WGPU.Internal.Surface (Surface, surfaceInst, wgpuSurface)
import WGPU.Internal.Texture (TextureFormat, TextureUsage, TextureView (TextureView), textureFormatFromRaw)
import WGPU.Raw.Generated.Enum.WGPUPresentMode (WGPUPresentMode)
import qualified WGPU.Raw.Generated.Enum.WGPUPresentMode as WGPUPresentMode
import WGPU.Raw.Generated.Enum.WGPUTextureFormat (WGPUTextureFormat (WGPUTextureFormat))
import qualified WGPU.Raw.Generated.Fun as RawFun
import WGPU.Raw.Generated.Struct.WGPUSwapChainDescriptor (WGPUSwapChainDescriptor)
import qualified WGPU.Raw.Generated.Struct.WGPUSwapChainDescriptor as WGPUSwapChainDescriptor
import WGPU.Raw.Types (WGPUSurfaceGetPreferredFormatCallback, WGPUSwapChain (WGPUSwapChain))

-------------------------------------------------------------------------------

data SwapChain = SwapChain
  { SwapChain -> Instance
swapChainInst :: !Instance,
    SwapChain -> WGPUSwapChain
wgpuSwapChain :: !WGPUSwapChain
  }

instance Show SwapChain where
  show :: SwapChain -> String
show SwapChain
s =
    let SwapChain Instance
_ (WGPUSwapChain Ptr ()
ptr) = SwapChain
s
     in String -> Ptr () -> String
forall a. String -> Ptr a -> String
showWithPtr String
"SwapChain" Ptr ()
ptr

instance Eq SwapChain where
  == :: SwapChain -> SwapChain -> Bool
(==) SwapChain
s1 SwapChain
s2 =
    let SwapChain Instance
_ (WGPUSwapChain Ptr ()
s1_ptr) = SwapChain
s1
        SwapChain Instance
_ (WGPUSwapChain Ptr ()
s2_ptr) = SwapChain
s2
     in Ptr ()
s1_ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
s2_ptr

instance ToRaw SwapChain WGPUSwapChain where
  raw :: SwapChain -> ContT r IO WGPUSwapChain
raw = WGPUSwapChain -> ContT r IO WGPUSwapChain
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUSwapChain -> ContT r IO WGPUSwapChain)
-> (SwapChain -> WGPUSwapChain)
-> SwapChain
-> ContT r IO WGPUSwapChain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapChain -> WGPUSwapChain
wgpuSwapChain

-------------------------------------------------------------------------------

-- | Describes a swapchain.
data SwapChainDescriptor = SwapChainDescriptor
  { -- | Debugging label for the swap chain.
    SwapChainDescriptor -> Text
swapChainLabel :: !Text,
    -- | The usage of the swap chain. The only supported usage is
    --   'TextureUsageRenderAttachment'.
    SwapChainDescriptor -> TextureUsage
usage :: !TextureUsage,
    -- | Texture format of the swap chain. The only guaranteed formats are
    -- 'TextureFormatBgra8Unorm' and 'TextureFormatBgra8UnormSrgb'. To
    -- determine the preferred texture format for a surface, use the
    -- 'getSwapChainPreferredFormat' function.
    SwapChainDescriptor -> TextureFormat
swapChainFormat :: !TextureFormat,
    -- | Width of the swap chain. Must be the same size as the surface.
    SwapChainDescriptor -> Word32
swapChainWidth :: !Word32,
    -- | Height of the swap chain. Must be the same size as the surface.
    SwapChainDescriptor -> Word32
swapChainHeight :: !Word32,
    -- | Presentation mode of the swap chain.
    SwapChainDescriptor -> PresentMode
presentMode :: !PresentMode
  }
  deriving (SwapChainDescriptor -> SwapChainDescriptor -> Bool
(SwapChainDescriptor -> SwapChainDescriptor -> Bool)
-> (SwapChainDescriptor -> SwapChainDescriptor -> Bool)
-> Eq SwapChainDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SwapChainDescriptor -> SwapChainDescriptor -> Bool
$c/= :: SwapChainDescriptor -> SwapChainDescriptor -> Bool
== :: SwapChainDescriptor -> SwapChainDescriptor -> Bool
$c== :: SwapChainDescriptor -> SwapChainDescriptor -> Bool
Eq, Int -> SwapChainDescriptor -> ShowS
[SwapChainDescriptor] -> ShowS
SwapChainDescriptor -> String
(Int -> SwapChainDescriptor -> ShowS)
-> (SwapChainDescriptor -> String)
-> ([SwapChainDescriptor] -> ShowS)
-> Show SwapChainDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SwapChainDescriptor] -> ShowS
$cshowList :: [SwapChainDescriptor] -> ShowS
show :: SwapChainDescriptor -> String
$cshow :: SwapChainDescriptor -> String
showsPrec :: Int -> SwapChainDescriptor -> ShowS
$cshowsPrec :: Int -> SwapChainDescriptor -> ShowS
Show)

instance ToRaw SwapChainDescriptor WGPUSwapChainDescriptor where
  raw :: SwapChainDescriptor -> ContT r IO WGPUSwapChainDescriptor
raw SwapChainDescriptor {Word32
Text
TextureFormat
TextureUsage
PresentMode
presentMode :: PresentMode
swapChainHeight :: Word32
swapChainWidth :: Word32
swapChainFormat :: TextureFormat
usage :: TextureUsage
swapChainLabel :: Text
presentMode :: SwapChainDescriptor -> PresentMode
swapChainHeight :: SwapChainDescriptor -> Word32
swapChainWidth :: SwapChainDescriptor -> Word32
swapChainFormat :: SwapChainDescriptor -> TextureFormat
usage :: SwapChainDescriptor -> TextureUsage
swapChainLabel :: SwapChainDescriptor -> Text
..} = do
    Ptr CChar
label_ptr <- Text -> ContT r IO (Ptr CChar)
forall a b r. ToRawPtr a b => a -> ContT r IO (Ptr b)
rawPtr Text
swapChainLabel
    Word32
n_usage <- TextureUsage -> ContT r IO Word32
forall a b r. ToRaw a b => a -> ContT r IO b
raw TextureUsage
usage
    WGPUTextureFormat
n_format <- TextureFormat -> ContT r IO WGPUTextureFormat
forall a b r. ToRaw a b => a -> ContT r IO b
raw TextureFormat
swapChainFormat
    WGPUPresentMode
n_presentMode <- PresentMode -> ContT r IO WGPUPresentMode
forall a b r. ToRaw a b => a -> ContT r IO b
raw PresentMode
presentMode
    WGPUSwapChainDescriptor -> ContT r IO WGPUSwapChainDescriptor
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      WGPUSwapChainDescriptor :: Ptr WGPUChainedStruct
-> Ptr CChar
-> Word32
-> WGPUTextureFormat
-> Word32
-> Word32
-> WGPUPresentMode
-> WGPUSwapChainDescriptor
WGPUSwapChainDescriptor.WGPUSwapChainDescriptor
        { nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr,
          label :: Ptr CChar
label = Ptr CChar
label_ptr,
          usage :: Word32
usage = Word32
n_usage,
          format :: WGPUTextureFormat
format = WGPUTextureFormat
n_format,
          width :: Word32
width = Word32
swapChainWidth,
          height :: Word32
height = Word32
swapChainHeight,
          presentMode :: WGPUPresentMode
presentMode = WGPUPresentMode
n_presentMode
        }

-------------------------------------------------------------------------------

-- | Behaviour of the presentation engine based on frame rate.
data PresentMode
  = -- | The presentation engine does __not__ wait for a vertical blanking
    -- period and the request is presented immediately. This is a low-latency
    -- presentation mode, but visible tearing may be observed. Will fallback to
    -- @Fifo@ if unavailable on the selected platform and backend. Not optimal
    -- for mobile.
    PresentModeImmediate
  | -- | The presentation engine waits for the next vertical blanking period to
    -- update the current image, but frames may be submitted without delay. This
    -- is a low-latency presentation mode and visible tearing will not be
    -- observed. Will fallback to Fifo if unavailable on the selected platform
    -- and backend. Not optimal for mobile.
    PresentModeMailbox
  | -- | The presentation engine waits for the next vertical blanking period to
    -- update the current image. The framerate will be capped at the display
    -- refresh rate, corresponding to the VSync. Tearing cannot be observed.
    -- Optimal for mobile.
    PresentModeFifo
  deriving (PresentMode -> PresentMode -> Bool
(PresentMode -> PresentMode -> Bool)
-> (PresentMode -> PresentMode -> Bool) -> Eq PresentMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PresentMode -> PresentMode -> Bool
$c/= :: PresentMode -> PresentMode -> Bool
== :: PresentMode -> PresentMode -> Bool
$c== :: PresentMode -> PresentMode -> Bool
Eq, Int -> PresentMode -> ShowS
[PresentMode] -> ShowS
PresentMode -> String
(Int -> PresentMode -> ShowS)
-> (PresentMode -> String)
-> ([PresentMode] -> ShowS)
-> Show PresentMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PresentMode] -> ShowS
$cshowList :: [PresentMode] -> ShowS
show :: PresentMode -> String
$cshow :: PresentMode -> String
showsPrec :: Int -> PresentMode -> ShowS
$cshowsPrec :: Int -> PresentMode -> ShowS
Show)

instance ToRaw PresentMode WGPUPresentMode where
  raw :: PresentMode -> ContT r IO WGPUPresentMode
raw PresentMode
pm =
    WGPUPresentMode -> ContT r IO WGPUPresentMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUPresentMode -> ContT r IO WGPUPresentMode)
-> WGPUPresentMode -> ContT r IO WGPUPresentMode
forall a b. (a -> b) -> a -> b
$
      case PresentMode
pm of
        PresentMode
PresentModeImmediate -> WGPUPresentMode
forall a. (Eq a, Num a) => a
WGPUPresentMode.Immediate
        PresentMode
PresentModeMailbox -> WGPUPresentMode
forall a. (Eq a, Num a) => a
WGPUPresentMode.Mailbox
        PresentMode
PresentModeFifo -> WGPUPresentMode
forall a. (Eq a, Num a) => a
WGPUPresentMode.Fifo

-------------------------------------------------------------------------------

-- | Returns an optimal texture format to use for the swapchain with this
--   adapter and surface.
getSwapChainPreferredFormat ::
  MonadIO m =>
  -- | @Surface@ for which to obtain an optimal texture format.
  Surface ->
  -- | @Adapter@ for which to obtain an optimal texture format.
  Adapter ->
  -- | IO action which returns the optimal texture format.
  m TextureFormat
getSwapChainPreferredFormat :: Surface -> Adapter -> m TextureFormat
getSwapChainPreferredFormat Surface
surface Adapter
adapter = do
  let inst :: Instance
inst = Surface -> Instance
surfaceInst Surface
surface

  MVar WGPUTextureFormat
textureFormatMVar <- m (MVar WGPUTextureFormat)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  WGPUSurfaceGetPreferredFormatCallback
callback <-
    (WGPUTextureFormat -> Ptr () -> IO ())
-> m WGPUSurfaceGetPreferredFormatCallback
forall (m :: * -> *).
MonadIO m =>
(WGPUTextureFormat -> Ptr () -> IO ())
-> m WGPUSurfaceGetPreferredFormatCallback
mkSurfaceGetPreferredFormatCallback (\WGPUTextureFormat
tf Ptr ()
_ -> MVar WGPUTextureFormat -> WGPUTextureFormat -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar WGPUTextureFormat
textureFormatMVar WGPUTextureFormat
tf)

  WGPUHsInstance
-> WGPUSurface
-> WGPUAdapter
-> WGPUSurfaceGetPreferredFormatCallback
-> Ptr ()
-> m ()
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance
-> WGPUSurface
-> WGPUAdapter
-> WGPUSurfaceGetPreferredFormatCallback
-> Ptr ()
-> m ()
RawFun.wgpuSurfaceGetPreferredFormat
    (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
    (Surface -> WGPUSurface
wgpuSurface Surface
surface)
    (Adapter -> WGPUAdapter
wgpuAdapter Adapter
adapter)
    WGPUSurfaceGetPreferredFormatCallback
callback
    Ptr ()
forall a. Ptr a
nullPtr

  TextureFormat
textureFormat <- WGPUTextureFormat -> TextureFormat
textureFormatFromRaw (WGPUTextureFormat -> TextureFormat)
-> m WGPUTextureFormat -> m TextureFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar WGPUTextureFormat -> m WGPUTextureFormat
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar WGPUTextureFormat
textureFormatMVar
  WGPUSurfaceGetPreferredFormatCallback -> m ()
forall (m :: * -> *) a. MonadIO m => FunPtr a -> m ()
freeHaskellFunPtr WGPUSurfaceGetPreferredFormatCallback
callback
  TextureFormat -> m TextureFormat
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextureFormat
textureFormat

mkSurfaceGetPreferredFormatCallback ::
  MonadIO m =>
  (WGPUTextureFormat -> Ptr () -> IO ()) ->
  m WGPUSurfaceGetPreferredFormatCallback
mkSurfaceGetPreferredFormatCallback :: (WGPUTextureFormat -> Ptr () -> IO ())
-> m WGPUSurfaceGetPreferredFormatCallback
mkSurfaceGetPreferredFormatCallback =
  IO WGPUSurfaceGetPreferredFormatCallback
-> m WGPUSurfaceGetPreferredFormatCallback
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WGPUSurfaceGetPreferredFormatCallback
 -> m WGPUSurfaceGetPreferredFormatCallback)
-> ((WGPUTextureFormat -> Ptr () -> IO ())
    -> IO WGPUSurfaceGetPreferredFormatCallback)
-> (WGPUTextureFormat -> Ptr () -> IO ())
-> m WGPUSurfaceGetPreferredFormatCallback
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WGPUTextureFormat -> Ptr () -> IO ())
-> IO WGPUSurfaceGetPreferredFormatCallback
mkSurfaceGetPreferredFormatCallbackIO

foreign import ccall "wrapper"
  mkSurfaceGetPreferredFormatCallbackIO ::
    (WGPUTextureFormat -> Ptr () -> IO ()) ->
    IO WGPUSurfaceGetPreferredFormatCallback

-------------------------------------------------------------------------------

-- | Createa a new 'SwapChain' which targets a 'Surface'.
--
-- To determine the preferred 'TextureFormat' for the 'Surface', use the
-- 'getSwapChainPreferredFormat' function.
createSwapChain ::
  MonadIO m =>
  -- | @Device@ for which the @SwapChain@ will be created.
  Device ->
  -- | @Surface@ for which the @SwapChain@ will be created.
  Surface ->
  -- | Description of the @SwapChain@ to be created.
  SwapChainDescriptor ->
  -- | IO action which creates the swap chain.
  m SwapChain
createSwapChain :: Device -> Surface -> SwapChainDescriptor -> m SwapChain
createSwapChain Device
device Surface
surface SwapChainDescriptor
scd = IO SwapChain -> m SwapChain
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SwapChain -> m SwapChain)
-> (ContT SwapChain IO SwapChain -> IO SwapChain)
-> ContT SwapChain IO SwapChain
-> m SwapChain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContT SwapChain IO SwapChain -> IO SwapChain
forall (m :: * -> *) a. Monad m => ContT a m a -> m a
evalContT (ContT SwapChain IO SwapChain -> m SwapChain)
-> ContT SwapChain IO SwapChain -> m SwapChain
forall a b. (a -> b) -> a -> b
$ do
  let inst :: Instance
inst = Device -> Instance
deviceInst Device
device
  Ptr WGPUSwapChainDescriptor
swapChainDescriptor_ptr <- SwapChainDescriptor
-> ContT SwapChain IO (Ptr WGPUSwapChainDescriptor)
forall a b r. ToRawPtr a b => a -> ContT r IO (Ptr b)
rawPtr SwapChainDescriptor
scd
  WGPUSwapChain
rawSwapChain <-
    WGPUHsInstance
-> WGPUDevice
-> WGPUSurface
-> Ptr WGPUSwapChainDescriptor
-> ContT SwapChain IO WGPUSwapChain
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance
-> WGPUDevice
-> WGPUSurface
-> Ptr WGPUSwapChainDescriptor
-> m WGPUSwapChain
RawFun.wgpuDeviceCreateSwapChain
      (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
      (Device -> WGPUDevice
wgpuDevice Device
device)
      (Surface -> WGPUSurface
wgpuSurface Surface
surface)
      Ptr WGPUSwapChainDescriptor
swapChainDescriptor_ptr
  SwapChain -> ContT SwapChain IO SwapChain
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instance -> WGPUSwapChain -> SwapChain
SwapChain Instance
inst WGPUSwapChain
rawSwapChain)

-------------------------------------------------------------------------------

-- | Get the 'TextureView' for the current swap chain frame.
getSwapChainCurrentTextureView ::
  MonadIO m =>
  -- | Swap chain from which to fetch the current texture view.
  SwapChain ->
  -- | IO action which returns the current swap chain texture view.
  m TextureView
getSwapChainCurrentTextureView :: SwapChain -> m TextureView
getSwapChainCurrentTextureView SwapChain
swapChain = do
  let inst :: Instance
inst = SwapChain -> Instance
swapChainInst SwapChain
swapChain
  WGPUTextureView -> TextureView
TextureView
    (WGPUTextureView -> TextureView)
-> m WGPUTextureView -> m TextureView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WGPUHsInstance -> WGPUSwapChain -> m WGPUTextureView
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance -> WGPUSwapChain -> m WGPUTextureView
RawFun.wgpuSwapChainGetCurrentTextureView
      (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
      (SwapChain -> WGPUSwapChain
wgpuSwapChain SwapChain
swapChain)

-------------------------------------------------------------------------------

-- | Present the latest swap chain image.
swapChainPresent ::
  MonadIO m =>
  -- | Swap chain to present.
  SwapChain ->
  -- | IO action which presents the swap chain image.
  m ()
swapChainPresent :: SwapChain -> m ()
swapChainPresent SwapChain
swapChain = do
  let inst :: Instance
inst = SwapChain -> Instance
swapChainInst SwapChain
swapChain
  WGPUHsInstance -> WGPUSwapChain -> m ()
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance -> WGPUSwapChain -> m ()
RawFun.wgpuSwapChainPresent (Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst) (SwapChain -> WGPUSwapChain
wgpuSwapChain SwapChain
swapChain)