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

-- |
-- Module      : WGPU.Internal.Device.
-- Description : Device (open connection to a device).
module WGPU.Internal.Device
  ( -- * Types
    Device (..),
    DeviceDescriptor (..),
    Features (..),
    Limits (..),

    -- * Functions
    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)

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

-- | An open connection to a graphics and/or compute device.
--
-- A 'Device' may be created using the 'requestDevice' function.
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

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

-- | Device features that are not guaranteed to be supported.
--
--   * NOTE: The Rust API currently has far more extensive @Features@. Perhaps
--     they have not yet been ported to the C API?
--     <https://docs.rs/wgpu-types/0.9.0/wgpu_types/struct.Features.html>
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

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

-- | Device limits.
--
-- Represents the set of limits an adapter/device supports.
data Limits = Limits
  { -- | Maximum allowed value for the width of a 1D texture.
    Limits -> Word32
maxTextureDimension1D :: !Word32,
    -- | Maximum allowed value for the width and height of a 2D texture.
    Limits -> Word32
maxTextureDimension2D :: !Word32,
    -- | Maximum allowed value for the width, height or depth of a 3D texture.
    Limits -> Word32
maxTextureDimension3D :: !Word32,
    -- | Maximum allowed value for the array layers of a texture.
    Limits -> Word32
maxTextureArrayLayers :: !Word32,
    -- | Amount of bind groups that can be attached to a pipeline at the same
    --   time.
    Limits -> Word32
maxBindGroups :: !Word32,
    -- | Amount of storage buffer bindings that can be dynamic in a single
    --   pipeline.
    Limits -> Word32
maxDynamicStorageBuffersPerPipelineLayout :: !Word32,
    -- | Amount of sampled textures visible in a single shader stage.
    Limits -> Word32
maxStorageBuffersPerShaderStage :: !Word32,
    -- | Maximum size in bytes of a binding to a uniform buffer.
    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
      }

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

-- | Describes a 'Device'.
data DeviceDescriptor = DeviceDescriptor
  { -- | Debug label for the device.
    DeviceDescriptor -> Text
deviceLabel :: !Text,
    -- | Features that the device should support.
    DeviceDescriptor -> Features
features :: !Features,
    -- | Limits that the device should support (minimum values).
    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
        }

-- | Requests a connection to a physical device, creating a logical device.
--
-- This action blocks until an available device is returned.
requestDevice ::
  MonadIO m =>
  -- | @Adapter@ for which the device will be returned.
  Adapter ->
  -- | The features and limits requested for the device.
  DeviceDescriptor ->
  -- | The returned @Device@, if it could be retrieved.
  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