Pipeline.hs

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

-- |
-- Module      : WGPU.Internal.Pipeline
-- Description : Pipelines.
module WGPU.Internal.Pipeline
  ( -- * Types
    PipelineLayout (..),
    PipelineLayoutDescriptor (..),
    VertexFormat (..),
    VertexAttribute (..),
    InputStepMode (..),
    VertexBufferLayout (..),
    VertexState (..),
    PrimitiveTopology (..),
    IndexFormat (..),
    FrontFace (..),
    CullMode (..),
    PrimitiveState (..),
    StencilOperation (..),
    StencilFaceState (..),
    StencilState (..),
    DepthBiasState (..),
    DepthStencilState (..),
    MultisampleState (..),
    BlendFactor (..),
    BlendOperation (..),
    BlendComponent (..),
    BlendState (..),
    ColorWriteMask (..),
    ColorTargetState (..),
    FragmentState (..),
    RenderPipelineDescriptor (..),

    -- * Functions
    createPipelineLayout,
    createRenderPipeline,
    colorWriteMaskAll,
  )
where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Cont (evalContT)
import Data.Bits ((.|.))
import Data.Default (Default, def)
import Data.Int (Int32)
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Word (Word32, Word64, Word8)
import Foreign (nullPtr)
import Foreign.C (CFloat (CFloat))
import WGPU.Internal.Binding (BindGroupLayout)
import WGPU.Internal.Device (Device, deviceInst, wgpuDevice)
import WGPU.Internal.Instance (Instance, wgpuHsInstance)
import WGPU.Internal.Memory (ToRaw, raw, rawArrayPtr, rawPtr, showWithPtr)
import WGPU.Internal.Multipurpose (CompareFunction)
import WGPU.Internal.RenderPass (RenderPipeline (RenderPipeline))
import WGPU.Internal.SMaybe (SMaybe (SJust, SNothing))
import WGPU.Internal.Shader (ShaderEntryPoint, ShaderModule)
import WGPU.Internal.Texture (TextureFormat)
import WGPU.Raw.Generated.Enum.WGPUBlendFactor (WGPUBlendFactor)
import qualified WGPU.Raw.Generated.Enum.WGPUBlendFactor as WGPUBlendFactor
import WGPU.Raw.Generated.Enum.WGPUBlendOperation (WGPUBlendOperation)
import qualified WGPU.Raw.Generated.Enum.WGPUBlendOperation as WGPUBlendOperation
import WGPU.Raw.Generated.Enum.WGPUColorWriteMask (WGPUColorWriteMask (WGPUColorWriteMask))
import qualified WGPU.Raw.Generated.Enum.WGPUColorWriteMask as WGPUColorWriteMask
import WGPU.Raw.Generated.Enum.WGPUCullMode (WGPUCullMode)
import qualified WGPU.Raw.Generated.Enum.WGPUCullMode as WGPUCullMode
import WGPU.Raw.Generated.Enum.WGPUFrontFace (WGPUFrontFace)
import qualified WGPU.Raw.Generated.Enum.WGPUFrontFace as WGPUFrontFace
import WGPU.Raw.Generated.Enum.WGPUIndexFormat (WGPUIndexFormat)
import qualified WGPU.Raw.Generated.Enum.WGPUIndexFormat as WGPUIndexFormat
import WGPU.Raw.Generated.Enum.WGPUInputStepMode (WGPUInputStepMode)
import qualified WGPU.Raw.Generated.Enum.WGPUInputStepMode as WGPUInputStepMode
import WGPU.Raw.Generated.Enum.WGPUPrimitiveTopology (WGPUPrimitiveTopology)
import qualified WGPU.Raw.Generated.Enum.WGPUPrimitiveTopology as WGPUPrimitiveTopology
import WGPU.Raw.Generated.Enum.WGPUStencilOperation (WGPUStencilOperation)
import qualified WGPU.Raw.Generated.Enum.WGPUStencilOperation as WGPUStencilOperation
import WGPU.Raw.Generated.Enum.WGPUVertexFormat (WGPUVertexFormat)
import qualified WGPU.Raw.Generated.Enum.WGPUVertexFormat as WGPUVertexFormat
import qualified WGPU.Raw.Generated.Fun as RawFun
import WGPU.Raw.Generated.Struct.WGPUBlendComponent (WGPUBlendComponent)
import qualified WGPU.Raw.Generated.Struct.WGPUBlendComponent as WGPUBlendComponent
import WGPU.Raw.Generated.Struct.WGPUBlendState (WGPUBlendState)
import qualified WGPU.Raw.Generated.Struct.WGPUBlendState as WGPUBlendState
import WGPU.Raw.Generated.Struct.WGPUColorTargetState (WGPUColorTargetState)
import qualified WGPU.Raw.Generated.Struct.WGPUColorTargetState as WGPUColorTargetState
import WGPU.Raw.Generated.Struct.WGPUDepthStencilState (WGPUDepthStencilState)
import qualified WGPU.Raw.Generated.Struct.WGPUDepthStencilState as WGPUDepthStencilState
import WGPU.Raw.Generated.Struct.WGPUFragmentState (WGPUFragmentState)
import qualified WGPU.Raw.Generated.Struct.WGPUFragmentState as WGPUFragmentState
import WGPU.Raw.Generated.Struct.WGPUMultisampleState (WGPUMultisampleState)
import qualified WGPU.Raw.Generated.Struct.WGPUMultisampleState as WGPUMultisampleState
import WGPU.Raw.Generated.Struct.WGPUPipelineLayoutDescriptor (WGPUPipelineLayoutDescriptor)
import qualified WGPU.Raw.Generated.Struct.WGPUPipelineLayoutDescriptor as WGPUPipelineLayoutDescriptor
import WGPU.Raw.Generated.Struct.WGPUPrimitiveState (WGPUPrimitiveState)
import qualified WGPU.Raw.Generated.Struct.WGPUPrimitiveState as WGPUPrimitiveState
import WGPU.Raw.Generated.Struct.WGPURenderPipelineDescriptor (WGPURenderPipelineDescriptor)
import qualified WGPU.Raw.Generated.Struct.WGPURenderPipelineDescriptor as WGPURenderPipelineDescriptor
import WGPU.Raw.Generated.Struct.WGPUStencilFaceState (WGPUStencilFaceState)
import qualified WGPU.Raw.Generated.Struct.WGPUStencilFaceState as WGPUStencilFaceState
import WGPU.Raw.Generated.Struct.WGPUVertexAttribute (WGPUVertexAttribute)
import qualified WGPU.Raw.Generated.Struct.WGPUVertexAttribute as WGPUVertexAttribute
import WGPU.Raw.Generated.Struct.WGPUVertexBufferLayout (WGPUVertexBufferLayout)
import qualified WGPU.Raw.Generated.Struct.WGPUVertexBufferLayout as WGPUVertexBufferLayout
import WGPU.Raw.Generated.Struct.WGPUVertexState (WGPUVertexState)
import qualified WGPU.Raw.Generated.Struct.WGPUVertexState as WGPUVertexState
import WGPU.Raw.Types (WGPUPipelineLayout (WGPUPipelineLayout))
import Prelude hiding (compare)

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

newtype PipelineLayout = PipelineLayout {wgpuPipelineLayout :: WGPUPipelineLayout}

instance Show PipelineLayout where
  show p =
    let PipelineLayout (WGPUPipelineLayout ptr) = p
     in showWithPtr "PipelineLayout" ptr

instance Eq PipelineLayout where
  (==) p1 p2 =
    let PipelineLayout (WGPUPipelineLayout p1_ptr) = p1
        PipelineLayout (WGPUPipelineLayout p2_ptr) = p2
     in p1_ptr == p2_ptr

instance ToRaw PipelineLayout WGPUPipelineLayout where
  raw = pure . wgpuPipelineLayout

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

-- | Describes a pipeline layout.
data PipelineLayoutDescriptor = PipelineLayoutDescriptor
  { -- | Debug label of the pipeline layout.
    pipelineLabel :: !Text,
    -- | Bind groups that this pipeline uses.
    bindGroupLayouts :: !(Vector BindGroupLayout)
  }
  deriving (Eq, Show)

instance ToRaw PipelineLayoutDescriptor WGPUPipelineLayoutDescriptor where
  raw PipelineLayoutDescriptor {..} = do
    label_ptr <- rawPtr pipelineLabel
    bindGroupLayouts_ptr <- rawArrayPtr bindGroupLayouts
    pure
      WGPUPipelineLayoutDescriptor.WGPUPipelineLayoutDescriptor
        { nextInChain = nullPtr,
          label = label_ptr,
          bindGroupLayoutCount = fromIntegral . Vector.length $ bindGroupLayouts,
          bindGroupLayouts = bindGroupLayouts_ptr
        }

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

-- | Create a pipeline layout.
createPipelineLayout ::
  -- | The device for which the pipeline layout will be created.
  Device ->
  -- | Descriptor of the pipeline.
  PipelineLayoutDescriptor ->
  IO PipelineLayout
createPipelineLayout device pdl = evalContT $ do
  let inst = deviceInst device
  pipelineLayoutDescriptor_ptr <- rawPtr pdl
  rawPipelineLayout <-
    liftIO $
      RawFun.wgpuDeviceCreatePipelineLayout
        (wgpuHsInstance inst)
        (wgpuDevice device)
        pipelineLayoutDescriptor_ptr
  pure (PipelineLayout rawPipelineLayout)

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

-- | Vertex format for a vertex attribute.
data VertexFormat
  = VertexFormatUint8x2
  | VertexFormatUint8x4
  | VertexFormatSint8x2
  | VertexFormatSint8x4
  | VertexFormatUnorm8x2
  | VertexFormatUnorm8x4
  | VertexFormatSnorm8x2
  | VertexFormatSnorm8x4
  | VertexFormatUint16x2
  | VertexFormatUint16x4
  | VertexFormatSint16x2
  | VertexFormatSint16x4
  | VertexFormatUnorm16x2
  | VertexFormatUnorm16x4
  | VertexFormatSnorm16x2
  | VertexFormatSnorm16x4
  | VertexFormatFloat16x2
  | VertexFormatFloat16x4
  | VertexFormatFloat32
  | VertexFormatFloat32x2
  | VertexFormatFloat32x3
  | VertexFormatFloat32x4
  | VertexFormatUint32
  | VertexFormatUint32x2
  | VertexFormatUint32x3
  | VertexFormatUint32x4
  | VertexFormatSint32
  | VertexFormatSint32x2
  | VertexFormatSint32x3
  | VertexFormatSint32x4
  deriving (Eq, Show)

-- | Convert a 'VertexFormat' to its raw representation.
instance ToRaw VertexFormat WGPUVertexFormat where
  raw vf =
    pure $
      case vf of
        VertexFormatUint8x2 -> WGPUVertexFormat.Uint8x2
        VertexFormatUint8x4 -> WGPUVertexFormat.Uint8x4
        VertexFormatSint8x2 -> WGPUVertexFormat.Sint8x2
        VertexFormatSint8x4 -> WGPUVertexFormat.Sint8x4
        VertexFormatUnorm8x2 -> WGPUVertexFormat.Unorm8x2
        VertexFormatUnorm8x4 -> WGPUVertexFormat.Unorm8x4
        VertexFormatSnorm8x2 -> WGPUVertexFormat.Snorm8x2
        VertexFormatSnorm8x4 -> WGPUVertexFormat.Snorm8x4
        VertexFormatUint16x2 -> WGPUVertexFormat.Uint16x2
        VertexFormatUint16x4 -> WGPUVertexFormat.Uint16x4
        VertexFormatSint16x2 -> WGPUVertexFormat.Sint16x2
        VertexFormatSint16x4 -> WGPUVertexFormat.Sint16x4
        VertexFormatUnorm16x2 -> WGPUVertexFormat.Unorm16x2
        VertexFormatUnorm16x4 -> WGPUVertexFormat.Unorm16x4
        VertexFormatSnorm16x2 -> WGPUVertexFormat.Snorm16x2
        VertexFormatSnorm16x4 -> WGPUVertexFormat.Snorm16x4
        VertexFormatFloat16x2 -> WGPUVertexFormat.Float16x2
        VertexFormatFloat16x4 -> WGPUVertexFormat.Float16x4
        VertexFormatFloat32 -> WGPUVertexFormat.Float32
        VertexFormatFloat32x2 -> WGPUVertexFormat.Float32x2
        VertexFormatFloat32x3 -> WGPUVertexFormat.Float32x3
        VertexFormatFloat32x4 -> WGPUVertexFormat.Float32x4
        VertexFormatUint32 -> WGPUVertexFormat.Uint32
        VertexFormatUint32x2 -> WGPUVertexFormat.Uint32x2
        VertexFormatUint32x3 -> WGPUVertexFormat.Uint32x3
        VertexFormatUint32x4 -> WGPUVertexFormat.Uint32x4
        VertexFormatSint32 -> WGPUVertexFormat.Sint32
        VertexFormatSint32x2 -> WGPUVertexFormat.Sint32x2
        VertexFormatSint32x3 -> WGPUVertexFormat.Sint32x3
        VertexFormatSint32x4 -> WGPUVertexFormat.Sint32x4

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

-- | Vertex inputs (attributes) to shaders.
data VertexAttribute = VertexAttribute
  { -- | Format of the input.
    vertexFormat :: VertexFormat,
    -- | Byte offset of the start of the input.
    offset :: Word64,
    -- | Location for this input. Must match the location in the shader.
    shaderLocation :: Word32
  }
  deriving (Eq, Show)

instance ToRaw VertexAttribute WGPUVertexAttribute where
  raw VertexAttribute {..} = do
    n_format <- raw vertexFormat
    pure
      WGPUVertexAttribute.WGPUVertexAttribute
        { format = n_format,
          offset = offset,
          shaderLocation = shaderLocation
        }

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

-- | Determines when vertex data is advanced.
data InputStepMode
  = -- | Input data is advanced every vertex.
    InputStepModeVertex
  | -- | Input data is advanced every instance.
    InputStepModeInstance
  deriving (Eq, Show)

-- | Convert an 'InputStepMode' to its raw value.
instance ToRaw InputStepMode WGPUInputStepMode where
  raw ism =
    pure $
      case ism of
        InputStepModeVertex -> WGPUInputStepMode.Vertex
        InputStepModeInstance -> WGPUInputStepMode.Instance

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

-- | Describes how a vertex buffer is interpreted.
data VertexBufferLayout = VertexBufferLayout
  { -- | The stride, in bytes, between elements of the buffer.
    arrayStride :: !Word64,
    -- | How often the vertex buffer is stepped forward (per vertex or
    -- per instance).
    stepMode :: !InputStepMode,
    -- | List of attributes that comprise a single vertex.
    attributes :: !(Vector VertexAttribute)
  }
  deriving (Eq, Show)

instance ToRaw VertexBufferLayout WGPUVertexBufferLayout where
  raw VertexBufferLayout {..} = do
    n_stepMode <- raw stepMode
    attributes_ptr <- rawArrayPtr attributes
    pure
      WGPUVertexBufferLayout.WGPUVertexBufferLayout
        { arrayStride = arrayStride,
          stepMode = n_stepMode,
          attributeCount = fromIntegral . length $ attributes,
          attributes = attributes_ptr
        }

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

-- | Describes the vertex process in a render pipeline.
data VertexState = VertexState
  { -- | The compiled shader module for this stage.
    vertexShaderModule :: !ShaderModule,
    -- | The name of the entry point in the compiled shader. There must be a
    -- function that returns @void@ with this name in the shader.
    vertexEntryPoint :: !ShaderEntryPoint,
    -- | The format of any vertex buffers used with this pipeline.
    buffers :: !(Vector VertexBufferLayout)
  }
  deriving (Eq, Show)

instance ToRaw VertexState WGPUVertexState where
  raw VertexState {..} = do
    n_shaderModule <- raw vertexShaderModule
    entryPoint_ptr <- rawPtr vertexEntryPoint
    buffers_ptr <- rawArrayPtr buffers
    pure
      WGPUVertexState.WGPUVertexState
        { nextInChain = nullPtr,
          shaderModule = n_shaderModule,
          entryPoint = entryPoint_ptr,
          bufferCount = fromIntegral . length $ buffers,
          buffers = buffers_ptr
        }

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

-- | Primitive type out of which an input mesh is composed.
data PrimitiveTopology
  = PrimitiveTopologyPointList
  | PrimitiveTopologyLineList
  | PrimitiveTopologyLineStrip
  | PrimitiveTopologyTriangleList
  | PrimitiveTopologyTriangleStrip
  deriving (Eq, Show)

instance Default PrimitiveTopology where def = PrimitiveTopologyTriangleList

-- | Convert a 'PrimitiveTopology' to its raw value.
instance ToRaw PrimitiveTopology WGPUPrimitiveTopology where
  raw pt =
    pure $
      case pt of
        PrimitiveTopologyPointList -> WGPUPrimitiveTopology.PointList
        PrimitiveTopologyLineList -> WGPUPrimitiveTopology.LineList
        PrimitiveTopologyLineStrip -> WGPUPrimitiveTopology.LineStrip
        PrimitiveTopologyTriangleList -> WGPUPrimitiveTopology.TriangleList
        PrimitiveTopologyTriangleStrip -> WGPUPrimitiveTopology.TriangleStrip

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

-- | Format of indices used within a pipeline.
data IndexFormat
  = -- | Indices are 16-bit unsigned integers ('Word16')
    IndexFormatUint16
  | -- | Indices are 32-bit unsigned integers ('Word32')
    IndexFormatUint32
  deriving (Eq, Show)

-- | Convert an 'IndexFormat' to its raw value.
instance ToRaw IndexFormat WGPUIndexFormat where
  raw idxFmt =
    pure $
      case idxFmt of
        IndexFormatUint16 -> WGPUIndexFormat.Uint16
        IndexFormatUint32 -> WGPUIndexFormat.Uint32

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

-- | Winding order which classifies the "front" face.
data FrontFace
  = -- | Triangles with counter-clockwise vertices are the front face.
    FrontFaceCCW
  | -- | Triangles with clockwise vertices are the front face.
    FrontFaceCW
  deriving (Eq, Show)

instance Default FrontFace where def = FrontFaceCCW

-- | Convert a 'FrontFace' to its raw value.
instance ToRaw FrontFace WGPUFrontFace where
  raw ff =
    pure $
      case ff of
        FrontFaceCCW -> WGPUFrontFace.CCW
        FrontFaceCW -> WGPUFrontFace.CW

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

-- | Whether to cull the face of a vertex.
data CullMode
  = -- | Cull the front face.
    CullModeFront
  | -- | Cull the back face.
    CullModeBack
  | -- | Do not cull either face.
    CullModeNone
  deriving (Eq, Show)

instance Default CullMode where def = CullModeNone

-- | Convert a 'CullMode' to its raw value.
instance ToRaw CullMode WGPUCullMode where
  raw cm =
    pure $
      case cm of
        CullModeFront -> WGPUCullMode.Front
        CullModeBack -> WGPUCullMode.Back
        CullModeNone -> WGPUCullMode.None

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

-- | Describes the state of primitive assembly and rasterization in a render
-- pipeline.
--
-- Differences between this and the Rust API:
--   - no `clamp_depth` member
--   - no `polygon_mode` member
--   - no `conservative` member
data PrimitiveState = PrimitiveState
  { -- | The primitive topology used to interpret vertices.
    topology :: !PrimitiveTopology,
    -- | When drawing strip topologies with indices, this is the required
    -- format for the index buffer. This has no effect for non-indexed or
    -- non-strip draws.
    stripIndexFormat :: !(SMaybe IndexFormat),
    -- | The face to consider the front for the purpose of culling and
    -- stencil operations.
    frontFace :: !FrontFace,
    -- | The face culling mode.
    cullMode :: !CullMode
  }
  deriving (Eq, Show)

instance Default PrimitiveState where
  def =
    PrimitiveState
      { topology = def,
        stripIndexFormat = SNothing,
        frontFace = def,
        cullMode = def
      }

instance ToRaw PrimitiveState WGPUPrimitiveState where
  raw PrimitiveState {..} = do
    n_topology <- raw topology
    n_stripIndexFormat <-
      case stripIndexFormat of
        SNothing -> pure WGPUIndexFormat.Undefined
        SJust sif -> raw sif
    n_frontFace <- raw frontFace
    n_cullMode <- raw cullMode
    pure
      WGPUPrimitiveState.WGPUPrimitiveState
        { nextInChain = nullPtr,
          topology = n_topology,
          stripIndexFormat = n_stripIndexFormat,
          frontFace = n_frontFace,
          cullMode = n_cullMode
        }

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

-- | Operation to perform on a stencil value.
data StencilOperation
  = StencilOperationKeep
  | StencilOperationZero
  | StencilOperationReplace
  | StencilOperationInvert
  | StencilOperationIncrementClamp
  | StencilOperationDecrementClamp
  | StencilOperationIncrementWrap
  | StencilOperationDecrementWrap
  deriving (Eq, Show)

-- | Convert a 'StencilOperation' to its raw value.
instance ToRaw StencilOperation WGPUStencilOperation where
  raw so =
    pure $
      case so of
        StencilOperationKeep -> WGPUStencilOperation.Keep
        StencilOperationZero -> WGPUStencilOperation.Zero
        StencilOperationReplace -> WGPUStencilOperation.Replace
        StencilOperationInvert -> WGPUStencilOperation.Invert
        StencilOperationIncrementClamp -> WGPUStencilOperation.IncrementClamp
        StencilOperationDecrementClamp -> WGPUStencilOperation.DecrementClamp
        StencilOperationIncrementWrap -> WGPUStencilOperation.IncrementWrap
        StencilOperationDecrementWrap -> WGPUStencilOperation.DecrementWrap

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

-- | Describes stencil state in a render pipeline.
data StencilFaceState = StencilFaceState
  { compare :: !CompareFunction,
    failOp :: !StencilOperation,
    depthFailOp :: !StencilOperation,
    passOp :: !StencilOperation
  }
  deriving (Eq, Show)

instance ToRaw StencilFaceState WGPUStencilFaceState where
  raw StencilFaceState {..} = do
    n_compare <- raw compare
    n_failOp <- raw failOp
    n_depthFailOp <- raw depthFailOp
    n_passOp <- raw passOp
    pure
      WGPUStencilFaceState.WGPUStencilFaceState
        { compare = n_compare,
          failOp = n_failOp,
          depthFailOp = n_depthFailOp,
          passOp = n_passOp
        }

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

-- | State of the stencil operation (fixed pipeline stage).
data StencilState = StencilState
  { -- | Front face mode.
    front :: !StencilFaceState,
    -- | Back face mode.
    back :: !StencilFaceState,
    -- | Stencil values are AND-ed with this mask when reading and writing from
    -- the stencil buffer.
    readMask :: !Word8,
    -- | Stencil values are AND-ed with this mask when writing to the stencil
    -- buffer.
    writeMask :: !Word8
  }
  deriving (Eq, Show)

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

-- | Describes the biasing setting for the depth target.
data DepthBiasState = DepthBiasState
  { -- Constant depth biasing factor, in basic units of the depth format.
    constant :: !Int32,
    -- | Slope depth biasing factor.
    slopeScale :: !Float,
    -- | Depth bias clamp value (absolute).
    clamp :: !Float
  }
  deriving (Eq, Show)

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

-- | Describes the depth / stencil state of a render pipeline.
data DepthStencilState = DepthStencilState
  { -- | Format of the depth/stencil buffer. This must be a special depth
    -- format, and must match the format of the depth/stencil attachment in
    -- the command encoder.
    depthStencilTextureFormat :: !TextureFormat,
    -- | If disabled, depth will not be written to.
    depthWriteEnabled :: !Bool,
    -- | Comparison function used to compare depth values in the depth test.
    depthCompare :: !CompareFunction,
    -- | Stencil state.
    stencil :: !StencilState,
    -- | Depth bias state.
    bias :: !DepthBiasState
  }
  deriving (Eq, Show)

instance ToRaw DepthStencilState WGPUDepthStencilState where
  raw DepthStencilState {..} = do
    n_format <- raw depthStencilTextureFormat
    n_depthWriteEnabled <- raw depthWriteEnabled
    n_depthCompare <- raw depthCompare
    n_stencilFront <- raw . front $ stencil
    n_stencilBack <- raw . back $ stencil
    pure
      WGPUDepthStencilState.WGPUDepthStencilState
        { nextInChain = nullPtr,
          format = n_format,
          depthWriteEnabled = n_depthWriteEnabled,
          depthCompare = n_depthCompare,
          stencilFront = n_stencilFront,
          stencilBack = n_stencilBack,
          stencilReadMask = fromIntegral . readMask $ stencil,
          stencilWriteMask = fromIntegral $ writeMask (stencil :: StencilState),
          depthBias = constant bias,
          depthBiasSlopeScale = CFloat (slopeScale bias),
          depthBiasClamp = CFloat (clamp bias)
        }

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

-- | Describes the multi-sampling state of a render pipeline.
data MultisampleState = MultisampleState
  { -- | Number of samples calculated per pixel (for MSAA). For
    -- non-multisampled textures, this should be 1.
    count :: Word32,
    -- | Bitmask that restricts the samples of a pixel modified by this
    -- pipeline. All samples can be enabled by using
    -- @0XFFFFFFFF@ (ie. zero complement).
    mask :: Word32,
    -- | When enabled, produces another sample mask per pixel based on the
    -- alpha output value, and that is AND-ed with the sample mask and the
    -- primitive coverage to restrict the set of samples affected by a
    -- primitive.
    alphaToCoverageEnabled :: Bool
  }
  deriving (Eq, Show)

instance ToRaw MultisampleState WGPUMultisampleState where
  raw MultisampleState {..} = do
    n_alphaToCoverageEnabled <- raw alphaToCoverageEnabled
    pure
      WGPUMultisampleState.WGPUMultisampleState
        { nextInChain = nullPtr,
          count = count,
          mask = mask,
          alphaToCoverageEnabled = n_alphaToCoverageEnabled
        }

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

-- | Alpha blend factor.
data BlendFactor
  = BlendFactorZero
  | BlendFactorOne
  | BlendFactorSrc
  | BlendFactorOneMinusSrc
  | BlendFactorSrcAlpha
  | BlendFactorOneMinusSrcAlpha
  | BlendFactorDst
  | BlendFactorOneMinusDst
  | BlendFactorDstAlpha
  | BlendFactorOneMinusDstAlpha
  | BlendFactorSrcAlphaSaturated
  | BlendFactorConstant
  | BlendFactorOneMinusConstant
  deriving (Eq, Show)

-- | Convert a 'BlendFactor' to its raw value.
instance ToRaw BlendFactor WGPUBlendFactor where
  raw bf =
    pure $
      case bf of
        BlendFactorZero -> WGPUBlendFactor.Zero
        BlendFactorOne -> WGPUBlendFactor.One
        BlendFactorSrc -> WGPUBlendFactor.Src
        BlendFactorOneMinusSrc -> WGPUBlendFactor.OneMinusSrc
        BlendFactorSrcAlpha -> WGPUBlendFactor.SrcAlpha
        BlendFactorOneMinusSrcAlpha -> WGPUBlendFactor.OneMinusSrcAlpha
        BlendFactorDst -> WGPUBlendFactor.Dst
        BlendFactorOneMinusDst -> WGPUBlendFactor.OneMinusDst
        BlendFactorDstAlpha -> WGPUBlendFactor.DstAlpha
        BlendFactorOneMinusDstAlpha -> WGPUBlendFactor.OneMinusDstAlpha
        BlendFactorSrcAlphaSaturated -> WGPUBlendFactor.SrcAlphaSaturated
        BlendFactorConstant -> WGPUBlendFactor.Constant
        BlendFactorOneMinusConstant -> WGPUBlendFactor.OneMinusConstant

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

-- | Alpha blending operation.
data BlendOperation
  = BlendOperationAdd
  | BlendOperationSubtract
  | BlendOperationReverseSubtract
  | BlendOperationMin
  | BlendOperationMax
  deriving (Eq, Show)

-- | Convert a 'BlendOperation' to its raw value.
instance ToRaw BlendOperation WGPUBlendOperation where
  raw bo =
    pure $
      case bo of
        BlendOperationAdd -> WGPUBlendOperation.Add
        BlendOperationSubtract -> WGPUBlendOperation.Subtract
        BlendOperationReverseSubtract -> WGPUBlendOperation.ReverseSubtract
        BlendOperationMin -> WGPUBlendOperation.Min
        BlendOperationMax -> WGPUBlendOperation.Max

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

-- | Describes the blend component of a pipeline.
data BlendComponent = BlendComponent
  { -- | Multiplier for the source, which is produced by the fragment shader.
    srcFactor :: !BlendFactor,
    -- | Multiplier for the destination, which is stored in the target.
    dstFactor :: !BlendFactor,
    -- | Binary operation applied to the source and destination, multiplied by
    -- their respective factors.
    operation :: !BlendOperation
  }
  deriving (Eq, Show)

instance Default BlendComponent where
  def =
    BlendComponent
      { srcFactor = BlendFactorOne,
        dstFactor = BlendFactorZero,
        operation = BlendOperationAdd
      }

instance ToRaw BlendComponent WGPUBlendComponent where
  raw BlendComponent {..} = do
    n_srcFactor <- raw srcFactor
    n_dstFactor <- raw dstFactor
    n_operation <- raw operation
    pure
      WGPUBlendComponent.WGPUBlendComponent
        { srcFactor = n_srcFactor,
          dstFactor = n_dstFactor,
          operation = n_operation
        }

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

-- | Describes the blend state of a render pipeline.
data BlendState = BlendState
  { -- | Color equation.
    blendColor :: !BlendComponent,
    -- | Alpha equation.
    blendAlpha :: !BlendComponent
  }
  deriving (Eq, Show)

instance ToRaw BlendState WGPUBlendState where
  raw BlendState {..} = do
    n_color <- raw blendColor
    n_alpha <- raw blendAlpha
    pure
      WGPUBlendState.WGPUBlendState
        { color = n_color,
          alpha = n_alpha
        }

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

-- | Describes which color channels are written.
data ColorWriteMask = ColorWriteMask
  { maskRed :: !Bool,
    maskGreen :: !Bool,
    maskBlue :: !Bool,
    maskAlpha :: !Bool
  }
  deriving (Eq, Show)

-- | A 'ColorWriteMask' that writes all colors and the alpha value.
colorWriteMaskAll :: ColorWriteMask
colorWriteMaskAll = ColorWriteMask True True True True

instance ToRaw ColorWriteMask WGPUColorWriteMask where
  raw ColorWriteMask {..} =
    pure $
      WGPUColorWriteMask
        ( (if maskRed then WGPUColorWriteMask.Red else 0)
            .|. (if maskGreen then WGPUColorWriteMask.Green else 0)
            .|. (if maskBlue then WGPUColorWriteMask.Blue else 0)
            .|. (if maskAlpha then WGPUColorWriteMask.Alpha else 0)
        )

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

-- | Describes the color state of a render pipeline.
data ColorTargetState = ColorTargetState
  { -- | The texture format of the image that this pipeline will render to.
    -- Must match the format of the corresponding color attachment in the
    -- command encoder.
    colorTextureFormat :: !TextureFormat,
    -- | The blending that is used for this pipeline.
    blend :: !(SMaybe BlendState),
    -- | Mask which enables or disables writes to different color/alpha
    -- channels.
    colorWriteMask :: !ColorWriteMask
  }
  deriving (Eq, Show)

instance ToRaw ColorTargetState WGPUColorTargetState where
  raw ColorTargetState {..} = do
    n_format <- raw colorTextureFormat
    blend_ptr <-
      case blend of
        SNothing -> pure nullPtr
        SJust x -> rawPtr x
    WGPUColorWriteMask n_writeMask <- raw colorWriteMask
    pure
      WGPUColorTargetState.WGPUColorTargetState
        { nextInChain = nullPtr,
          format = n_format,
          blend = blend_ptr,
          writeMask = n_writeMask
        }

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

-- | Describes the fragment processing in a render pipeline.
data FragmentState = FragmentState
  { -- | The compiled shader module for this stage.
    fragmentShaderModule :: !ShaderModule,
    -- | The entry point in the compiled shader. There must be a function that
    -- returns @void@ with this name in the shader.
    fragmentEntryPoint :: !ShaderEntryPoint,
    -- | The color state of the render targets.
    targets :: !(Vector ColorTargetState)
  }
  deriving (Eq, Show)

instance ToRaw FragmentState WGPUFragmentState where
  raw FragmentState {..} = do
    n_shaderModule <- raw fragmentShaderModule
    entryPoint_ptr <- rawPtr fragmentEntryPoint
    targets_ptr <- rawArrayPtr targets
    pure
      WGPUFragmentState.WGPUFragmentState
        { nextInChain = nullPtr,
          shaderModule = n_shaderModule,
          entryPoint = entryPoint_ptr,
          targetCount = fromIntegral . length $ targets,
          targets = targets_ptr
        }

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

-- | Describes a render (graphics) pipeline.
data RenderPipelineDescriptor = RenderPipelineDescriptor
  { -- | Debug label of the pipeline.
    renderPipelineLabel :: !Text,
    -- | The layout of bind groups for this pipeline.
    layout :: !(SMaybe PipelineLayout),
    -- | Vertex state.
    vertex :: !VertexState,
    -- | Primitive state.
    primitive :: !PrimitiveState,
    -- | Depth stencil state.
    depthStencil :: !(SMaybe DepthStencilState),
    -- | Multisample state.
    multisample :: !MultisampleState,
    -- | Fragment state.
    fragment :: !(SMaybe FragmentState)
  }
  deriving (Eq, Show)

instance ToRaw RenderPipelineDescriptor WGPURenderPipelineDescriptor where
  raw RenderPipelineDescriptor {..} = do
    label_ptr <- rawPtr renderPipelineLabel
    n_layout <-
      case layout of
        SNothing -> pure (WGPUPipelineLayout nullPtr)
        SJust x -> raw x
    n_vertex <- raw vertex
    n_primitive <- raw primitive
    n_depthStencil <-
      case depthStencil of
        SNothing -> pure nullPtr
        SJust x -> rawPtr x
    n_multisample <- raw multisample
    n_fragment <-
      case fragment of
        SNothing -> pure nullPtr
        SJust x -> rawPtr x
    pure
      WGPURenderPipelineDescriptor.WGPURenderPipelineDescriptor
        { nextInChain = nullPtr,
          label = label_ptr,
          layout = n_layout,
          vertex = n_vertex,
          primitive = n_primitive,
          depthStencil = n_depthStencil,
          multisample = n_multisample,
          fragment = n_fragment
        }

createRenderPipeline ::
  Device ->
  RenderPipelineDescriptor ->
  IO RenderPipeline
createRenderPipeline device rpd = evalContT $ do
  let inst :: Instance
      inst = deviceInst device

  renderPipelineDescriptor_ptr <- rawPtr rpd
  renderPipelineRaw <-
    liftIO $
      RawFun.wgpuDeviceCreateRenderPipeline
        (wgpuHsInstance inst)
        (wgpuDevice device)
        renderPipelineDescriptor_ptr
  pure (RenderPipeline renderPipelineRaw)