{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
module WGPU.Internal.Device
(
Device (..),
DeviceDescriptor (..),
Features (..),
Limits (..),
requestDevice,
)
where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Default (Default, def)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word (Word32)
import Foreign (Ptr, nullPtr)
import WGPU.Internal.Adapter (Adapter, adapterInst, wgpuAdapter)
import WGPU.Internal.ChainedStruct (ChainedStruct (EmptyChain, PtrChain))
import WGPU.Internal.Instance (Instance, wgpuHsInstance)
import WGPU.Internal.Memory
( ToRaw,
evalContT,
freeHaskellFunPtr,
newEmptyMVar,
putMVar,
raw,
rawPtr,
showWithPtr,
takeMVar,
withCZeroingAfter,
)
import WGPU.Raw.Generated.Enum.WGPUNativeFeature (WGPUNativeFeature)
import qualified WGPU.Raw.Generated.Enum.WGPUNativeFeature as WGPUNativeFeature
import qualified WGPU.Raw.Generated.Enum.WGPUNativeSType as WGPUSType
import qualified WGPU.Raw.Generated.Fun as RawFun
import qualified WGPU.Raw.Generated.Struct.WGPUDeviceDescriptor as WGPUDeviceDescriptor
import WGPU.Raw.Generated.Struct.WGPUDeviceExtras (WGPUDeviceExtras)
import qualified WGPU.Raw.Generated.Struct.WGPUDeviceExtras as WGPUDeviceExtras
import WGPU.Raw.Types (WGPUDevice (WGPUDevice), WGPURequestDeviceCallback)
data Device = Device
{ Device -> Instance
deviceInst :: !Instance,
Device -> WGPUDevice
wgpuDevice :: !WGPUDevice
}
instance Show Device where
show :: Device -> String
show Device
d =
let Device Instance
_ (WGPUDevice Ptr ()
ptr) = Device
d
in String -> Ptr () -> String
forall a. String -> Ptr a -> String
showWithPtr String
"Device" Ptr ()
ptr
instance Eq Device where
== :: Device -> Device -> Bool
(==) Device
d1 Device
d2 =
let Device Instance
_ (WGPUDevice Ptr ()
d1_ptr) = Device
d1
Device Instance
_ (WGPUDevice Ptr ()
d2_ptr) = Device
d2
in Ptr ()
d1_ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
d2_ptr
instance ToRaw Device WGPUDevice where
raw :: Device -> ContT r IO WGPUDevice
raw = WGPUDevice -> ContT r IO WGPUDevice
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUDevice -> ContT r IO WGPUDevice)
-> (Device -> WGPUDevice) -> Device -> ContT r IO WGPUDevice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Device -> WGPUDevice
wgpuDevice
newtype Features = Features
{ Features -> Bool
textureAdapterSpecificFormatFeatures :: Bool
}
deriving (Features -> Features -> Bool
(Features -> Features -> Bool)
-> (Features -> Features -> Bool) -> Eq Features
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Features -> Features -> Bool
$c/= :: Features -> Features -> Bool
== :: Features -> Features -> Bool
$c== :: Features -> Features -> Bool
Eq, Int -> Features -> ShowS
[Features] -> ShowS
Features -> String
(Int -> Features -> ShowS)
-> (Features -> String) -> ([Features] -> ShowS) -> Show Features
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Features] -> ShowS
$cshowList :: [Features] -> ShowS
show :: Features -> String
$cshow :: Features -> String
showsPrec :: Int -> Features -> ShowS
$cshowsPrec :: Int -> Features -> ShowS
Show)
instance Default Features where
def :: Features
def =
Features :: Bool -> Features
Features
{ textureAdapterSpecificFormatFeatures :: Bool
textureAdapterSpecificFormatFeatures = Bool
False
}
instance ToRaw Features WGPUNativeFeature where
raw :: Features -> ContT r IO WGPUNativeFeature
raw Features {Bool
textureAdapterSpecificFormatFeatures :: Bool
textureAdapterSpecificFormatFeatures :: Features -> Bool
..} =
WGPUNativeFeature -> ContT r IO WGPUNativeFeature
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUNativeFeature -> ContT r IO WGPUNativeFeature)
-> WGPUNativeFeature -> ContT r IO WGPUNativeFeature
forall a b. (a -> b) -> a -> b
$
if Bool
textureAdapterSpecificFormatFeatures
then WGPUNativeFeature
forall a. (Eq a, Num a) => a
WGPUNativeFeature.TEXTURE_ADAPTER_SPECIFIC_FORMAT_FEATURES
else WGPUNativeFeature
0
data Limits = Limits
{
Limits -> Word32
maxTextureDimension1D :: !Word32,
Limits -> Word32
maxTextureDimension2D :: !Word32,
Limits -> Word32
maxTextureDimension3D :: !Word32,
Limits -> Word32
maxTextureArrayLayers :: !Word32,
Limits -> Word32
maxBindGroups :: !Word32,
Limits -> Word32
maxDynamicStorageBuffersPerPipelineLayout :: !Word32,
Limits -> Word32
maxStorageBuffersPerShaderStage :: !Word32,
Limits -> Word32
maxStorageBufferBindingSize :: !Word32
}
deriving (Limits -> Limits -> Bool
(Limits -> Limits -> Bool)
-> (Limits -> Limits -> Bool) -> Eq Limits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Limits -> Limits -> Bool
$c/= :: Limits -> Limits -> Bool
== :: Limits -> Limits -> Bool
$c== :: Limits -> Limits -> Bool
Eq, Int -> Limits -> ShowS
[Limits] -> ShowS
Limits -> String
(Int -> Limits -> ShowS)
-> (Limits -> String) -> ([Limits] -> ShowS) -> Show Limits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Limits] -> ShowS
$cshowList :: [Limits] -> ShowS
show :: Limits -> String
$cshow :: Limits -> String
showsPrec :: Int -> Limits -> ShowS
$cshowsPrec :: Int -> Limits -> ShowS
Show)
instance Default Limits where
def :: Limits
def =
Limits :: Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Limits
Limits
{ maxTextureDimension1D :: Word32
maxTextureDimension1D = Word32
0,
maxTextureDimension2D :: Word32
maxTextureDimension2D = Word32
0,
maxTextureDimension3D :: Word32
maxTextureDimension3D = Word32
0,
maxTextureArrayLayers :: Word32
maxTextureArrayLayers = Word32
0,
maxBindGroups :: Word32
maxBindGroups = Word32
0,
maxDynamicStorageBuffersPerPipelineLayout :: Word32
maxDynamicStorageBuffersPerPipelineLayout = Word32
0,
maxStorageBuffersPerShaderStage :: Word32
maxStorageBuffersPerShaderStage = Word32
0,
maxStorageBufferBindingSize :: Word32
maxStorageBufferBindingSize = Word32
0
}
data DeviceDescriptor = DeviceDescriptor
{
DeviceDescriptor -> Text
deviceLabel :: !Text,
DeviceDescriptor -> Features
features :: !Features,
DeviceDescriptor -> Limits
limits :: !Limits
}
deriving (DeviceDescriptor -> DeviceDescriptor -> Bool
(DeviceDescriptor -> DeviceDescriptor -> Bool)
-> (DeviceDescriptor -> DeviceDescriptor -> Bool)
-> Eq DeviceDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeviceDescriptor -> DeviceDescriptor -> Bool
$c/= :: DeviceDescriptor -> DeviceDescriptor -> Bool
== :: DeviceDescriptor -> DeviceDescriptor -> Bool
$c== :: DeviceDescriptor -> DeviceDescriptor -> Bool
Eq, Int -> DeviceDescriptor -> ShowS
[DeviceDescriptor] -> ShowS
DeviceDescriptor -> String
(Int -> DeviceDescriptor -> ShowS)
-> (DeviceDescriptor -> String)
-> ([DeviceDescriptor] -> ShowS)
-> Show DeviceDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeviceDescriptor] -> ShowS
$cshowList :: [DeviceDescriptor] -> ShowS
show :: DeviceDescriptor -> String
$cshow :: DeviceDescriptor -> String
showsPrec :: Int -> DeviceDescriptor -> ShowS
$cshowsPrec :: Int -> DeviceDescriptor -> ShowS
Show)
instance Default DeviceDescriptor where
def :: DeviceDescriptor
def =
DeviceDescriptor :: Text -> Features -> Limits -> DeviceDescriptor
DeviceDescriptor
{ deviceLabel :: Text
deviceLabel = Text
Text.empty,
features :: Features
features = Features
forall a. Default a => a
def,
limits :: Limits
limits = Limits
forall a. Default a => a
def
}
instance ToRaw DeviceDescriptor WGPUDeviceExtras where
raw :: DeviceDescriptor -> ContT r IO WGPUDeviceExtras
raw DeviceDescriptor {Text
Limits
Features
limits :: Limits
features :: Features
deviceLabel :: Text
limits :: DeviceDescriptor -> Limits
features :: DeviceDescriptor -> Features
deviceLabel :: DeviceDescriptor -> Text
..} = do
WGPUChainedStruct
chain_ptr <- ChainedStruct Any -> ContT r IO WGPUChainedStruct
forall a b r. ToRaw a b => a -> ContT r IO b
raw (WGPUSType -> ChainedStruct Any
forall a. WGPUSType -> ChainedStruct a
EmptyChain WGPUSType
forall a. (Eq a, Num a) => a
WGPUSType.DeviceExtras)
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
deviceLabel
WGPUNativeFeature
n_nativeFeatures <- Features -> ContT r IO WGPUNativeFeature
forall a b r. ToRaw a b => a -> ContT r IO b
raw Features
features
WGPUDeviceExtras -> ContT r IO WGPUDeviceExtras
forall (f :: * -> *) a. Applicative f => a -> f a
pure
WGPUDeviceExtras :: WGPUChainedStruct
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> WGPUNativeFeature
-> Ptr CChar
-> Ptr CChar
-> WGPUDeviceExtras
WGPUDeviceExtras.WGPUDeviceExtras
{ chain :: WGPUChainedStruct
chain = WGPUChainedStruct
chain_ptr,
maxTextureDimension1D :: Word32
maxTextureDimension1D = Limits -> Word32
maxTextureDimension1D Limits
limits,
maxTextureDimension2D :: Word32
maxTextureDimension2D = Limits -> Word32
maxTextureDimension2D Limits
limits,
maxTextureDimension3D :: Word32
maxTextureDimension3D = Limits -> Word32
maxTextureDimension3D Limits
limits,
maxTextureArrayLayers :: Word32
maxTextureArrayLayers = Limits -> Word32
maxTextureArrayLayers Limits
limits,
maxBindGroups :: Word32
maxBindGroups = Limits -> Word32
maxBindGroups Limits
limits,
maxDynamicStorageBuffersPerPipelineLayout :: Word32
maxDynamicStorageBuffersPerPipelineLayout =
Limits -> Word32
maxDynamicStorageBuffersPerPipelineLayout Limits
limits,
maxStorageBuffersPerShaderStage :: Word32
maxStorageBuffersPerShaderStage =
Limits -> Word32
maxStorageBuffersPerShaderStage Limits
limits,
maxStorageBufferBindingSize :: Word32
maxStorageBufferBindingSize =
Limits -> Word32
maxStorageBufferBindingSize Limits
limits,
nativeFeatures :: WGPUNativeFeature
nativeFeatures = WGPUNativeFeature
n_nativeFeatures,
label :: Ptr CChar
label = Ptr CChar
label_ptr,
tracePath :: Ptr CChar
tracePath = Ptr CChar
forall a. Ptr a
nullPtr
}
requestDevice ::
MonadIO m =>
Adapter ->
DeviceDescriptor ->
m (Maybe Device)
requestDevice :: Adapter -> DeviceDescriptor -> m (Maybe Device)
requestDevice Adapter
adapter DeviceDescriptor
deviceDescriptor = IO (Maybe Device) -> m (Maybe Device)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Device) -> m (Maybe Device))
-> (ContT (Maybe Device) IO (Maybe Device) -> IO (Maybe Device))
-> ContT (Maybe Device) IO (Maybe Device)
-> m (Maybe Device)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContT (Maybe Device) IO (Maybe Device) -> IO (Maybe Device)
forall (m :: * -> *) a. Monad m => ContT a m a -> m a
evalContT (ContT (Maybe Device) IO (Maybe Device) -> m (Maybe Device))
-> ContT (Maybe Device) IO (Maybe Device) -> m (Maybe Device)
forall a b. (a -> b) -> a -> b
$ do
let inst :: Instance
inst = Adapter -> Instance
adapterInst Adapter
adapter
MVar WGPUDevice
deviceMVar <- ContT (Maybe Device) IO (MVar WGPUDevice)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
WGPURequestDeviceCallback
callback <- (WGPUDevice -> Ptr () -> IO ())
-> ContT (Maybe Device) IO WGPURequestDeviceCallback
forall (m :: * -> *).
MonadIO m =>
(WGPUDevice -> Ptr () -> IO ()) -> m WGPURequestDeviceCallback
mkDeviceCallback (\WGPUDevice
d Ptr ()
_ -> MVar WGPUDevice -> WGPUDevice -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar WGPUDevice
deviceMVar WGPUDevice
d)
Ptr WGPUDeviceExtras
deviceExtras_ptr <- DeviceDescriptor -> ContT (Maybe Device) IO (Ptr WGPUDeviceExtras)
forall a b r. ToRawPtr a b => a -> ContT r IO (Ptr b)
rawPtr DeviceDescriptor
deviceDescriptor
Ptr WGPUChainedStruct
nextInChain_ptr <- ChainedStruct WGPUDeviceExtras
-> ContT (Maybe Device) IO (Ptr WGPUChainedStruct)
forall a b r. ToRawPtr a b => a -> ContT r IO (Ptr b)
rawPtr (WGPUSType -> Ptr WGPUDeviceExtras -> ChainedStruct WGPUDeviceExtras
forall a. WGPUSType -> Ptr a -> ChainedStruct a
PtrChain WGPUSType
forall a. (Eq a, Num a) => a
WGPUSType.DeviceExtras Ptr WGPUDeviceExtras
deviceExtras_ptr)
Ptr WGPUDeviceDescriptor
deviceDescriptor_ptr <-
WGPUDeviceDescriptor
-> ContT (Maybe Device) IO (Ptr WGPUDeviceDescriptor)
forall a r. Storable a => a -> ContT r IO (Ptr a)
withCZeroingAfter (WGPUDeviceDescriptor
-> ContT (Maybe Device) IO (Ptr WGPUDeviceDescriptor))
-> WGPUDeviceDescriptor
-> ContT (Maybe Device) IO (Ptr WGPUDeviceDescriptor)
forall a b. (a -> b) -> a -> b
$
WGPUDeviceDescriptor :: Ptr WGPUChainedStruct -> WGPUDeviceDescriptor
WGPUDeviceDescriptor.WGPUDeviceDescriptor
{ nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
nextInChain_ptr
}
WGPUHsInstance
-> WGPUAdapter
-> Ptr WGPUDeviceDescriptor
-> WGPURequestDeviceCallback
-> Ptr ()
-> ContT (Maybe Device) IO ()
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance
-> WGPUAdapter
-> Ptr WGPUDeviceDescriptor
-> WGPURequestDeviceCallback
-> Ptr ()
-> m ()
RawFun.wgpuAdapterRequestDevice
(Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
(Adapter -> WGPUAdapter
wgpuAdapter Adapter
adapter)
Ptr WGPUDeviceDescriptor
deviceDescriptor_ptr
WGPURequestDeviceCallback
callback
Ptr ()
forall a. Ptr a
nullPtr
WGPUDevice
device <- MVar WGPUDevice -> ContT (Maybe Device) IO WGPUDevice
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar WGPUDevice
deviceMVar
WGPURequestDeviceCallback -> ContT (Maybe Device) IO ()
forall (m :: * -> *) a. MonadIO m => FunPtr a -> m ()
freeHaskellFunPtr WGPURequestDeviceCallback
callback
Maybe Device -> ContT (Maybe Device) IO (Maybe Device)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Device -> ContT (Maybe Device) IO (Maybe Device))
-> Maybe Device -> ContT (Maybe Device) IO (Maybe Device)
forall a b. (a -> b) -> a -> b
$ case WGPUDevice
device of
WGPUDevice Ptr ()
ptr | Ptr ()
ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr -> Maybe Device
forall a. Maybe a
Nothing
WGPUDevice Ptr ()
_ -> Device -> Maybe Device
forall a. a -> Maybe a
Just (Instance -> WGPUDevice -> Device
Device Instance
inst WGPUDevice
device)
mkDeviceCallback ::
(MonadIO m) =>
(WGPUDevice -> Ptr () -> IO ()) ->
m WGPURequestDeviceCallback
mkDeviceCallback :: (WGPUDevice -> Ptr () -> IO ()) -> m WGPURequestDeviceCallback
mkDeviceCallback = IO WGPURequestDeviceCallback -> m WGPURequestDeviceCallback
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WGPURequestDeviceCallback -> m WGPURequestDeviceCallback)
-> ((WGPUDevice -> Ptr () -> IO ())
-> IO WGPURequestDeviceCallback)
-> (WGPUDevice -> Ptr () -> IO ())
-> m WGPURequestDeviceCallback
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WGPUDevice -> Ptr () -> IO ()) -> IO WGPURequestDeviceCallback
mkDeviceCallbackIO
foreign import ccall "wrapper"
mkDeviceCallbackIO ::
(WGPUDevice -> Ptr () -> IO ()) -> IO WGPURequestDeviceCallback