{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module WGPU.Internal.Buffer
  ( -- * Types
    Buffer (..),
    BufferUsage (..),
    BufferDescriptor (..),

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

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

-- | Handle to a buffer.
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

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

-- | Different ways you can use a buffer.
data BufferUsage = BufferUsage
  { -- | Allow a buffer to be mapped for reading.
    BufferUsage -> Bool
bufMapRead :: !Bool,
    -- | Allow a buffer to be mapped for writing.
    BufferUsage -> Bool
bufMapWrite :: !Bool,
    -- | Allow a buffer to be a source buffer for a copy operation.
    BufferUsage -> Bool
bufCopySrc :: !Bool,
    -- | Allow a buffer to be a destination buffer for a copy operation.
    BufferUsage -> Bool
bufCopyDst :: !Bool,
    -- | Allow a buffer to be the index buffer in a draw operation.
    BufferUsage -> Bool
bufIndex :: !Bool,
    -- | Allow a buffer to be the vertex buffer in a draw operation.
    BufferUsage -> Bool
bufVertex :: !Bool,
    -- | Allow a buffer to be a uniform binding in a bind group.
    BufferUsage -> Bool
bufUniform :: !Bool,
    -- | Allow a buffer to be a storage binding in a bind group.
    BufferUsage -> Bool
bufStorage :: !Bool,
    -- | Allow a buffer to be the indirect buffer in an indirect draw call.
    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
      }

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

-- | Describes a 'Buffer'.
data BufferDescriptor = BufferDescriptor
  { -- | Debugging label for the buffer.
    BufferDescriptor -> Text
bufferLabel :: !Text,
    -- | Size of the buffer, in bytes.
    BufferDescriptor -> ByteSize
bufferSize :: !ByteSize,
    -- | Usage(s) of the buffer.
    BufferDescriptor -> BufferUsage
bufferUsage :: !BufferUsage,
    -- | Is the buffer mapped to host memory at creation? If this is set to
    -- 'True', then the buffer may be more easily populated with data
    -- initially. See 'createBufferInit' for a way to create a buffer and
    -- initialize it with data in one step.
    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
        }

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

-- | Create a 'Buffer'.
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

-- | Create a 'Buffer' with data to initialize it.
createBufferInit ::
  forall a m.
  (MonadIO m, ReadableMemoryBuffer a) =>
  -- | Device for which to create the buffer.
  Device ->
  -- | Debugging label for the buffer.
  Text ->
  -- | Usage for the buffer.
  BufferUsage ->
  -- | Data to initialize the buffer with.
  a ->
  -- | Buffer created with the specified data.
  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
  -- Convert the foreign pointer to a raw pointer.
  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

  -- Create the buffer, marking it as "mappedAtCreation", so that its memory
  -- is mapped to host memory.
  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

  -- Find the pointer to the mapped region of the buffer.
  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

  -- Copy the supplied content to the buffer
  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)

  -- Un-map the buffer and return it
  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

-- | Return a pointer to a region of host memory that has been mapped to a
-- 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 #-}

-- | Unmap a buffer that was previously mapped into host memory.
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 #-}