{-# LANGUAGE AllowAmbiguousTypes #-}

module Mischief.Render.Material.Definition where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State (MonadState (get), put)
import Data.Data
import Data.Foldable
import Data.Kind (Type)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Foreign (Ptr, nullPtr, with)
import Foreign.C.ConstPtr
import GHC.TypeLits
import Mischief.Assets (Asset (..))
import Mischief.ECS
import Mischief.Math qualified as Math
import Mischief.Render.Core
import Mischief.Render.Texture
import Mischief.Render.TextureFormat
import Mischief.Shader hiding (FragmentOutput, VertexOutput)
import Mischief.Shader.Generation hiding (FragmentOutput)
import Mischief.Shader.Internal.Bindings (Bindable, ErasedBinding (..), ErasedBindingValue, createBindGroup, createBindLayout, dummyBinding)
import Mischief.Shader.Internal.Params
import Mischief.Shader.Internal.State
import Mischief.Shader.Types qualified as ST
import Mischief.WGPU
import Mischief.WGPU.Framework (loadShaderFromBytes)
import Mischief.WGPU.Opaque
import Mischief.WGPU.Types.Enums
import Mischief.WGPU.Types.General
import Unsafe.Coerce (unsafeCoerce)

newtype DefaultVI f = DefaultVI (BuiltIn f "vertex_index" Uint)
  deriving ((forall x. DefaultVI f -> Rep (DefaultVI f) x)
-> (forall x. Rep (DefaultVI f) x -> DefaultVI f)
-> Generic (DefaultVI f)
forall x. Rep (DefaultVI f) x -> DefaultVI f
forall x. DefaultVI f -> Rep (DefaultVI f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall f x. Rep (DefaultVI f) x -> DefaultVI f
forall f x. DefaultVI f -> Rep (DefaultVI f) x
$cfrom :: forall f x. DefaultVI f -> Rep (DefaultVI f) x
from :: forall x. DefaultVI f -> Rep (DefaultVI f) x
$cto :: forall f x. Rep (DefaultVI f) x -> DefaultVI f
to :: forall x. Rep (DefaultVI f) x -> DefaultVI f
Generic)
  deriving anyclass (Typeable (DefaultVI GPU)
Params
ParamDefinition
DefaultVI GPU
Typeable (DefaultVI GPU) =>
Params
-> ParamDefinition
-> DefaultVI GPU
-> (DefaultVI GPU -> Values)
-> ShaderParam DefaultVI
DefaultVI GPU -> Values
forall (a :: * -> *).
Typeable (a GPU) =>
Params
-> ParamDefinition -> a GPU -> (a GPU -> Values) -> ShaderParam a
$ccollectParams :: Params
collectParams :: Params
$cparamDefinition :: ParamDefinition
paramDefinition :: ParamDefinition
$cdummyParam :: DefaultVI GPU
dummyParam :: DefaultVI GPU
$ccollectValues :: DefaultVI GPU -> Values
collectValues :: DefaultVI GPU -> Values
ShaderParam)

newtype DefaultVO f = DefaultVO
  { forall f. DefaultVO f -> BuiltIn f "position" (Vec 4 Float)
pos :: BuiltIn f "position" (Vec 4 ST.Float)
  }
  deriving ((forall x. DefaultVO f -> Rep (DefaultVO f) x)
-> (forall x. Rep (DefaultVO f) x -> DefaultVO f)
-> Generic (DefaultVO f)
forall x. Rep (DefaultVO f) x -> DefaultVO f
forall x. DefaultVO f -> Rep (DefaultVO f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall f x. Rep (DefaultVO f) x -> DefaultVO f
forall f x. DefaultVO f -> Rep (DefaultVO f) x
$cfrom :: forall f x. DefaultVO f -> Rep (DefaultVO f) x
from :: forall x. DefaultVO f -> Rep (DefaultVO f) x
$cto :: forall f x. Rep (DefaultVO f) x -> DefaultVO f
to :: forall x. Rep (DefaultVO f) x -> DefaultVO f
Generic)
  deriving anyclass (Typeable (DefaultVO GPU)
Params
ParamDefinition
DefaultVO GPU
Typeable (DefaultVO GPU) =>
Params
-> ParamDefinition
-> DefaultVO GPU
-> (DefaultVO GPU -> Values)
-> ShaderParam DefaultVO
DefaultVO GPU -> Values
forall (a :: * -> *).
Typeable (a GPU) =>
Params
-> ParamDefinition -> a GPU -> (a GPU -> Values) -> ShaderParam a
$ccollectParams :: Params
collectParams :: Params
$cparamDefinition :: ParamDefinition
paramDefinition :: ParamDefinition
$cdummyParam :: DefaultVO GPU
dummyParam :: DefaultVO GPU
$ccollectValues :: DefaultVO GPU -> Values
collectValues :: DefaultVO GPU -> Values
ShaderParam)

class
  ( Bindable (B a),
    ShaderParam (VI a),
    ShaderParam (VO a),
    Extension (Extends a),
    Typeable a,
    Typeable (B a),
    Typeable (VI a),
    Typeable (VO a),
    Typeable (Extends a),
    Typeable (IsPhantom a)
  ) =>
  Material (a :: Type)
  where
  type VI a :: Type -> Type
  type VO a :: Type -> Type

  type B a :: Type -> Type

  type Extends a :: [Type]
  type Extends a = '[]

  type Extandable a :: Bool
  type Extandable a = True

  type IsPhantom a :: Bool
  type IsPhantom a = False

  vertex :: VI a GPU -> Shader a (VO a GPU)
  default vertex :: (IsPhantom a ~ True) => VI a GPU -> Shader a (VO a GPU)
  vertex = VI a GPU -> Shader a (VO a GPU)
forall a. HasCallStack => a
undefined

  fragment :: VO a GPU -> Shader a (ST.Vec 4 ST.Float)
  default fragment :: (IsPhantom a ~ True) => VO a GPU -> Shader a (ST.Vec 4 ST.Float)
  fragment = VO a GPU -> Shader a (Expr ('VectorType 4 'TFloat))
VO a GPU -> Shader a (Vec 4 Float)
forall a. HasCallStack => a
undefined

  fetch :: FetchBindings (B a)

data PhantomMaterial = PhantomMaterial deriving (Typeable PhantomMaterial
[HookRel PhantomMaterial]
[Hook PhantomMaterial]
Set DefaultComponentType
IsExclusive (IsExclusiveRel PhantomMaterial)
(Typeable PhantomMaterial,
 IsExclusive (IsExclusiveRel PhantomMaterial)) =>
Set DefaultComponentType
-> [Hook PhantomMaterial]
-> [Hook PhantomMaterial]
-> [Hook PhantomMaterial]
-> [HookRel PhantomMaterial]
-> [HookRel PhantomMaterial]
-> [HookRel PhantomMaterial]
-> Component PhantomMaterial
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook PhantomMaterial]
onAdd :: [Hook PhantomMaterial]
$conSet :: [Hook PhantomMaterial]
onSet :: [Hook PhantomMaterial]
$conRemove :: [Hook PhantomMaterial]
onRemove :: [Hook PhantomMaterial]
$conAddRel :: [HookRel PhantomMaterial]
onAddRel :: [HookRel PhantomMaterial]
$conSetRel :: [HookRel PhantomMaterial]
onSetRel :: [HookRel PhantomMaterial]
$conRemoveRel :: [HookRel PhantomMaterial]
onRemoveRel :: [HookRel PhantomMaterial]
Component)

data MaterialType where
  MaterialType :: forall m. (Material m) => Proxy m -> MaterialType
  deriving (Typeable MaterialType
[HookRel MaterialType]
[Hook MaterialType]
Set DefaultComponentType
IsExclusive (IsExclusiveRel MaterialType)
(Typeable MaterialType,
 IsExclusive (IsExclusiveRel MaterialType)) =>
Set DefaultComponentType
-> [Hook MaterialType]
-> [Hook MaterialType]
-> [Hook MaterialType]
-> [HookRel MaterialType]
-> [HookRel MaterialType]
-> [HookRel MaterialType]
-> Component MaterialType
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook MaterialType]
onAdd :: [Hook MaterialType]
$conSet :: [Hook MaterialType]
onSet :: [Hook MaterialType]
$conRemove :: [Hook MaterialType]
onRemove :: [Hook MaterialType]
$conAddRel :: [HookRel MaterialType]
onAddRel :: [HookRel MaterialType]
$conSetRel :: [HookRel MaterialType]
onSetRel :: [HookRel MaterialType]
$conRemoveRel :: [HookRel MaterialType]
onRemoveRel :: [HookRel MaterialType]
Component)

data NoMaterial

-- type StoreData MaterialType = (MaterialType, )
-- storeAsset = undefined

liftExt :: forall a b c. (ExtensionOf b a) => Shader a c -> Shader b c
liftExt :: forall a b c. ExtensionOf b a => Shader a c -> Shader b c
liftExt (Shader State ShaderState c
a) = State ShaderState c -> Shader b c
forall {k} (m :: k) a. State ShaderState a -> Shader m a
Shader State ShaderState c
a

class Extension (a :: [Type]) where
  collectExtBindings :: Set ErasedBinding

instance {-# OVERLAPS #-} Extension '[] where
  collectExtBindings :: Set ErasedBinding
collectExtBindings = Set ErasedBinding
forall a. Set a
Set.empty

instance (Extension xs, Material a) => Extension (a : xs) where
  collectExtBindings :: Set ErasedBinding
collectExtBindings = [Set ErasedBinding] -> Set ErasedBinding
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ErasedBinding -> Set ErasedBinding
forall a. a -> Set a
Set.singleton (ErasedBinding -> Set ErasedBinding)
-> ErasedBinding -> Set ErasedBinding
forall a b. (a -> b) -> a -> b
$ MaterialType -> Proxy a -> Proxy (B a) -> ErasedBinding
forall (b :: * -> *) a m.
(Typeable m, Bindable b, Typeable b, Typeable a) =>
m -> Proxy a -> Proxy b -> ErasedBinding
ErasedBinding (Proxy a -> MaterialType
forall m. Material m => Proxy m -> MaterialType
MaterialType (Proxy a -> MaterialType) -> Proxy a -> MaterialType
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @(B a)), forall (a :: [*]). Extension a => Set ErasedBinding
collectExtBindings @(Extends a), forall (a :: [*]). Extension a => Set ErasedBinding
collectExtBindings @xs]

collectBindings :: forall m. (Material m) => Set ErasedBinding
collectBindings :: forall m. Material m => Set ErasedBinding
collectBindings = Set ErasedBinding -> Set ErasedBinding -> Set ErasedBinding
forall a. Ord a => Set a -> Set a -> Set a
Set.union (ErasedBinding -> Set ErasedBinding
forall a. a -> Set a
Set.singleton (ErasedBinding -> Set ErasedBinding)
-> ErasedBinding -> Set ErasedBinding
forall a b. (a -> b) -> a -> b
$ MaterialType -> Proxy m -> Proxy (B m) -> ErasedBinding
forall (b :: * -> *) a m.
(Typeable m, Bindable b, Typeable b, Typeable a) =>
m -> Proxy a -> Proxy b -> ErasedBinding
ErasedBinding (Proxy m -> MaterialType
forall m. Material m => Proxy m -> MaterialType
MaterialType (Proxy m -> MaterialType) -> Proxy m -> MaterialType
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m) (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @(B m))) (Set ErasedBinding -> Set ErasedBinding)
-> Set ErasedBinding -> Set ErasedBinding
forall a b. (a -> b) -> a -> b
$ forall (a :: [*]). Extension a => Set ErasedBinding
collectExtBindings @(Extends m)

type ExtensionOf a b = (Material a, IsExtensionOf a b ~ True)

type family IsExtensionOf a b where
  IsExtensionOf a NoMaterial = True
  IsExtensionOf a b = IsExtensionOf' '[a] b

type family IsExtensionOf' (m :: [Type]) (target :: Type) :: Bool where
  IsExtensionOf' '[] a = False
  IsExtensionOf' (a : xs) a = True
  IsExtensionOf' (a : xs) t = Or (IsExtensionOf' (Extends a) t) (IsExtensionOf' xs t)

type family Or a b where
  Or False False = False
  Or a b = True

-- type family ExtendsMaterialRec (e :: Maybe Type) (target :: Type) :: Bool where
--   ExtendsMaterialRec Nothing t = False
--   ExtendsMaterialRec (Just m) t = IsExtensionOf m t

bindings :: forall a. (Material a) => Shader a (B a GPU)
bindings :: forall a. Material a => Shader a (B a GPU)
bindings = do
  ShaderState {dict} <- Shader a ShaderState
forall s (m :: * -> *). MonadState s m => m s
get
  (ErasedValue a) <- pure $ unwrap $ Map.lookup (typeRep $ Proxy @a) dict
  pure $ unsafeCoerce a

extension :: forall e a. (Material e, ExtensionOf a e) => Shader a (B e GPU)
extension :: forall e a. (Material e, ExtensionOf a e) => Shader a (B e GPU)
extension = do
  ShaderState {dict} <- Shader a ShaderState
forall s (m :: * -> *). MonadState s m => m s
get
  (ErasedValue a) <- pure $ unwrap $ Map.lookup (typeRep $ Proxy @e) dict
  pure $ unsafeCoerce a

convertFrag :: forall m. (VO m GPU -> Shader m (ST.Vec 4 ST.Float)) -> VO m GPU -> Shader m (FragmentOutput GPU)
convertFrag :: forall m.
(VO m GPU -> Shader m (Vec 4 Float))
-> VO m GPU -> Shader m (FragmentOutput GPU)
convertFrag VO m GPU -> Shader m (Vec 4 Float)
s VO m GPU
v = do
  s' <- VO m GPU -> Shader m (Vec 4 Float)
s VO m GPU
v
  pure $ FragmentOutput s'

data FetchBindings b where
  FetchBindings ::
    forall x y b.
    (Bindable b) =>
    { ()
camera :: CameraEntity -> Query System x,
      ()
mesh :: MeshEntity -> Query System y,
      ()
result :: x -> y -> b CPU
    } ->
    FetchBindings b

newtype FragmentOutput f = FragmentOutput
  { forall f. FragmentOutput f -> Location f 0 (Vec 4 Float)
fragOut1 :: Location f 0 (ST.Vec 4 ST.Float)
  }
  deriving stock ((forall x. FragmentOutput f -> Rep (FragmentOutput f) x)
-> (forall x. Rep (FragmentOutput f) x -> FragmentOutput f)
-> Generic (FragmentOutput f)
forall x. Rep (FragmentOutput f) x -> FragmentOutput f
forall x. FragmentOutput f -> Rep (FragmentOutput f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall f x. Rep (FragmentOutput f) x -> FragmentOutput f
forall f x. FragmentOutput f -> Rep (FragmentOutput f) x
$cfrom :: forall f x. FragmentOutput f -> Rep (FragmentOutput f) x
from :: forall x. FragmentOutput f -> Rep (FragmentOutput f) x
$cto :: forall f x. Rep (FragmentOutput f) x -> FragmentOutput f
to :: forall x. Rep (FragmentOutput f) x -> FragmentOutput f
Generic)
  deriving anyclass (Typeable (FragmentOutput GPU)
Params
ParamDefinition
FragmentOutput GPU
Typeable (FragmentOutput GPU) =>
Params
-> ParamDefinition
-> FragmentOutput GPU
-> (FragmentOutput GPU -> Values)
-> ShaderParam FragmentOutput
FragmentOutput GPU -> Values
forall (a :: * -> *).
Typeable (a GPU) =>
Params
-> ParamDefinition -> a GPU -> (a GPU -> Values) -> ShaderParam a
$ccollectParams :: Params
collectParams :: Params
$cparamDefinition :: ParamDefinition
paramDefinition :: ParamDefinition
$cdummyParam :: FragmentOutput GPU
dummyParam :: FragmentOutput GPU
$ccollectValues :: FragmentOutput GPU -> Values
collectValues :: FragmentOutput GPU -> Values
ShaderParam)

blendState :: WGPUBlendState
blendState :: WGPUBlendState
blendState =
  WGPUBlendState
    { color :: WGPUBlendComponent
color =
        WGPUBlendComponent
          { srcFactor :: WGPUBlendFactor
srcFactor = WGPUBlendFactor
wGPUBlendFactor_SrcAlpha,
            dstFactor :: WGPUBlendFactor
dstFactor = WGPUBlendFactor
wGPUBlendFactor_OneMinusSrcAlpha,
            operation :: WGPUBlendOperation
operation = WGPUBlendOperation
wGPUBlendOperation_Add
          },
      alpha :: WGPUBlendComponent
alpha =
        WGPUBlendComponent
          { srcFactor :: WGPUBlendFactor
srcFactor = WGPUBlendFactor
wGPUBlendFactor_One,
            dstFactor :: WGPUBlendFactor
dstFactor = WGPUBlendFactor
wGPUBlendFactor_OneMinusSrcAlpha,
            operation :: WGPUBlendOperation
operation = WGPUBlendOperation
wGPUBlendOperation_Add
          }
    }

data DrawCommand bindings = Draw {forall {k} (bindings :: k).
DrawCommand bindings -> [ErasedBindingValue]
binds :: [ErasedBindingValue], forall {k} (bindings :: k). DrawCommand bindings -> Natural
vertices :: Nat}

drawCommand :: forall m. (Material m) => RenderDevice -> Ptr WGPURenderPassEncoder -> BindLayout -> DrawCommand (B m) -> IO ()
drawCommand :: forall m.
Material m =>
RenderDevice
-> Ptr WGPURenderPassEncoder
-> BindLayout
-> DrawCommand (B m)
-> IO ()
drawCommand RenderDevice
device Ptr WGPURenderPassEncoder
encoder BindLayout
layout (Draw [ErasedBindingValue]
b Natural
vert) = do
  bindGroup <- RenderDevice
-> BindLayout -> [ErasedBindingValue] -> IO (Ptr WGPUBindGroup)
createBindGroup RenderDevice
device BindLayout
layout [ErasedBindingValue]
b
  wgpuRenderPassEncoderSetBindGroup encoder 0 bindGroup 0 (ConstPtr nullPtr)
  wgpuRenderPassEncoderDraw encoder (fromIntegral vert) 1 0 0

render :: forall mat. (Material mat) => RenderDevice -> RenderQueue -> RenderPipeline -> RenderOptions -> Texture -> [DrawCommand (B mat)] -> System ()
render :: forall mat.
Material mat =>
RenderDevice
-> RenderQueue
-> RenderPipeline
-> RenderOptions
-> Texture
-> [DrawCommand (B mat)]
-> System ()
render (RenderDevice Ptr WGPUDevice
device) (RenderQueue Ptr WGPUQueue
queue) (RenderPipeline Ptr WGPURenderPipeline
pipeline) RenderOptions {Clear
clear :: Clear
clear :: RenderOptions -> Clear
clear} (Texture {texture :: Texture -> Ptr WGPUTexture
texture = Ptr WGPUTexture
output}) [DrawCommand (B mat)]
commands = IO () -> System ()
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> System ()) -> IO () -> System ()
forall a b. (a -> b) -> a -> b
$ do
  bindLayout <- [ErasedBinding] -> RenderDevice -> IO BindLayout
createBindLayout (Set ErasedBinding -> [ErasedBinding]
forall a. Set a -> [a]
Set.toList (Set ErasedBinding -> [ErasedBinding])
-> Set ErasedBinding -> [ErasedBinding]
forall a b. (a -> b) -> a -> b
$ forall m. Material m => Set ErasedBinding
collectBindings @mat) (Ptr WGPUDevice -> RenderDevice
RenderDevice Ptr WGPUDevice
device)

  -- bindGroup <- createBindGroup (RenderDevice device) bindLayout b
  -- RenderPipeline pipeline <- createPipeline @mat (RenderDevice device) (toWGPUFormat format)

  frame <- wgpuTextureCreateView output (ConstPtr nullPtr)

  commandEncoder <- withWGPUString "command encoder" $ \WGPUStringView
label -> do
    let desc :: WGPUCommandEncoderDescriptor
desc = WGPUCommandEncoderDescriptor {nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr, WGPUStringView
label :: WGPUStringView
label :: WGPUStringView
label}
    WGPUCommandEncoderDescriptor
-> (Ptr WGPUCommandEncoderDescriptor
    -> IO (Ptr WGPUCommandEncoder))
-> IO (Ptr WGPUCommandEncoder)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUCommandEncoderDescriptor
desc ((Ptr WGPUCommandEncoderDescriptor -> IO (Ptr WGPUCommandEncoder))
 -> IO (Ptr WGPUCommandEncoder))
-> (Ptr WGPUCommandEncoderDescriptor
    -> IO (Ptr WGPUCommandEncoder))
-> IO (Ptr WGPUCommandEncoder)
forall a b. (a -> b) -> a -> b
$ \Ptr WGPUCommandEncoderDescriptor
desc -> Ptr WGPUDevice
-> Ptr WGPUCommandEncoderDescriptor -> IO (Ptr WGPUCommandEncoder)
wgpuDeviceCreateCommandEncoder Ptr WGPUDevice
device Ptr WGPUCommandEncoderDescriptor
desc

  let (clearValue, loadOp) = case clear of
        Clear (Math.V3 Float
a Float
b Float
c) -> (Double -> Double -> Double -> Double -> WGPUColor
wgpuColor (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
a) (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
b) (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
c) Double
1, WGPULoadOp
wGPULoadOp_Clear)
        Clear
DontClear -> (Double -> Double -> Double -> Double -> WGPUColor
wgpuColor Double
0 Double
0 Double
0 Double
1, WGPULoadOp
wGPULoadOp_Load)

  let attachment =
        WGPURenderPassColorAttachment
          { WGPUColor
clearValue :: WGPUColor
clearValue :: WGPUColor
clearValue,
            storeOp :: WGPUStoreOp
storeOp = WGPUStoreOp
wGPUStoreOp_Store,
            WGPULoadOp
loadOp :: WGPULoadOp
loadOp :: WGPULoadOp
loadOp,
            resolveTarget :: Ptr WGPUTextureView
resolveTarget = Ptr WGPUTextureView
forall a. Ptr a
nullPtr,
            depthSlice :: Word32
depthSlice = Word32
wGPU_DEPTH_SLICE_UNDEFINED,
            view :: Ptr WGPUTextureView
view = Ptr WGPUTextureView
frame,
            nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr
          }

  renderPassEncoder <- with attachment $ \Ptr WGPURenderPassColorAttachment
attachment -> do
    String
-> (WGPUStringView -> IO (Ptr WGPURenderPassEncoder))
-> IO (Ptr WGPURenderPassEncoder)
forall a. String -> (WGPUStringView -> IO a) -> IO a
withWGPUString String
"render pass encoder" ((WGPUStringView -> IO (Ptr WGPURenderPassEncoder))
 -> IO (Ptr WGPURenderPassEncoder))
-> (WGPUStringView -> IO (Ptr WGPURenderPassEncoder))
-> IO (Ptr WGPURenderPassEncoder)
forall a b. (a -> b) -> a -> b
$ \WGPUStringView
label -> do
      let desc :: WGPURenderPassDescriptor
desc =
            WGPURenderPassDescriptor
              { timestampWrites :: ConstPtr ()
timestampWrites = Ptr () -> ConstPtr ()
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr ()
forall a. Ptr a
nullPtr,
                occlusionQuerySet :: Ptr WGPUQuerySet
occlusionQuerySet = Ptr WGPUQuerySet
forall a. Ptr a
nullPtr,
                depthStencilAttachment :: ConstPtr ()
depthStencilAttachment = Ptr () -> ConstPtr ()
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr ()
forall a. Ptr a
nullPtr,
                colorAttachments :: ConstPtr WGPURenderPassColorAttachment
colorAttachments = Ptr WGPURenderPassColorAttachment
-> ConstPtr WGPURenderPassColorAttachment
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPURenderPassColorAttachment
attachment,
                colorAttachmentCount :: Int
colorAttachmentCount = Int
1,
                WGPUStringView
label :: WGPUStringView
label :: WGPUStringView
label,
                nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr
              }

      WGPURenderPassDescriptor
-> (Ptr WGPURenderPassDescriptor -> IO (Ptr WGPURenderPassEncoder))
-> IO (Ptr WGPURenderPassEncoder)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPURenderPassDescriptor
desc ((Ptr WGPURenderPassDescriptor -> IO (Ptr WGPURenderPassEncoder))
 -> IO (Ptr WGPURenderPassEncoder))
-> (Ptr WGPURenderPassDescriptor -> IO (Ptr WGPURenderPassEncoder))
-> IO (Ptr WGPURenderPassEncoder)
forall a b. (a -> b) -> a -> b
$ \Ptr WGPURenderPassDescriptor
desc -> do
        Ptr WGPUCommandEncoder
-> ConstPtr WGPURenderPassDescriptor
-> IO (Ptr WGPURenderPassEncoder)
wgpuCommandEncoderBeginRenderPass Ptr WGPUCommandEncoder
commandEncoder (Ptr WGPURenderPassDescriptor -> ConstPtr WGPURenderPassDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPURenderPassDescriptor
desc)

  when (renderPassEncoder == nullPtr) $ error "Couldn't encode render pass."

  wgpuRenderPassEncoderSetPipeline renderPassEncoder pipeline
  for_ commands $ drawCommand @mat (RenderDevice device) renderPassEncoder bindLayout
  wgpuRenderPassEncoderEnd renderPassEncoder
  wgpuRenderPassEncoderRelease renderPassEncoder

  commandBuffer <- withWGPUString "command buffer" $ \WGPUStringView
label -> do
    let desc :: WGPUCommandBufferDescriptor
desc = WGPUCommandBufferDescriptor {WGPUStringView
label :: WGPUStringView
label :: WGPUStringView
label, nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr}
    WGPUCommandBufferDescriptor
-> (Ptr WGPUCommandBufferDescriptor -> IO (Ptr WGPUCommandBuffer))
-> IO (Ptr WGPUCommandBuffer)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with WGPUCommandBufferDescriptor
desc ((Ptr WGPUCommandBufferDescriptor -> IO (Ptr WGPUCommandBuffer))
 -> IO (Ptr WGPUCommandBuffer))
-> (Ptr WGPUCommandBufferDescriptor -> IO (Ptr WGPUCommandBuffer))
-> IO (Ptr WGPUCommandBuffer)
forall a b. (a -> b) -> a -> b
$ \Ptr WGPUCommandBufferDescriptor
desc -> Ptr WGPUCommandEncoder
-> ConstPtr WGPUCommandBufferDescriptor
-> IO (Ptr WGPUCommandBuffer)
wgpuCommandEncoderFinish Ptr WGPUCommandEncoder
commandEncoder (Ptr WGPUCommandBufferDescriptor
-> ConstPtr WGPUCommandBufferDescriptor
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUCommandBufferDescriptor
desc)

  when (commandBuffer == nullPtr) $ error "Couldn't create command buffer."

  with commandBuffer $ \Ptr (Ptr WGPUCommandBuffer)
commandBuffer -> do
    Ptr WGPUQueue -> CSize -> ConstPtr (Ptr WGPUCommandBuffer) -> IO ()
wgpuQueueSubmit Ptr WGPUQueue
queue CSize
1 (Ptr (Ptr WGPUCommandBuffer) -> ConstPtr (Ptr WGPUCommandBuffer)
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr (Ptr WGPUCommandBuffer)
commandBuffer)

  wgpuCommandBufferRelease commandBuffer
  wgpuCommandEncoderRelease commandEncoder
  wgpuTextureViewRelease frame

data Clear = DontClear | Clear (Math.V3 Prelude.Float)

data RenderOptions = RenderOptions
  { RenderOptions -> Clear
clear :: Clear,
    RenderOptions -> Natural
nvertices :: Nat
  }

instance Default RenderOptions where
  def :: RenderOptions
def =
    RenderOptions
      { clear :: Clear
clear = Clear
DontClear,
        nvertices :: Natural
nvertices = Natural
6
      }