{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
module WGPU.Internal.SwapChain
(
SwapChain,
SwapChainDescriptor (..),
PresentMode (..),
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
data SwapChainDescriptor = SwapChainDescriptor
{
SwapChainDescriptor -> Text
swapChainLabel :: !Text,
SwapChainDescriptor -> TextureUsage
usage :: !TextureUsage,
SwapChainDescriptor -> TextureFormat
swapChainFormat :: !TextureFormat,
SwapChainDescriptor -> Word32
swapChainWidth :: !Word32,
SwapChainDescriptor -> Word32
swapChainHeight :: !Word32,
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
}
data PresentMode
=
PresentModeImmediate
|
PresentModeMailbox
|
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
getSwapChainPreferredFormat ::
MonadIO m =>
Surface ->
Adapter ->
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
createSwapChain ::
MonadIO m =>
Device ->
Surface ->
SwapChainDescriptor ->
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)
getSwapChainCurrentTextureView ::
MonadIO m =>
SwapChain ->
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)
swapChainPresent ::
MonadIO m =>
SwapChain ->
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)