{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module WGPU.Internal.Buffer
(
Buffer (..),
BufferUsage (..),
BufferDescriptor (..),
createBuffer,
createBufferInit,
)
where
import Control.Monad.Cont (ContT (ContT))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits ((.|.))
import Data.Default (Default, def)
import Data.Text (Text)
import Data.Word (Word32, Word64)
import Foreign
( Ptr,
castPtr,
copyBytes,
nullPtr,
)
import WGPU.Internal.Device (Device, deviceInst, wgpuDevice)
import WGPU.Internal.Instance (Instance, wgpuHsInstance)
import WGPU.Internal.Memory
( ByteSize,
ReadableMemoryBuffer,
ToRaw,
evalContT,
raw,
rawPtr,
readableMemoryBufferSize,
showWithPtr,
toCSize,
unByteSize,
withReadablePtr,
)
import qualified WGPU.Raw.Generated.Enum.WGPUBufferUsage as WGPUBufferUsage
import qualified WGPU.Raw.Generated.Fun as RawFun
import qualified WGPU.Raw.Generated.Fun as WGPU
import WGPU.Raw.Generated.Struct.WGPUBufferDescriptor (WGPUBufferDescriptor)
import qualified WGPU.Raw.Generated.Struct.WGPUBufferDescriptor as WGPUBufferDescriptor
import WGPU.Raw.Types (WGPUBuffer (WGPUBuffer))
data Buffer = Buffer
{ Buffer -> Instance
bufferInst :: !Instance,
Buffer -> Device
bufferDevice :: !Device,
Buffer -> WGPUBuffer
wgpuBuffer :: !WGPUBuffer
}
instance Show Buffer where
show :: Buffer -> String
show Buffer
b =
let Buffer Instance
_ Device
_ (WGPUBuffer Ptr ()
ptr) = Buffer
b
in String -> Ptr () -> String
forall a. String -> Ptr a -> String
showWithPtr String
"Buffer" Ptr ()
ptr
instance Eq Buffer where
== :: Buffer -> Buffer -> Bool
(==) Buffer
b1 Buffer
b2 =
let Buffer Instance
_ Device
_ (WGPUBuffer Ptr ()
b1_ptr) = Buffer
b1
Buffer Instance
_ Device
_ (WGPUBuffer Ptr ()
b2_ptr) = Buffer
b2
in Ptr ()
b1_ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
b2_ptr
instance ToRaw Buffer WGPUBuffer where
raw :: Buffer -> ContT r IO WGPUBuffer
raw = WGPUBuffer -> ContT r IO WGPUBuffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WGPUBuffer -> ContT r IO WGPUBuffer)
-> (Buffer -> WGPUBuffer) -> Buffer -> ContT r IO WGPUBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffer -> WGPUBuffer
wgpuBuffer
data BufferUsage = BufferUsage
{
BufferUsage -> Bool
bufMapRead :: !Bool,
BufferUsage -> Bool
bufMapWrite :: !Bool,
BufferUsage -> Bool
bufCopySrc :: !Bool,
BufferUsage -> Bool
bufCopyDst :: !Bool,
BufferUsage -> Bool
bufIndex :: !Bool,
BufferUsage -> Bool
bufVertex :: !Bool,
BufferUsage -> Bool
bufUniform :: !Bool,
BufferUsage -> Bool
bufStorage :: !Bool,
BufferUsage -> Bool
bufIndirect :: !Bool
}
deriving (BufferUsage -> BufferUsage -> Bool
(BufferUsage -> BufferUsage -> Bool)
-> (BufferUsage -> BufferUsage -> Bool) -> Eq BufferUsage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BufferUsage -> BufferUsage -> Bool
$c/= :: BufferUsage -> BufferUsage -> Bool
== :: BufferUsage -> BufferUsage -> Bool
$c== :: BufferUsage -> BufferUsage -> Bool
Eq, Int -> BufferUsage -> ShowS
[BufferUsage] -> ShowS
BufferUsage -> String
(Int -> BufferUsage -> ShowS)
-> (BufferUsage -> String)
-> ([BufferUsage] -> ShowS)
-> Show BufferUsage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BufferUsage] -> ShowS
$cshowList :: [BufferUsage] -> ShowS
show :: BufferUsage -> String
$cshow :: BufferUsage -> String
showsPrec :: Int -> BufferUsage -> ShowS
$cshowsPrec :: Int -> BufferUsage -> ShowS
Show)
instance ToRaw BufferUsage Word32 where
raw :: BufferUsage -> ContT r IO Word32
raw BufferUsage {Bool
bufIndirect :: Bool
bufStorage :: Bool
bufUniform :: Bool
bufVertex :: Bool
bufIndex :: Bool
bufCopyDst :: Bool
bufCopySrc :: Bool
bufMapWrite :: Bool
bufMapRead :: Bool
bufIndirect :: BufferUsage -> Bool
bufStorage :: BufferUsage -> Bool
bufUniform :: BufferUsage -> Bool
bufVertex :: BufferUsage -> Bool
bufIndex :: BufferUsage -> Bool
bufCopyDst :: BufferUsage -> Bool
bufCopySrc :: BufferUsage -> Bool
bufMapWrite :: BufferUsage -> Bool
bufMapRead :: BufferUsage -> Bool
..} =
Word32 -> ContT r IO Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> ContT r IO Word32) -> Word32 -> ContT r IO Word32
forall a b. (a -> b) -> a -> b
$
(if Bool
bufMapRead then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.MapRead else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufMapWrite then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.MapWrite else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufCopySrc then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.CopySrc else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufCopyDst then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.CopyDst else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufIndex then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.Index else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufVertex then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.Vertex else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufUniform then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.Uniform else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufStorage then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.Storage else Word32
0)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (if Bool
bufIndirect then Word32
forall a. (Eq a, Num a) => a
WGPUBufferUsage.Indirect else Word32
0)
instance Default BufferUsage where
def :: BufferUsage
def =
BufferUsage :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> BufferUsage
BufferUsage
{ bufMapRead :: Bool
bufMapRead = Bool
False,
bufMapWrite :: Bool
bufMapWrite = Bool
False,
bufCopySrc :: Bool
bufCopySrc = Bool
False,
bufCopyDst :: Bool
bufCopyDst = Bool
False,
bufIndex :: Bool
bufIndex = Bool
False,
bufVertex :: Bool
bufVertex = Bool
False,
bufUniform :: Bool
bufUniform = Bool
False,
bufStorage :: Bool
bufStorage = Bool
False,
bufIndirect :: Bool
bufIndirect = Bool
False
}
data BufferDescriptor = BufferDescriptor
{
BufferDescriptor -> Text
bufferLabel :: !Text,
BufferDescriptor -> ByteSize
bufferSize :: !ByteSize,
BufferDescriptor -> BufferUsage
bufferUsage :: !BufferUsage,
BufferDescriptor -> Bool
mappedAtCreation :: Bool
}
deriving (BufferDescriptor -> BufferDescriptor -> Bool
(BufferDescriptor -> BufferDescriptor -> Bool)
-> (BufferDescriptor -> BufferDescriptor -> Bool)
-> Eq BufferDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BufferDescriptor -> BufferDescriptor -> Bool
$c/= :: BufferDescriptor -> BufferDescriptor -> Bool
== :: BufferDescriptor -> BufferDescriptor -> Bool
$c== :: BufferDescriptor -> BufferDescriptor -> Bool
Eq, Int -> BufferDescriptor -> ShowS
[BufferDescriptor] -> ShowS
BufferDescriptor -> String
(Int -> BufferDescriptor -> ShowS)
-> (BufferDescriptor -> String)
-> ([BufferDescriptor] -> ShowS)
-> Show BufferDescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BufferDescriptor] -> ShowS
$cshowList :: [BufferDescriptor] -> ShowS
show :: BufferDescriptor -> String
$cshow :: BufferDescriptor -> String
showsPrec :: Int -> BufferDescriptor -> ShowS
$cshowsPrec :: Int -> BufferDescriptor -> ShowS
Show)
instance ToRaw BufferDescriptor WGPUBufferDescriptor where
raw :: BufferDescriptor -> ContT r IO WGPUBufferDescriptor
raw BufferDescriptor {Bool
Text
ByteSize
BufferUsage
mappedAtCreation :: Bool
bufferUsage :: BufferUsage
bufferSize :: ByteSize
bufferLabel :: Text
mappedAtCreation :: BufferDescriptor -> Bool
bufferUsage :: BufferDescriptor -> BufferUsage
bufferSize :: BufferDescriptor -> ByteSize
bufferLabel :: BufferDescriptor -> 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
bufferLabel
Word32
n_usage <- BufferUsage -> ContT r IO Word32
forall a b r. ToRaw a b => a -> ContT r IO b
raw BufferUsage
bufferUsage
CBool
n_mappedAtCreation <- Bool -> ContT r IO CBool
forall a b r. ToRaw a b => a -> ContT r IO b
raw Bool
mappedAtCreation
WGPUBufferDescriptor -> ContT r IO WGPUBufferDescriptor
forall (f :: * -> *) a. Applicative f => a -> f a
pure
WGPUBufferDescriptor :: Ptr WGPUChainedStruct
-> Ptr CChar -> Word32 -> Word64 -> CBool -> WGPUBufferDescriptor
WGPUBufferDescriptor.WGPUBufferDescriptor
{ 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,
size :: Word64
size = ByteSize -> Word64
unByteSize ByteSize
bufferSize,
mappedAtCreation :: CBool
mappedAtCreation = CBool
n_mappedAtCreation
}
createBuffer :: MonadIO m => Device -> BufferDescriptor -> m Buffer
createBuffer :: Device -> BufferDescriptor -> m Buffer
createBuffer Device
device BufferDescriptor
bufferDescriptor = IO Buffer -> m Buffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Buffer -> m Buffer)
-> (ContT Buffer IO Buffer -> IO Buffer)
-> ContT Buffer IO Buffer
-> m Buffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContT Buffer IO Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => ContT a m a -> m a
evalContT (ContT Buffer IO Buffer -> m Buffer)
-> ContT Buffer IO Buffer -> m Buffer
forall a b. (a -> b) -> a -> b
$ do
let inst :: Instance
inst = Device -> Instance
deviceInst Device
device
Ptr WGPUBufferDescriptor
bufferDescriptor_ptr <- BufferDescriptor -> ContT Buffer IO (Ptr WGPUBufferDescriptor)
forall a b r. ToRawPtr a b => a -> ContT r IO (Ptr b)
rawPtr BufferDescriptor
bufferDescriptor
Instance -> Device -> WGPUBuffer -> Buffer
Buffer Instance
inst Device
device
(WGPUBuffer -> Buffer)
-> ContT Buffer IO WGPUBuffer -> ContT Buffer IO Buffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WGPUHsInstance
-> WGPUDevice
-> Ptr WGPUBufferDescriptor
-> ContT Buffer IO WGPUBuffer
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance
-> WGPUDevice -> Ptr WGPUBufferDescriptor -> m WGPUBuffer
RawFun.wgpuDeviceCreateBuffer
(Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
(Device -> WGPUDevice
wgpuDevice Device
device)
Ptr WGPUBufferDescriptor
bufferDescriptor_ptr
createBufferInit ::
forall a m.
(MonadIO m, ReadableMemoryBuffer a) =>
Device ->
Text ->
BufferUsage ->
a ->
m Buffer
createBufferInit :: Device -> Text -> BufferUsage -> a -> m Buffer
createBufferInit Device
device Text
label BufferUsage
bufferUsage a
content = IO Buffer -> m Buffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Buffer -> m Buffer)
-> (ContT Buffer IO Buffer -> IO Buffer)
-> ContT Buffer IO Buffer
-> m Buffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContT Buffer IO Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => ContT a m a -> m a
evalContT (ContT Buffer IO Buffer -> m Buffer)
-> ContT Buffer IO Buffer -> m Buffer
forall a b. (a -> b) -> a -> b
$ do
Ptr ()
contentPtr <- ((Ptr () -> IO Buffer) -> IO Buffer) -> ContT Buffer IO (Ptr ())
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr () -> IO Buffer) -> IO Buffer) -> ContT Buffer IO (Ptr ()))
-> ((Ptr () -> IO Buffer) -> IO Buffer) -> ContT Buffer IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ a -> (Ptr () -> IO Buffer) -> IO Buffer
forall a b. ReadableMemoryBuffer a => a -> (Ptr () -> IO b) -> IO b
withReadablePtr a
content
let contentSz :: ByteSize
contentSz :: ByteSize
contentSz = a -> ByteSize
forall a. ReadableMemoryBuffer a => a -> ByteSize
readableMemoryBufferSize a
content
let bufferDescriptor :: BufferDescriptor
bufferDescriptor :: BufferDescriptor
bufferDescriptor =
BufferDescriptor :: Text -> ByteSize -> BufferUsage -> Bool -> BufferDescriptor
BufferDescriptor
{ bufferLabel :: Text
bufferLabel = Text
label,
bufferSize :: ByteSize
bufferSize = ByteSize
contentSz,
bufferUsage :: BufferUsage
bufferUsage = BufferUsage
bufferUsage,
mappedAtCreation :: Bool
mappedAtCreation = Bool
True
}
Buffer
buffer <- Device -> BufferDescriptor -> ContT Buffer IO Buffer
forall (m :: * -> *).
MonadIO m =>
Device -> BufferDescriptor -> m Buffer
createBuffer Device
device BufferDescriptor
bufferDescriptor
Ptr ()
bufferPtr <- Buffer -> Word64 -> ByteSize -> ContT Buffer IO (Ptr ())
forall (m :: * -> *).
MonadIO m =>
Buffer -> Word64 -> ByteSize -> m (Ptr ())
bufferGetMappedRange Buffer
buffer Word64
0 ByteSize
contentSz
IO () -> ContT Buffer IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT Buffer IO ()) -> IO () -> ContT Buffer IO ()
forall a b. (a -> b) -> a -> b
$ Ptr () -> Ptr () -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr ()
bufferPtr (Ptr () -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
contentPtr) (ByteSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteSize
contentSz)
Buffer -> ContT Buffer IO ()
forall (m :: * -> *). MonadIO m => Buffer -> m ()
bufferUnmap Buffer
buffer
Buffer -> ContT Buffer IO Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
buffer
bufferGetMappedRange :: MonadIO m => Buffer -> Word64 -> ByteSize -> m (Ptr ())
bufferGetMappedRange :: Buffer -> Word64 -> ByteSize -> m (Ptr ())
bufferGetMappedRange Buffer
buffer Word64
byteOffset ByteSize
byteLength = do
let inst :: Instance
inst = Buffer -> Instance
bufferInst Buffer
buffer
WGPUHsInstance -> WGPUBuffer -> CSize -> CSize -> m (Ptr ())
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance -> WGPUBuffer -> CSize -> CSize -> m (Ptr ())
WGPU.wgpuBufferGetMappedRange
(Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
(Buffer -> WGPUBuffer
wgpuBuffer Buffer
buffer)
(Word64 -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteOffset)
(ByteSize -> CSize
toCSize ByteSize
byteLength)
{-# INLINEABLE bufferGetMappedRange #-}
bufferUnmap :: MonadIO m => Buffer -> m ()
bufferUnmap :: Buffer -> m ()
bufferUnmap Buffer
buffer = do
let inst :: Instance
inst = Buffer -> Instance
bufferInst Buffer
buffer
WGPUHsInstance -> WGPUBuffer -> m ()
forall (m :: * -> *).
MonadIO m =>
WGPUHsInstance -> WGPUBuffer -> m ()
WGPU.wgpuBufferUnmap
(Instance -> WGPUHsInstance
wgpuHsInstance Instance
inst)
(Buffer -> WGPUBuffer
wgpuBuffer Buffer
buffer)
{-# INLINEABLE bufferUnmap #-}