wgpu-hs 0.3.0.0 → 0.4.0.0

raw patch · 18 files changed

+2317/−121 lines, 18 filesdep +JuicyPixelsdep +derive-storabledep +lineardep ~data-defaultdep ~data-hasdep ~lensnew-component:exe:cubePVP ok

version bump matches the API change (PVP)

Dependencies added: JuicyPixels, derive-storable, linear

Dependency ranges changed: data-default, data-has, lens, mtl, resourcet, sdl2, text, vector, wgpu-raw-hs

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• examples/cube/Cube.hs +646/−0
• examples/triangle-glfw/TriangleGLFW.hs +3/−3
• examples/triangle-sdl/TriangleSDL.hs +26/−29
• src-internal/WGPU/Internal/Binding.hs +188/−30
• src-internal/WGPU/Internal/Buffer.hs +232/−0
• src-internal/WGPU/Internal/Memory.hs +69/−2
• src-internal/WGPU/Internal/Multipurpose.hs +167/−1
• src-internal/WGPU/Internal/Pipeline.hs +3/−23
• src-internal/WGPU/Internal/Queue.hs +84/−1
• src-internal/WGPU/Internal/RenderPass.hs +89/−1
• src-internal/WGPU/Internal/Sampler.hs +148/−1
• src-internal/WGPU/Internal/SwapChain.hs +5/−6
• src-internal/WGPU/Internal/Texture.hs +180/−17
• src/WGPU.hs +46/−1
• src/WGPU/BoneYard/SimpleSDL.hs +245/−3
• src/WGPU/Classy.hs +152/−1
• wgpu-hs.cabal +29/−2

@@ -1,5 +1,10 @@ # Revision history for wgpu-hs +## 0.4.0.0 -- 2021-09-10++- Add `cube `example.+- Initial support for buffers and textures.+ ## 0.3.0.0 -- 2021-08-30  - Add Classy interface - supply parameters from `ReaderT`.

@@ -0,0 +1,646 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Codec.Picture (Image, Pixel8)+import qualified Codec.Picture as Picture+import Control.Concurrent (MVar, modifyMVar_, newMVar, withMVar)+import Control.Exception.Safe (MonadThrow)+import Control.Lens (Lens', lens, set, (^.))+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import Control.Monad.Reader.Class (asks)+import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)+import Data.Default (def)+import Data.Foldable (foldl')+import Data.Has (Has, getter, hasLens)+import Data.Maybe (catMaybes, fromMaybe)+import qualified Data.String.QQ as SQQ+import Data.Text (Text)+import qualified Data.Text.IO as TextIO+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as Vector+import Data.Word (Word16, Word8)+import Foreign (sizeOf)+import Foreign.Storable.Generic (GStorable)+import GHC.Generics (Generic)+import Linear (V4 (V4), (!*!), _x, _y)+import qualified Linear+import Linear.Matrix (M44)+import Linear.V2 (V2 (V2))+import Linear.V3 (V3 (V3))+import qualified SDL+import qualified WGPU+import qualified WGPU.BoneYard.SimpleSDL as SimpleSDL+import qualified WGPU.Classy as C+import Prelude hiding (putStrLn)++main :: IO ()+main = runResourceT $ do+  -- Parameters for the static resource initialization+  let params =+        SimpleSDL.Params+          { title = "Cube Example",+            mDeviceDescriptor =+              WGPU.SJust $+                def {WGPU.limits = def {WGPU.maxBindGroups = 1}}+          }++  -- Initialize the app static resources. This creates the SDL window, the+  -- WGPU Instance, etc.+  resources <- SimpleSDL.loadResources params++  -- Create other state holders+  buffers <- SimpleSDL.emptyBuffers+  textures <- SimpleSDL.emptyTextures+  bindGroups <- SimpleSDL.emptyBindGroups+  shaders <- SimpleSDL.emptyShaders+  renderPipelines <- SimpleSDL.emptyRenderPipelines+  swapChainState <- SimpleSDL.emptySwapChainState+  viewTransform <- zeroViewTransform++  -- Run the app+  runApp Env {..} app++app :: App ()+app = do+  putStrLn "== Cube Example =="+  putStrLn "- Use left-mouse-button + drag to rotate the cube."+  putStrLn "- Press 'q' or close the window to quit."++  -- Dump some debugging stuff; set the WGPU log, etc.+  C.getVersion >>= \v -> putStrLn $ "WGPU version: " <> WGPU.versionToText v+  C.getAdapterProperties >>= \p -> putStrLn $ WGPU.adapterPropertiesToText p+  C.setLogLevel WGPU.Warn+  C.connectLog++  -- Create application-specific dynamic resources+  initApp++  -- Application loop+  let appLoop :: App ()+      appLoop = do+        render+        events <- SDL.pollEvents+        mouseInteraction events+        let qPressed, windowClosed, shouldClose :: Bool+            qPressed = any eventIsQPress events+            windowClosed = any eventIsWindowClose events+            shouldClose = qPressed || windowClosed+        unless shouldClose appLoop+  appLoop++mouseInteraction :: [SDL.Event] -> App ()+mouseInteraction events = do+  -- sensitivity is a coefficient that maps screen mouse motion to radians+  let sensitivity = 0.005+  let motionEvents =+        filter (\mmed -> SDL.ButtonLeft `elem` SDL.mouseMotionEventState mmed) $+          catMaybes (mMouseMotionEvent <$> events)+  unless (null motionEvents) $ do+    let dPos =+          foldl' (+) (V2 0 0) $+            SDL.mouseMotionEventRelMotion <$> motionEvents+    let dx = sensitivity * fromIntegral (dPos ^. _x)+        dy = sensitivity * fromIntegral (dPos ^. _y)+    _ <-+      modifyViewTransform+        ( \t ->+            t+              { vtYRot = vtYRot t + dx,+                vtXRot = vtXRot t + dy+              }+        )+    updateViewTransformUniformBuffer++-- | Rendering action.+render :: App ()+render = SimpleSDL.withSwapChain $ do+  nextTexture <- C.getSwapChainCurrentTextureView+  renderPipeline <- SimpleSDL.getRenderPipeline "Render Pipeline"+  indexBuffer <- SimpleSDL.getBuffer "index"+  vertexBuffer <- SimpleSDL.getBuffer "vertex"+  bindGroup <- SimpleSDL.getBindGroup "Bind Group"+  commandBuffer <-+    C.buildCommandBuffer "Command Encoder" "Command Buffer" $ do+      let renderPassDescriptor =+            WGPU.RenderPassDescriptor+              { renderPassLabel = "Render Pass",+                colorAttachments =+                  [ WGPU.RenderPassColorAttachment+                      { colorView = nextTexture,+                        resolveTarget = WGPU.SNothing,+                        operations =+                          WGPU.Operations+                            { load =+                                WGPU.LoadOpClear+                                  (WGPU.Color 0.1 0.2 0.3 1.0),+                              store = WGPU.StoreOpStore+                            }+                      }+                  ],+                depthStencilAttachment = WGPU.SNothing+              }+      C.buildRenderPass renderPassDescriptor $ do+        C.renderPassSetPipeline renderPipeline+        C.renderPassSetBindGroup 0 bindGroup []+        C.renderPassSetIndexBuffer+          indexBuffer+          WGPU.IndexFormatUint16+          0+          (fromIntegral $ 2 * Vector.length cubeIndices)+        C.renderPassSetVertexBuffer+          0+          vertexBuffer+          0+          (fromIntegral $ sizeOf (undefined :: Vert) * Vector.length cubeVerts)+        C.renderPassDrawIndexed+          (WGPU.Range 0 (fromIntegral . Vector.length $ cubeIndices))+          0+          (WGPU.Range 0 1)+  C.queueSubmit' [commandBuffer]+  C.swapChainPresent++-- | Application initialization.+initApp :: App ()+initApp = do+  _vertexBuffer <-+    SimpleSDL.createBufferInit "vertex" (def {WGPU.bufVertex = True}) cubeVerts+  _indexBuffer <-+    SimpleSDL.createBufferInit "index" (def {WGPU.bufIndex = True}) cubeIndices++  let size = 256+      texels = createTexels (fromIntegral size)+  texture <-+    SimpleSDL.createTexture+      "texture"+      (WGPU.Extent3D size size 1)+      1+      1+      WGPU.TextureDimension2D+      WGPU.TextureFormatR8Uint+      (def {WGPU.texCopyDst = True, WGPU.texSampled = True})+  textureView <-+    WGPU.createView+      texture+      WGPU.TextureViewDescriptor+        { textureViewLabel = "Texture View",+          textureViewFormat = WGPU.TextureFormatR8Uint,+          textureViewDimension = WGPU.TextureViewDimension2D,+          textureViewBaseMipLevel = 0,+          textureViewMipLevelCount = 1,+          baseArrayLayer = 0,+          arrayLayerCount = 1,+          textureViewAspect = WGPU.TextureAspectAll+        }+  C.queueWriteTexture+    WGPU.ImageCopyTexture+      { texture = texture,+        mipLevel = 0,+        origin = WGPU.Origin3D 0 0 0,+        aspect = WGPU.TextureAspectAll+      }+    WGPU.TextureDataLayout+      { textureOffset = 0,+        bytesPerRow = size,+        rowsPerImage = 0+      }+    (WGPU.Extent3D size size 1)+    (Picture.imageData texels)++  shaderModule <- SimpleSDL.compileWGSL "shader" shaderSrc++  bindGroupLayout <-+    C.createBindGroupLayout+      WGPU.BindGroupLayoutDescriptor+        { bindGroupLayoutLabel = "Bind Group",+          layoutEntries =+            [ WGPU.BindGroupLayoutEntry+                { layoutBinding = 0,+                  visibility = def {WGPU.stageVertex = True},+                  bindGroupLayoutEntryType =+                    WGPU.BindingTypeBuffer+                      WGPU.BufferBindingLayout+                        { bindingBufferLayoutType = WGPU.Uniform,+                          hasDynamicOffset = False,+                          minBindingSize = WGPU.SJust (4 * 16)+                        }+                },+              WGPU.BindGroupLayoutEntry+                { layoutBinding = 1,+                  visibility = def {WGPU.stageFragment = True},+                  bindGroupLayoutEntryType =+                    WGPU.BindingTypeTexture+                      WGPU.TextureBindingLayout+                        { sampleType = WGPU.TextureSampleTypeUnsignedInt,+                          textureBindingViewDimension =+                            WGPU.TextureViewDimension2D,+                          multiSampled = False+                        }+                }+            ]+        }+  pipelineLayout <-+    C.createPipelineLayout+      (WGPU.PipelineLayoutDescriptor "Pipeline Layout" [bindGroupLayout])++  matrixBuf <-+    SimpleSDL.createBuffer+      "matrix"+      (fromIntegral (4 * 4 * sizeOf (undefined :: Float)))+      (def {WGPU.bufUniform = True, WGPU.bufCopyDst = True})+  updateViewTransformUniformBuffer++  _bindGroup <-+    SimpleSDL.createBindGroup+      "Bind Group"+      WGPU.BindGroupDescriptor+        { bindGroupLabel = "Bind Group",+          bindGroupLayout = bindGroupLayout,+          bindGroupEntries =+            [ -- tranformation matrix+              WGPU.BindGroupEntry+                { binding = 0,+                  resource =+                    WGPU.BindingResourceBuffer+                      (WGPU.BufferBinding matrixBuf 0 (4 * 16))+                },+              -- texture+              WGPU.BindGroupEntry+                { binding = 1,+                  resource = WGPU.BindingResourceTextureView textureView+                }+            ]+        }++  swapChainFormat <- C.getSwapChainPreferredFormat+  _renderPipeline <-+    SimpleSDL.createRenderPipeline+      "Render Pipeline"+      WGPU.RenderPipelineDescriptor+        { renderPipelineLabel = "Render Pipeline",+          layout = WGPU.SJust pipelineLayout,+          vertex =+            WGPU.VertexState+              shaderModule+              "vs_main"+              [ WGPU.VertexBufferLayout+                  (fromIntegral . sizeOf $ (undefined :: Vert))+                  WGPU.InputStepModeVertex+                  [ WGPU.VertexAttribute WGPU.VertexFormatFloat32x4 0 0,+                    WGPU.VertexAttribute WGPU.VertexFormatFloat32x2 (4 * 4) 1+                  ]+              ],+          fragment =+            WGPU.SJust $+              WGPU.FragmentState+                shaderModule+                "fs_main"+                [ WGPU.ColorTargetState+                    swapChainFormat+                    (WGPU.SJust (WGPU.BlendState def def))+                    WGPU.colorWriteMaskAll+                ],+          primitive = def {WGPU.cullMode = WGPU.CullModeBack},+          depthStencil = WGPU.SNothing,+          multisample = WGPU.MultisampleState 1 0xFFFFFFFF False -- TODO def+        }+  pure ()++-------------------------------------------------------------------------------+-- Shader source++shaderSrc :: WGPU.WGSL+shaderSrc =+  WGPU.WGSL+    [SQQ.s|+struct VertexOutput {+  [[location(0)]] tex_coord: vec2<f32>;+  [[builtin(position)]] position: vec4<f32>;+};++[[block]]+struct Locals {+  transform: mat4x4<f32>;+};+[[group(0), binding(0)]]+var r_locals: Locals;++[[stage(vertex)]]+fn vs_main(+  [[location(0)]] position: vec4<f32>,+  [[location(1)]] tex_coord: vec2<f32>+) -> VertexOutput {+  var out: VertexOutput;+  out.tex_coord = tex_coord;+  out.position = r_locals.transform * position;+  return out;+}++[[group(0), binding(1)]]+var r_color: texture_2d<u32>;++[[stage(fragment)]]+fn fs_main(in: VertexOutput) -> [[location(0)]] vec4<f32> {+  let tex = textureLoad(r_color, vec2<i32>(in.tex_coord * 256.0), 0);+  let v = f32(tex.x) / 255.0;+  return vec4<f32>(+    1.0 - (v * 5.0),+    1.0 - (v * 15.0),+    1.0 - (v * 50.0),+    1.0+  );+}++[[stage(fragment)]]+fn fs_wire() -> [[location(0)]] vec4<f32> {+  return vec4<f32>(0.0, 0.5, 0.0, 0.5);+}+|]++-------------------------------------------------------------------------------+-- Texture / Texels++-- | Quick Mandelbrot texture.+createTexels :: Int -> Image Pixel8+createTexels size = Picture.generateImage f size size+  where+    f :: Int -> Int -> Word8+    f px py =+      let cx, cy :: Float+          cx = 3.0 * fromIntegral px / fromIntegral (size - 1) - 2.0+          cy = 2.0 * fromIntegral py / fromIntegral (size - 1) - 1.0++          go :: Word8 -> Float -> Float -> Word8+          go count x y =+            let x2, y2, esc :: Float+                x2 = x * x+                y2 = y * y+                esc = x2 + y2+             in if (count < 0xFF) && (esc < 4.0)+                  then+                    let x', y' :: Float+                        x' = x2 - y2 + cx+                        y' = 2.0 * x * y + cy+                     in go (count + 1) x' y'+                  else count+       in go 0 cx cy++-------------------------------------------------------------------------------+-- Cube definition++cubeVerts :: Vector Vert+cubeVerts =+  let v :: Float -> Float -> Float -> Float -> Float -> Vert+      v x y z s t = Vert (V4 x y z 1.0) (V2 s t)+   in [ -- top (0, 0, 1)+        v -1 -1 1 0 0,+        v 1 -1 1 1 0,+        v 1 1 1 1 1,+        v -1 1 1 0 1,+        -- bottom (0, 0, -1)+        v -1 1 -1 1 0,+        v 1 1 -1 0 0,+        v 1 -1 -1 0 1,+        v -1 -1 -1 1 1,+        -- right (1, 0, 0)+        v 1 -1 -1 0 0,+        v 1 1 -1 1 0,+        v 1 1 1 1 1,+        v 1 -1 1 0 1,+        -- left (-1, 0, 0)+        v -1 -1 1 1 0,+        v -1 1 1 0 0,+        v -1 1 -1 0 1,+        v -1 -1 -1 1 1,+        -- front (0, 1, 0)+        v 1 1 -1 1 0,+        v -1 1 -1 0 0,+        v -1 1 1 0 1,+        v 1 1 1 1 1,+        -- back (0, -1, 0)+        v 1 -1 1 0 0,+        v -1 -1 1 1 0,+        v -1 -1 -1 1 1,+        v 1 -1 -1 0 1+      ]++cubeIndices :: Vector Word16+cubeIndices =+  mconcat+    [ [0, 1, 2, 2, 3, 0], -- top+      [4, 5, 6, 6, 7, 4], -- bottom+      [8, 9, 10, 10, 11, 8], -- right+      [12, 13, 14, 14, 15, 12], -- left+      [16, 17, 18, 18, 19, 16], -- front+      [20, 21, 22, 22, 23, 20] -- back+    ]++-------------------------------------------------------------------------------+-- Vertex type++data Vert = Vert+  { -- | Position of the vertex.+    vertPos :: V4 Float,+    -- | Texture coordinate of the vertex.+    vertTexCoord :: V2 Float+  }+  deriving (Eq, Show, Generic)++-- | Provides a 'Generic'-derived @Storable@ instance for 'Vert'.+instance GStorable Vert++-------------------------------------------------------------------------------+-- Application Monad++runApp ::+  Env ->+  App a ->+  ResourceT IO a+runApp env a = runReaderT (unApp a) env++-- | Application monad data type.+newtype App a = App {unApp :: ReaderT Env (ResourceT IO) a}+  deriving newtype+    ( Functor,+      Applicative,+      Monad,+      MonadThrow,+      MonadIO,+      MonadResource,+      MonadReader Env+    )++data Env = Env+  { resources :: !SimpleSDL.Resources,+    buffers :: !SimpleSDL.Buffers,+    textures :: !SimpleSDL.Textures,+    shaders :: !SimpleSDL.Shaders,+    bindGroups :: !SimpleSDL.BindGroups,+    renderPipelines :: !SimpleSDL.RenderPipelines,+    swapChainState :: !SimpleSDL.SwapChainState,+    viewTransform :: !(MVar ViewTransform)+  }++instance Has SimpleSDL.Resources Env where+  hasLens = lens resources (\s x -> s {resources = x})++instance Has SimpleSDL.Buffers Env where+  hasLens = lens buffers (\s x -> s {buffers = x})++instance Has SimpleSDL.Textures Env where+  hasLens = lens textures (\s x -> s {textures = x})++instance Has SimpleSDL.Shaders Env where+  hasLens = lens shaders (\s x -> s {shaders = x})++instance Has SimpleSDL.BindGroups Env where+  hasLens = lens bindGroups (\s x -> s {bindGroups = x})++instance Has SimpleSDL.RenderPipelines Env where+  hasLens = lens renderPipelines (\s x -> s {renderPipelines = x})++instance Has SimpleSDL.SwapChainState Env where+  hasLens = lens swapChainState (\s x -> s {swapChainState = x})++instance Has (MVar ViewTransform) Env where+  hasLens = lens viewTransform (\s x -> s {viewTransform = x})++envResourcesL :: Lens' Env SimpleSDL.Resources+envResourcesL = hasLens++instance Has WGPU.Instance Env where hasLens = envResourcesL . hasLens++instance Has SDL.Window Env where hasLens = envResourcesL . hasLens++instance Has WGPU.Surface Env where hasLens = envResourcesL . hasLens++instance Has WGPU.Adapter Env where hasLens = envResourcesL . hasLens++instance Has WGPU.Device Env where hasLens = envResourcesL . hasLens++instance Has WGPU.Queue Env where hasLens = envResourcesL . hasLens++-------------------------------------------------------------------------------+-- Viewing Transformation Matrix++updateViewTransformUniformBuffer ::+  ( Has (MVar ViewTransform) r,+    Has SimpleSDL.Buffers r,+    Has SDL.Window r,+    Has WGPU.Queue r,+    MonadReader r m,+    MonadThrow m,+    MonadIO m+  ) =>+  m ()+updateViewTransformUniformBuffer = do+  (w, h) <- SimpleSDL.getDrawableSize+  let aspect :: Float+      aspect = fromIntegral w / fromIntegral h+  matrix <- flip generateMatrix aspect <$> getViewTransform+  matrixBuf <- SimpleSDL.getBuffer "matrix"+  C.queueWriteBuffer matrixBuf matrix++getViewTransform ::+  (Has (MVar ViewTransform) r, MonadReader r m, MonadIO m) =>+  m ViewTransform+getViewTransform = asks getter >>= liftIO . flip withMVar pure++modifyViewTransform ::+  (Has (MVar ViewTransform) r, MonadReader r m, MonadIO m) =>+  (ViewTransform -> ViewTransform) ->+  m ()+modifyViewTransform f = asks getter >>= liftIO . flip modifyMVar_ (pure . f)++data ViewTransform = ViewTransform+  { vtYRot :: !Float,+    vtXRot :: !Float,+    vtZTrans :: !Float+  }+  deriving (Eq, Show)++zeroViewTransform :: MonadIO m => m (MVar ViewTransform)+zeroViewTransform =+  liftIO . newMVar $+    ViewTransform+      { vtYRot = pi / 8,+        vtXRot = pi / 12,+        vtZTrans = 5.0+      }++generateMatrix :: ViewTransform -> Float -> M44 Float+generateMatrix ViewTransform {..} aspect =+  let rotAxisAngle :: V3 Float -> Float -> M44 Float+      rotAxisAngle axis angle = Linear.m33_to_m44 . Linear.fromQuaternion $ quat+        where+          quat = Linear.axisAngle axis angle++      proj = Linear.perspective (pi / 4.0) aspect 1.0 10.0+      rotY = rotAxisAngle (V3 0 1 0) vtYRot+      rotX = rotAxisAngle (V3 1 0 0) vtXRot+      transZ = set Linear.translation (V3 0 0 (-vtZTrans)) Linear.identity+      view = transZ !*! rotX !*! rotY+   in Linear.transpose $ openGLToWGPU !*! proj !*! view++openGLToWGPU :: M44 Float+openGLToWGPU =+  V4+    (V4 1.0 0.0 0.0 0.0)+    (V4 0.0 1.0 0.0 0.0)+    (V4 0.0 0.0 0.5 0.5)+    (V4 0.0 0.0 0.0 1.0)++-------------------------------------------------------------------------------+-- SDL Event Helpers++mKeyEvent :: SDL.Event -> Maybe SDL.KeyboardEventData+mKeyEvent event =+  case SDL.eventPayload event of+    SDL.KeyboardEvent keyboardEventData -> Just keyboardEventData+    _ -> Nothing++mKeyPressed :: SDL.KeyboardEventData -> Maybe SDL.Keysym+mKeyPressed ed =+  case SDL.keyboardEventKeyMotion ed of+    SDL.Pressed -> Just (SDL.keyboardEventKeysym ed)+    _ -> Nothing++eventIsQPress :: SDL.Event -> Bool+eventIsQPress event =+  fromMaybe False $+    mKeyEvent event >>= mKeyPressed >>= \keySym -> do+      if SDL.keysymKeycode keySym == SDL.KeycodeQ+        then Just True+        else Nothing++eventIsWindowClose :: SDL.Event -> Bool+eventIsWindowClose event =+  case SDL.eventPayload event of+    SDL.WindowClosedEvent _ -> True+    _ -> False++mMouseMotionEvent :: SDL.Event -> Maybe SDL.MouseMotionEventData+mMouseMotionEvent event =+  case SDL.eventPayload event of+    SDL.MouseMotionEvent mouseMotionEventData -> Just mouseMotionEventData+    _ -> Nothing++-------------------------------------------------------------------------------+-- Miscellaneous++-- | Print text to the console.+putStrLn :: MonadIO m => Text -> m ()+putStrLn = liftIO . TextIO.putStrLn

@@ -175,10 +175,10 @@           surface           WGPU.SwapChainDescriptor             { swapChainLabel = "SwapChain",-              usage = WGPU.TextureUsageRenderAttachment,+              usage = def {WGPU.texRenderAttachment = True},               swapChainFormat = textureFormat,-              width = fromIntegral . fst $ curSz,-              height = fromIntegral . snd $ curSz,+              swapChainWidth = fromIntegral . fst $ curSz,+              swapChainHeight = fromIntegral . snd $ curSz,               presentMode = WGPU.PresentModeFifo             }       _ <- tryTakeMVar swapChainMVar

@@ -28,8 +28,6 @@  main :: IO () main = runResourceT $ do-  putStrLn "Start"-   -- Parameters for the static resource initialization   let params =         SimpleSDL.Params@@ -79,33 +77,32 @@  -- | The rendering action. render :: App ()-render = do-  SimpleSDL.withSwapChain $ do-    nextTexture <- C.getSwapChainCurrentTextureView-    renderPipeline <- SimpleSDL.getRenderPipeline "renderPipeline"-    commandBuffer <--      C.buildCommandBuffer "Command Encoder" "Command Buffer" $ do-        let renderPassDescriptor =-              WGPU.RenderPassDescriptor-                { renderPassLabel = "Render Pass",-                  colorAttachments =-                    [ WGPU.RenderPassColorAttachment-                        { colorView = nextTexture,-                          resolveTarget = WGPU.SNothing,-                          operations =-                            WGPU.Operations-                              { load = WGPU.LoadOpClear (WGPU.Color 0 0 0 1),-                                store = WGPU.StoreOpStore-                              }-                        }-                    ],-                  depthStencilAttachment = WGPU.SNothing-                }-        C.buildRenderPass renderPassDescriptor $ do-          C.renderPassSetPipeline renderPipeline-          C.renderPassDraw (WGPU.Range 0 3) (WGPU.Range 0 1)-    C.queueSubmit' [commandBuffer]-    C.swapChainPresent+render = SimpleSDL.withSwapChain $ do+  nextTexture <- C.getSwapChainCurrentTextureView+  renderPipeline <- SimpleSDL.getRenderPipeline "renderPipeline"+  commandBuffer <-+    C.buildCommandBuffer "Command Encoder" "Command Buffer" $ do+      let renderPassDescriptor =+            WGPU.RenderPassDescriptor+              { renderPassLabel = "Render Pass",+                colorAttachments =+                  [ WGPU.RenderPassColorAttachment+                      { colorView = nextTexture,+                        resolveTarget = WGPU.SNothing,+                        operations =+                          WGPU.Operations+                            { load = WGPU.LoadOpClear (WGPU.Color 0 0 0 1),+                              store = WGPU.StoreOpStore+                            }+                      }+                  ],+                depthStencilAttachment = WGPU.SNothing+              }+      C.buildRenderPass renderPassDescriptor $ do+        C.renderPassSetPipeline renderPipeline+        C.renderPassDraw (WGPU.Range 0 3) (WGPU.Range 0 1)+  C.queueSubmit' [commandBuffer]+  C.swapChainPresent  -- | Application initialization initApp :: App ()

@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -7,6 +8,9 @@ -- Description : Resource Binding module WGPU.Internal.Binding   ( -- * Types+    BindGroup (..),+    BindGroupDescriptor (..),+    BindGroupEntry (..),     BindGroupLayout (..),     BindGroupLayoutDescriptor (..),     BindGroupLayoutEntry (..),@@ -20,19 +24,25 @@     StorageTextureAccess (..),     TextureSampleType (..),     BufferBindingType (..),+    BindingResource (..),+    BufferBinding (..),      -- * Functions+    createBindGroup,     createBindGroupLayout,   ) where  import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bits ((.|.))+import Data.Default (Default, def) import Data.Text (Text) import Data.Vector (Vector)+import qualified Data.Vector as Vector import Data.Word (Word32, Word64) import Foreign (nullPtr) import Foreign.C (CBool (CBool))+import WGPU.Internal.Buffer (Buffer, wgpuBuffer) import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) import WGPU.Internal.Instance (wgpuHsInstance) import WGPU.Internal.Memory@@ -44,7 +54,8 @@     showWithPtr,   ) import WGPU.Internal.SMaybe (SMaybe, fromSMaybe)-import WGPU.Internal.Texture (TextureFormat, TextureViewDimension)+import WGPU.Internal.Sampler (Sampler, wgpuSampler)+import WGPU.Internal.Texture (TextureFormat, TextureView, TextureViewDimension, wgpuTextureView) import WGPU.Raw.Generated.Enum.WGPUBufferBindingType (WGPUBufferBindingType) import qualified WGPU.Raw.Generated.Enum.WGPUBufferBindingType as WGPUBufferBindingType import qualified WGPU.Raw.Generated.Enum.WGPUSamplerBindingType as WGPUSamplerBindingType@@ -56,6 +67,10 @@ import qualified WGPU.Raw.Generated.Enum.WGPUTextureSampleType as WGPUTextureSampleType import qualified WGPU.Raw.Generated.Enum.WGPUTextureViewDimension as WGPUTextureViewDimension import qualified WGPU.Raw.Generated.Fun as RawFun+import WGPU.Raw.Generated.Struct.WGPUBindGroupDescriptor (WGPUBindGroupDescriptor)+import qualified WGPU.Raw.Generated.Struct.WGPUBindGroupDescriptor as WGPUBindGroupDescriptor+import WGPU.Raw.Generated.Struct.WGPUBindGroupEntry (WGPUBindGroupEntry)+import qualified WGPU.Raw.Generated.Struct.WGPUBindGroupEntry as WGPUBindGroupEntry import WGPU.Raw.Generated.Struct.WGPUBindGroupLayoutDescriptor (WGPUBindGroupLayoutDescriptor) import qualified WGPU.Raw.Generated.Struct.WGPUBindGroupLayoutDescriptor as WGPUBindGroupLayoutDescriptor import WGPU.Raw.Generated.Struct.WGPUBindGroupLayoutEntry (WGPUBindGroupLayoutEntry)@@ -69,12 +84,38 @@ import WGPU.Raw.Generated.Struct.WGPUTextureBindingLayout (WGPUTextureBindingLayout) import qualified WGPU.Raw.Generated.Struct.WGPUTextureBindingLayout as WGPUTextureBindingLayout import WGPU.Raw.Types-  ( WGPUBindGroupLayout (WGPUBindGroupLayout),+  ( WGPUBindGroup (WGPUBindGroup),+    WGPUBindGroupLayout (WGPUBindGroupLayout),+    WGPUBuffer (WGPUBuffer),+    WGPUSampler (WGPUSampler),     WGPUShaderStageFlags,+    WGPUTextureView (WGPUTextureView),   )  ------------------------------------------------------------------------------- +-- | Binding group.+--+-- Represents the set of resources bound to the bindings described by a+-- 'BindGroupLayout'.+newtype BindGroup = BindGroup {wgpuBindGroup :: WGPUBindGroup}++instance Show BindGroup where+  show b =+    let BindGroup (WGPUBindGroup ptr) = b+     in showWithPtr "BindGroup" ptr++instance Eq BindGroup where+  (==) b1 b2 =+    let BindGroup (WGPUBindGroup b1_ptr) = b1+        BindGroup (WGPUBindGroup b2_ptr) = b2+     in b1_ptr == b2_ptr++instance ToRaw BindGroup WGPUBindGroup where+  raw = pure . wgpuBindGroup++-------------------------------------------------------------------------------+ -- | Handle to a binding group layout. -- -- A @BindGroupLayout@ is a handle to the GPU-side layout of a binding group.@@ -96,42 +137,112 @@  ------------------------------------------------------------------------------- --- | Creates a 'BindGroupLayout'.-createBindGroupLayout ::-  MonadIO m =>-  -- | The device for which the bind group layout will be created.-  Device ->-  -- | Description of the bind group layout.-  BindGroupLayoutDescriptor ->-  -- | MonadIO action that creates a bind group layout.-  m BindGroupLayout-createBindGroupLayout device ld = liftIO . evalContT $ do-  let inst = deviceInst device+-- | Describes a 'BindGroup'.+data BindGroupDescriptor = BindGroupDescriptor+  { bindGroupLabel :: !Text,+    bindGroupLayout :: !BindGroupLayout,+    bindGroupEntries :: !(Vector BindGroupEntry)+  }+  deriving (Eq, Show) -  bindGroupLayoutDescriptor_ptr <- rawPtr ld-  rawBindGroupLayout <--    RawFun.wgpuDeviceCreateBindGroupLayout-      (wgpuHsInstance inst)-      (wgpuDevice device)-      bindGroupLayoutDescriptor_ptr-  pure (BindGroupLayout rawBindGroupLayout)+instance ToRaw BindGroupDescriptor WGPUBindGroupDescriptor where+  raw BindGroupDescriptor {..} = do+    label_ptr <- rawPtr bindGroupLabel+    n_layout <- raw bindGroupLayout+    let n_entryCount = fromIntegral . Vector.length $ bindGroupEntries+    entries_ptr <- rawArrayPtr bindGroupEntries+    pure+      WGPUBindGroupDescriptor.WGPUBindGroupDescriptor+        { nextInChain = nullPtr,+          label = label_ptr,+          layout = n_layout,+          entryCount = n_entryCount,+          entries = entries_ptr+        }  ------------------------------------------------------------------------------- +-- | Entry in a bind group.+data BindGroupEntry = BindGroupEntry+  { binding :: !Binding,+    resource :: !BindingResource+  }+  deriving (Eq, Show)++instance ToRaw BindGroupEntry WGPUBindGroupEntry where+  raw BindGroupEntry {..} = pure $+    case resource of+      BindingResourceBuffer bufferBinding ->+        bufferBindingToRaw binding bufferBinding+      BindingResourceSampler sampler ->+        samplerBindingToRaw binding sampler+      BindingResourceTextureView textureView ->+        textureViewBindingToRaw binding textureView+    where+      bufferBindingToRaw :: Binding -> BufferBinding -> WGPUBindGroupEntry+      bufferBindingToRaw bnding BufferBinding {..} =+        WGPUBindGroupEntry.WGPUBindGroupEntry+          { binding = unBinding bnding,+            buffer = wgpuBuffer bindingBuffer,+            offset = bindingBufferOffset,+            size = bindingBufferSize,+            sampler = WGPUSampler nullPtr,+            textureView = WGPUTextureView nullPtr+          }++      samplerBindingToRaw :: Binding -> Sampler -> WGPUBindGroupEntry+      samplerBindingToRaw bnding sampler =+        WGPUBindGroupEntry.WGPUBindGroupEntry+          { binding = unBinding bnding,+            buffer = WGPUBuffer nullPtr,+            offset = 0,+            size = 0,+            sampler = wgpuSampler sampler,+            textureView = WGPUTextureView nullPtr+          }++      textureViewBindingToRaw :: Binding -> TextureView -> WGPUBindGroupEntry+      textureViewBindingToRaw bnding textureView =+        WGPUBindGroupEntry.WGPUBindGroupEntry+          { binding = unBinding bnding,+            buffer = WGPUBuffer nullPtr,+            offset = 0,+            size = 0,+            sampler = WGPUSampler nullPtr,+            textureView = wgpuTextureView textureView+          }++-- | Resource that can be bound to a pipeline.+data BindingResource+  = BindingResourceBuffer !BufferBinding+  | BindingResourceSampler !Sampler+  | BindingResourceTextureView !TextureView+  deriving (Eq, Show)++-- | A buffer binding.+data BufferBinding = BufferBinding+  { bindingBuffer :: !Buffer,+    bindingBufferOffset :: !Word64,+    bindingBufferSize :: !Word64+  }+  deriving (Eq, Show)++-------------------------------------------------------------------------------+ -- | Describes a 'BindGroupLayout'. data BindGroupLayoutDescriptor = BindGroupLayoutDescriptor   { -- | Debug label of the bind group layout.-    bindGroupLabel :: !Text,+    bindGroupLayoutLabel :: !Text,     -- | Sequence of entries in this bind group layout.-    entries :: !(Vector BindGroupLayoutEntry)+    layoutEntries :: !(Vector BindGroupLayoutEntry)   }   deriving (Eq, Show)  instance ToRaw BindGroupLayoutDescriptor WGPUBindGroupLayoutDescriptor where   raw BindGroupLayoutDescriptor {..} = do-    label_ptr <- rawPtr bindGroupLabel-    let n_entryCount = fromIntegral . length $ entries-    entries_ptr <- rawArrayPtr entries+    label_ptr <- rawPtr bindGroupLayoutLabel+    let n_entryCount = fromIntegral . length $ layoutEntries+    entries_ptr <- rawArrayPtr layoutEntries     pure       WGPUBindGroupLayoutDescriptor.WGPUBindGroupLayoutDescriptor         { nextInChain = nullPtr,@@ -146,7 +257,7 @@ data BindGroupLayoutEntry = BindGroupLayoutEntry   { -- | Binding index. Must match a shader index, and be unique inside a     --   bind group layout.-    binding :: !Binding,+    layoutBinding :: !Binding,     -- | Which shader stages can see this binding.     visibility :: !ShaderStage,     -- | Type of the binding.@@ -156,7 +267,7 @@  instance ToRaw BindGroupLayoutEntry WGPUBindGroupLayoutEntry where   raw BindGroupLayoutEntry {..} = do-    n_binding <- raw binding+    n_binding <- raw layoutBinding     n_visibility <- raw visibility     (n_buffer, n_sampler, n_texture, n_storageTexture) <-       case bindGroupLayoutEntryType of@@ -223,7 +334,7 @@ -- -- This must match a shader index, and be unique inside a binding group -- layout.-newtype Binding = Binding {unBinding :: Word32} deriving (Eq, Show)+newtype Binding = Binding {unBinding :: Word32} deriving (Eq, Num, Show)  instance ToRaw Binding Word32 where   raw = pure . unBinding@@ -248,6 +359,14 @@         .|. (if stageFragment then WGPUShaderStage.Fragment else 0)         .|. (if stageCompute then WGPUShaderStage.Compute else 0) +instance Default ShaderStage where+  def =+    ShaderStage+      { stageVertex = False,+        stageFragment = False,+        stageCompute = False+      }+ -------------------------------------------------------------------------------  -- | Specifies type of a binding.@@ -320,7 +439,7 @@   { -- | Sample type of the texture binding.     sampleType :: !TextureSampleType,     -- | Dimension of the texture view that is going to be sampled.-    textureViewDimension :: !TextureViewDimension,+    textureBindingViewDimension :: !TextureViewDimension,     -- | True if the texture has a sample count greater than 1.     multiSampled :: !Bool   }@@ -329,7 +448,7 @@ instance ToRaw TextureBindingLayout WGPUTextureBindingLayout where   raw TextureBindingLayout {..} = do     n_sampleType <- raw sampleType-    n_viewDimension <- raw textureViewDimension+    n_viewDimension <- raw textureBindingViewDimension     n_multisampled <- raw multiSampled     pure       WGPUTextureBindingLayout.WGPUTextureBindingLayout@@ -417,3 +536,42 @@         Uniform -> WGPUBufferBindingType.Uniform         Storage False -> WGPUBufferBindingType.Storage         Storage True -> WGPUBufferBindingType.ReadOnlyStorage++-------------------------------------------------------------------------------++-- | Create a bind group.+createBindGroup ::+  MonadIO m =>+  -- | Device for which to create the bind group.+  Device ->+  -- | Description of the bind group.+  BindGroupDescriptor ->+  -- | Action to create the bind group.+  m BindGroup+createBindGroup device bindGroupDescriptor = liftIO . evalContT $ do+  let inst = deviceInst device+  bindGroupDescriptor_ptr <- rawPtr bindGroupDescriptor+  BindGroup+    <$> RawFun.wgpuDeviceCreateBindGroup+      (wgpuHsInstance inst)+      (wgpuDevice device)+      bindGroupDescriptor_ptr++-- | Creates a 'BindGroupLayout'.+createBindGroupLayout ::+  MonadIO m =>+  -- | The device for which the bind group layout will be created.+  Device ->+  -- | Description of the bind group layout.+  BindGroupLayoutDescriptor ->+  -- | MonadIO action that creates a bind group layout.+  m BindGroupLayout+createBindGroupLayout device ld = liftIO . evalContT $ do+  let inst = deviceInst device+  bindGroupLayoutDescriptor_ptr <- rawPtr ld+  rawBindGroupLayout <-+    RawFun.wgpuDeviceCreateBindGroupLayout+      (wgpuHsInstance inst)+      (wgpuDevice device)+      bindGroupLayoutDescriptor_ptr+  pure (BindGroupLayout rawBindGroupLayout)

@@ -0,0 +1,232 @@+{-# 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+  { bufferInst :: !Instance,+    bufferDevice :: !Device,+    wgpuBuffer :: !WGPUBuffer+  }++instance Show Buffer where+  show b =+    let Buffer _ _ (WGPUBuffer ptr) = b+     in showWithPtr "Buffer" ptr++instance Eq Buffer where+  (==) b1 b2 =+    let Buffer _ _ (WGPUBuffer b1_ptr) = b1+        Buffer _ _ (WGPUBuffer b2_ptr) = b2+     in b1_ptr == b2_ptr++instance ToRaw Buffer WGPUBuffer where+  raw = pure . wgpuBuffer++-------------------------------------------------------------------------------++-- | Different ways you can use a buffer.+data BufferUsage = BufferUsage+  { -- | Allow a buffer to be mapped for reading.+    bufMapRead :: !Bool,+    -- | Allow a buffer to be mapped for writing.+    bufMapWrite :: !Bool,+    -- | Allow a buffer to be a source buffer for a copy operation.+    bufCopySrc :: !Bool,+    -- | Allow a buffer to be a destination buffer for a copy operation.+    bufCopyDst :: !Bool,+    -- | Allow a buffer to be the index buffer in a draw operation.+    bufIndex :: !Bool,+    -- | Allow a buffer to be the vertex buffer in a draw operation.+    bufVertex :: !Bool,+    -- | Allow a buffer to be a uniform binding in a bind group.+    bufUniform :: !Bool,+    -- | Allow a buffer to be a storage binding in a bind group.+    bufStorage :: !Bool,+    -- | Allow a buffer to be the indirect buffer in an indirect draw call.+    bufIndirect :: !Bool+  }+  deriving (Eq, Show)++instance ToRaw BufferUsage Word32 where+  raw BufferUsage {..} =+    pure $+      (if bufMapRead then WGPUBufferUsage.MapRead else 0)+        .|. (if bufMapWrite then WGPUBufferUsage.MapWrite else 0)+        .|. (if bufCopySrc then WGPUBufferUsage.CopySrc else 0)+        .|. (if bufCopyDst then WGPUBufferUsage.CopyDst else 0)+        .|. (if bufIndex then WGPUBufferUsage.Index else 0)+        .|. (if bufVertex then WGPUBufferUsage.Vertex else 0)+        .|. (if bufUniform then WGPUBufferUsage.Uniform else 0)+        .|. (if bufStorage then WGPUBufferUsage.Storage else 0)+        .|. (if bufIndirect then WGPUBufferUsage.Indirect else 0)++instance Default BufferUsage where+  def =+    BufferUsage+      { bufMapRead = False,+        bufMapWrite = False,+        bufCopySrc = False,+        bufCopyDst = False,+        bufIndex = False,+        bufVertex = False,+        bufUniform = False,+        bufStorage = False,+        bufIndirect = False+      }++-------------------------------------------------------------------------------++-- | Describes a 'Buffer'.+data BufferDescriptor = BufferDescriptor+  { -- | Debugging label for the buffer.+    bufferLabel :: !Text,+    -- | Size of the buffer, in bytes.+    bufferSize :: !ByteSize,+    -- | Usage(s) of the buffer.+    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.+    mappedAtCreation :: Bool+  }+  deriving (Eq, Show)++instance ToRaw BufferDescriptor WGPUBufferDescriptor where+  raw BufferDescriptor {..} = do+    label_ptr <- rawPtr bufferLabel+    n_usage <- raw bufferUsage+    n_mappedAtCreation <- raw mappedAtCreation+    pure+      WGPUBufferDescriptor.WGPUBufferDescriptor+        { nextInChain = nullPtr,+          label = label_ptr,+          usage = n_usage,+          size = unByteSize bufferSize,+          mappedAtCreation = n_mappedAtCreation+        }++-------------------------------------------------------------------------------++-- | Create a 'Buffer'.+createBuffer :: MonadIO m => Device -> BufferDescriptor -> m Buffer+createBuffer device bufferDescriptor = liftIO . evalContT $ do+  let inst = deviceInst device+  bufferDescriptor_ptr <- rawPtr bufferDescriptor+  Buffer inst device+    <$> RawFun.wgpuDeviceCreateBuffer+      (wgpuHsInstance inst)+      (wgpuDevice device)+      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 label bufferUsage content = liftIO . evalContT $ do+  -- Convert the foreign pointer to a raw pointer.+  contentPtr <- ContT $ withReadablePtr content+  let contentSz :: ByteSize+      contentSz = readableMemoryBufferSize content++  -- Create the buffer, marking it as "mappedAtCreation", so that its memory+  -- is mapped to host memory.+  let bufferDescriptor :: BufferDescriptor+      bufferDescriptor =+        BufferDescriptor+          { bufferLabel = label,+            bufferSize = contentSz,+            bufferUsage = bufferUsage,+            mappedAtCreation = True+          }+  buffer <- createBuffer device bufferDescriptor++  -- Find the pointer to the mapped region of the buffer.+  bufferPtr <- bufferGetMappedRange buffer 0 contentSz++  -- Copy the supplied content to the buffer+  liftIO $ copyBytes bufferPtr (castPtr contentPtr) (fromIntegral contentSz)++  -- Un-map the buffer and return it+  bufferUnmap buffer+  pure 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 byteOffset byteLength = do+  let inst = bufferInst buffer+  WGPU.wgpuBufferGetMappedRange+    (wgpuHsInstance inst)+    (wgpuBuffer buffer)+    (fromIntegral byteOffset)+    (toCSize byteLength)+{-# INLINEABLE bufferGetMappedRange #-}++-- | Unmap a buffer that was previously mapped into host memory.+bufferUnmap :: MonadIO m => Buffer -> m ()+bufferUnmap buffer = do+  let inst = bufferInst buffer+  WGPU.wgpuBufferUnmap+    (wgpuHsInstance inst)+    (wgpuBuffer buffer)+{-# INLINEABLE bufferUnmap #-}

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}@@ -64,10 +65,15 @@     FromRaw (fromRaw),     ToRawPtr (rawPtr),     FromRawPtr (fromRawPtr),+    ReadableMemoryBuffer (withReadablePtr, readableMemoryBufferSize), +    -- * Types+    ByteSize (ByteSize, unByteSize),+     -- * Functions      -- ** Internal+    toCSize,     evalContT,     allocaC,     rawArrayPtr,@@ -93,11 +99,13 @@ import qualified Data.Text as Text import Data.Vector.Generic (Vector) import qualified Data.Vector.Generic as Vector-import Data.Word (Word8)+import qualified Data.Vector.Storable as SVector+import Data.Word (Word32, Word8) import Foreign   ( FunPtr,     Ptr,     Storable,+    Word64,     advancePtr,     alignment,     alloca,@@ -108,7 +116,7 @@     sizeOf,   ) import qualified Foreign (fillBytes, freeHaskellFunPtr, poke)-import Foreign.C (CBool, CChar, peekCString, withCString)+import Foreign.C (CBool, CChar, CSize (CSize), peekCString, withCString)  ------------------------------------------------------------------------------- -- Type Classes@@ -183,6 +191,9 @@   raw x = pure (if x then 1 else 0)   {-# INLINE raw #-} +instance ToRaw Word32 Word32 where+  raw = pure+ instance ToRawPtr Text CChar where   rawPtr = withCStringC . Text.unpack   {-# INLINEABLE rawPtr #-}@@ -261,6 +272,62 @@  evalContT :: Monad m => ContT a m a -> m a evalContT cont = runContT cont pure++-------------------------------------------------------------------------------++-- | Size, in number of bytes.+newtype ByteSize = ByteSize {unByteSize :: Word64}+  deriving (Eq, Ord, Show, Enum, Real, Integral, Num)++instance ToRaw ByteSize CSize where+  raw = pure . toCSize++toCSize :: ByteSize -> CSize+toCSize = CSize . unByteSize++-------------------------------------------------------------------------------++-- | Region of memory that is read-only for WGPU.+--+-- A 'ReadableMemoryBuffer' represents a contiguous region of memory that WGPU+-- may read from, but not write to. It has a pointer to the start of the region,+-- and a size in bytes.+--+-- When the caller of WGPU supplies a 'ReadableMemoryBuffer', it commits to+-- keeping the buffer alive for the period of the call to `withReadablePtr`.+-- WGPU commits to not mutating the data.+--+-- If it is necessary to refer to slices within a buffer, it is up to the type+-- @a@ to store those offsets and account for them in the two functions required+-- by the API. (For example, 'SVector.Vector' does this.)+class ReadableMemoryBuffer a where+  -- | Perform an action with the memory buffer.+  withReadablePtr :: a -> (Ptr () -> IO b) -> IO b++  -- | The size of the buffer, in number of bytes.+  readableMemoryBufferSize :: a -> ByteSize++instance {-# OVERLAPPABLE #-} Storable a => ReadableMemoryBuffer a where+  withReadablePtr x action =+    alloca $ \ptr -> do+      poke ptr x+      result <- action (castPtr ptr)+      zeroMemory ptr (sizeOf (undefined :: a))+      pure result+  {-# INLINEABLE withReadablePtr #-}+  readableMemoryBufferSize x = ByteSize (fromIntegral (sizeOf x))+  {-# INLINEABLE readableMemoryBufferSize #-}++instance+  {-# OVERLAPPABLE #-}+  Storable a =>+  ReadableMemoryBuffer (SVector.Vector a)+  where+  withReadablePtr vec action = SVector.unsafeWith vec (action . castPtr)+  {-# INLINEABLE withReadablePtr #-}+  readableMemoryBufferSize vec =+    ByteSize . fromIntegral $ sizeOf (undefined :: a) * SVector.length vec+  {-# INLINEABLE readableMemoryBufferSize #-}  ------------------------------------------------------------------------------- 

@@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}  -- | -- Module      : WGPU.Internal.Multipurpose@@ -8,16 +9,62 @@ -- somewhat generic and are used in more than one part of the API. module WGPU.Internal.Multipurpose   ( -- * Types+    Texture (..),     CompareFunction (..),+    Origin3D (..),+    Extent3D (..),+    TextureAspect (..),+    ImageCopyTexture (..),+    TextureDataLayout (..),+    IndexFormat (..),   ) where -import WGPU.Internal.Memory (ToRaw, raw)+import Data.Word (Word32)+import Foreign (Word64, nullPtr)+import WGPU.Internal.Instance (Instance)+import WGPU.Internal.Memory (ToRaw, raw, showWithPtr) import WGPU.Raw.Generated.Enum.WGPUCompareFunction (WGPUCompareFunction) import qualified WGPU.Raw.Generated.Enum.WGPUCompareFunction as WGPUCompareFunction+import WGPU.Raw.Generated.Enum.WGPUIndexFormat (WGPUIndexFormat)+import qualified WGPU.Raw.Generated.Enum.WGPUIndexFormat as WGPUIndexFormat+import WGPU.Raw.Generated.Enum.WGPUTextureAspect (WGPUTextureAspect)+import qualified WGPU.Raw.Generated.Enum.WGPUTextureAspect as WGPUTextureAspect+import WGPU.Raw.Generated.Struct.WGPUExtent3D (WGPUExtent3D)+import qualified WGPU.Raw.Generated.Struct.WGPUExtent3D as WGPUExtent3D+import WGPU.Raw.Generated.Struct.WGPUImageCopyTexture (WGPUImageCopyTexture)+import qualified WGPU.Raw.Generated.Struct.WGPUImageCopyTexture as WGPU+import qualified WGPU.Raw.Generated.Struct.WGPUImageCopyTexture as WGPUImageCopyTexture+import WGPU.Raw.Generated.Struct.WGPUOrigin3D (WGPUOrigin3D)+import qualified WGPU.Raw.Generated.Struct.WGPUOrigin3D as WGPUOrigin3D+import WGPU.Raw.Generated.Struct.WGPUTextureDataLayout (WGPUTextureDataLayout)+import qualified WGPU.Raw.Generated.Struct.WGPUTextureDataLayout as WGPUTextureDataLayout+import WGPU.Raw.Types (WGPUTexture (WGPUTexture))  ------------------------------------------------------------------------------- +-- | Handle to a texture.+data Texture = Texture+  { textureInst :: !Instance,+    wgpuTexture :: !WGPUTexture+  }++instance Show Texture where+  show t =+    let Texture _ (WGPUTexture ptr) = t+     in showWithPtr "Texture" ptr++instance Eq Texture where+  (==) t1 t2 =+    let Texture _ (WGPUTexture t1_ptr) = t1+        Texture _ (WGPUTexture t2_ptr) = t2+     in t1_ptr == t2_ptr++instance ToRaw Texture WGPUTexture where+  raw = pure . wgpuTexture++-------------------------------------------------------------------------------+ -- | Comparison function used for depth and stencil operations. data CompareFunction   = CompareFunctionNever@@ -43,3 +90,122 @@         CompareFunctionNotEqual -> WGPUCompareFunction.NotEqual         CompareFunctionGreaterEqual -> WGPUCompareFunction.GreaterEqual         CompareFunctionAlways -> WGPUCompareFunction.Always++-------------------------------------------------------------------------------++-- | Origin of a copy to/from a texture.+data Origin3D = Origin3D+  { originX :: !Word32,+    originY :: !Word32,+    originZ :: !Word32+  }+  deriving (Eq, Show)++instance ToRaw Origin3D WGPUOrigin3D where+  raw Origin3D {..} =+    pure $+      WGPUOrigin3D.WGPUOrigin3D+        { x = originX,+          y = originY,+          z = originZ+        }++-------------------------------------------------------------------------------++-- | Extent of a texture or texture-related operation.+data Extent3D = Extent3D+  { extentWidth :: !Word32,+    extentHeight :: !Word32,+    extentDepthOrArrayLayers :: !Word32+  }+  deriving (Eq, Show)++instance ToRaw Extent3D WGPUExtent3D where+  raw Extent3D {..} =+    pure $+      WGPUExtent3D.WGPUExtent3D+        { width = extentWidth,+          height = extentHeight,+          depthOrArrayLayers = extentDepthOrArrayLayers+        }++-------------------------------------------------------------------------------++-- | Kind of data a texture holds.+data TextureAspect+  = TextureAspectAll+  | TextureAspectStencilOnly+  | TextureAspectDepthOnly+  deriving (Eq, Show)++instance ToRaw TextureAspect WGPUTextureAspect where+  raw ta = pure $ case ta of+    TextureAspectAll -> WGPUTextureAspect.All+    TextureAspectStencilOnly -> WGPUTextureAspect.StencilOnly+    TextureAspectDepthOnly -> WGPUTextureAspect.DepthOnly++-------------------------------------------------------------------------------++-- | View of a texture which can be used to copy to/from a buffer/texture.+data ImageCopyTexture = ImageCopyTexture+  { texture :: !Texture,+    mipLevel :: !Word32,+    origin :: !Origin3D,+    aspect :: !TextureAspect+  }++instance ToRaw ImageCopyTexture WGPUImageCopyTexture where+  raw ImageCopyTexture {..} = do+    n_texture <- raw texture+    n_origin <- raw origin+    n_aspect <- raw aspect+    pure+      WGPUImageCopyTexture.WGPUImageCopyTexture+        { nextInChain = nullPtr,+          texture = n_texture,+          mipLevel = mipLevel,+          origin = n_origin,+          aspect = n_aspect+        }++-------------------------------------------------------------------------------++-- | Layout of a texture in a buffer's memory.+data TextureDataLayout = TextureDataLayout+  { -- | Offset into the buffer that is the start of the texture. Must be a+    -- multiple of texture block size. For non-compressed textures, this is 1.+    textureOffset :: !Word64,+    -- | Bytes per "row" in an image.+    bytesPerRow :: !Word32,+    -- | Rows that make up a single image. Used if there are multiple images.+    rowsPerImage :: !Word32+  }+  deriving (Eq, Show)++instance ToRaw TextureDataLayout WGPUTextureDataLayout where+  raw TextureDataLayout {..} =+    pure $+      WGPUTextureDataLayout.WGPUTextureDataLayout+        { nextInChain = nullPtr,+          offset = textureOffset,+          bytesPerRow = bytesPerRow,+          rowsPerImage = rowsPerImage+        }++-------------------------------------------------------------------------------++-- | 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

@@ -14,7 +14,6 @@     VertexBufferLayout (..),     VertexState (..),     PrimitiveTopology (..),-    IndexFormat (..),     FrontFace (..),     CullMode (..),     PrimitiveState (..),@@ -61,7 +60,7 @@     rawPtr,     showWithPtr,   )-import WGPU.Internal.Multipurpose (CompareFunction)+import WGPU.Internal.Multipurpose (CompareFunction, IndexFormat) import WGPU.Internal.RenderPass (RenderPipeline (RenderPipeline)) import WGPU.Internal.SMaybe (SMaybe (SJust, SNothing)) import WGPU.Internal.Shader (ShaderEntryPoint, ShaderModule)@@ -76,7 +75,6 @@ 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@@ -256,7 +254,7 @@   { -- | Format of the input.     vertexFormat :: !VertexFormat,     -- | Byte offset of the start of the input.-    offset :: !Word64,+    vertexOffset :: !Word64,     -- | Location for this input. Must match the location in the shader.     shaderLocation :: !Word32   }@@ -268,7 +266,7 @@     pure       WGPUVertexAttribute.WGPUVertexAttribute         { format = n_format,-          offset = offset,+          offset = vertexOffset,           shaderLocation = shaderLocation         } @@ -367,24 +365,6 @@         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  ------------------------------------------------------------------------------- 

@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Module      : WGPU.Internal.Queue@@ -11,15 +12,36 @@     -- * Functions     getQueue,     queueSubmit,+    queueWriteTexture,+    queueWriteBuffer,   ) where +import Control.Monad.Cont (ContT (ContT)) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Vector (Vector)+import Foreign (castPtr)+import WGPU.Internal.Buffer (Buffer, wgpuBuffer) import WGPU.Internal.CommandBuffer (CommandBuffer) import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) import WGPU.Internal.Instance (Instance, wgpuHsInstance)-import WGPU.Internal.Memory (ToRaw, evalContT, raw, rawArrayPtr, showWithPtr)+import WGPU.Internal.Memory+  ( ReadableMemoryBuffer,+    ToRaw,+    evalContT,+    raw,+    rawArrayPtr,+    rawPtr,+    readableMemoryBufferSize,+    showWithPtr,+    toCSize,+    withReadablePtr,+  )+import WGPU.Internal.Multipurpose+  ( Extent3D,+    ImageCopyTexture,+    TextureDataLayout,+  ) import qualified WGPU.Raw.Generated.Fun as RawFun import WGPU.Raw.Types (WGPUQueue (WGPUQueue)) @@ -65,3 +87,64 @@     (wgpuQueue queue)     commandCount     commandBuffer_ptr++-------------------------------------------------------------------------------++-- | Schedule a data write into a texture.+queueWriteTexture ::+  forall m a.+  (MonadIO m, ReadableMemoryBuffer a) =>+  -- | Queue to which the texture write will be submitted.+  Queue ->+  -- | View of a texture which will be copied.+  ImageCopyTexture ->+  -- | Layout of the texture in a buffer's memory.+  TextureDataLayout ->+  -- | Extent of the texture operation.+  Extent3D ->+  -- | A 'ReadableMemoryBuffer' from which to copy. All of the buffer is copied+  -- (as determined by its 'readableMemoryBufferSize').+  a ->+  -- | Action to copy the texture+  m ()+queueWriteTexture queue imageCopyTexture textureDataLayout extent3d content =+  liftIO . evalContT $ do+    let inst = queueInst queue+    let content_sz = readableMemoryBufferSize content+    content_ptr <- ContT $ withReadablePtr content+    imageCopyTexture_ptr <- rawPtr imageCopyTexture+    textureDataLayout_ptr <- rawPtr textureDataLayout+    extent3d_ptr <- rawPtr extent3d+    RawFun.wgpuQueueWriteTexture+      (wgpuHsInstance inst)+      (wgpuQueue queue)+      imageCopyTexture_ptr+      content_ptr+      (toCSize content_sz)+      textureDataLayout_ptr+      extent3d_ptr++-- | Schedule a data write into a buffer.+queueWriteBuffer ::+  forall m a.+  (MonadIO m, ReadableMemoryBuffer a) =>+  -- | Queue to which the buffer write will be submitted.+  Queue ->+  -- | Buffer in which to write.+  Buffer ->+  -- | A 'ReadableMemoryBuffer' from which to copy. All of the buffer is copied+  -- (as determined by its 'readableMemoryBufferSize').+  a ->+  -- | Action which copies the buffer data.+  m ()+queueWriteBuffer queue buffer content = liftIO . evalContT $ do+  let inst = queueInst queue+  let content_sz = readableMemoryBufferSize content+  content_ptr <- ContT $ withReadablePtr content+  RawFun.wgpuQueueWriteBuffer+    (wgpuHsInstance inst)+    (wgpuQueue queue)+    (wgpuBuffer buffer)+    0+    (castPtr content_ptr)+    (toCSize content_sz)

@@ -19,17 +19,25 @@     -- * Functions     beginRenderPass,     renderPassSetPipeline,+    renderPassSetBindGroup,+    renderPassSetIndexBuffer,+    renderPassSetVertexBuffer,     renderPassDraw,+    renderPassDrawIndexed,     endRenderPass,   ) where  import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Int (Int32) import Data.Text (Text) import Data.Vector (Vector)-import Data.Word (Word32)+import qualified Data.Vector as Vector+import Data.Word (Word32, Word64) import Foreign (nullPtr) import Foreign.C (CBool (CBool), CFloat (CFloat))+import WGPU.Internal.Binding (BindGroup, wgpuBindGroup)+import WGPU.Internal.Buffer (Buffer, wgpuBuffer) import WGPU.Internal.Color (Color, transparentBlack) import WGPU.Internal.CommandEncoder   ( CommandEncoder,@@ -45,6 +53,7 @@     rawPtr,     showWithPtr,   )+import WGPU.Internal.Multipurpose (IndexFormat) import WGPU.Internal.SMaybe (SMaybe (SJust, SNothing)) import WGPU.Internal.Texture (TextureView) import qualified WGPU.Raw.Generated.Enum.WGPULoadOp as WGPULoadOp@@ -344,6 +353,85 @@     (rangeLength (vertices :: Range Word32))     (rangeLength (instances :: Range Word32))     (rangeStart vertices)+    (rangeStart instances)++-- | Sets the active bind group for a given bind group index.+renderPassSetBindGroup ::+  MonadIO m =>+  RenderPassEncoder ->+  Word32 ->+  BindGroup ->+  Vector Word32 ->+  m ()+renderPassSetBindGroup renderPassEncoder index bindGroup offsets =+  liftIO . evalContT $ do+    let inst = renderPassEncoderInst renderPassEncoder+    let offsetsLength = fromIntegral . Vector.length $ offsets+    offsets_ptr <- rawArrayPtr offsets+    RawFun.wgpuRenderPassEncoderSetBindGroup+      (wgpuHsInstance inst)+      (wgpuRenderPassEncoder renderPassEncoder)+      index+      (wgpuBindGroup bindGroup)+      offsetsLength+      offsets_ptr++-- | Sets the active index buffer.+renderPassSetIndexBuffer ::+  MonadIO m =>+  RenderPassEncoder ->+  Buffer ->+  IndexFormat ->+  Word64 ->+  Word64 ->+  m ()+renderPassSetIndexBuffer renderPassEncoder buffer indexFormat offset size =+  liftIO . evalContT $ do+    let inst = renderPassEncoderInst renderPassEncoder+    n_indexFormat <- raw indexFormat+    RawFun.wgpuRenderPassEncoderSetIndexBuffer+      (wgpuHsInstance inst)+      (wgpuRenderPassEncoder renderPassEncoder)+      (wgpuBuffer buffer)+      n_indexFormat+      offset+      size++-- | Assign a vertex buffer to a slot.+renderPassSetVertexBuffer ::+  MonadIO m =>+  RenderPassEncoder ->+  Word32 ->+  Buffer ->+  Word64 ->+  Word64 ->+  m ()+renderPassSetVertexBuffer renderPassEncoder slot buffer offset size = do+  let inst = renderPassEncoderInst renderPassEncoder+  RawFun.wgpuRenderPassEncoderSetVertexBuffer+    (wgpuHsInstance inst)+    (wgpuRenderPassEncoder renderPassEncoder)+    slot+    (wgpuBuffer buffer)+    offset+    size++renderPassDrawIndexed ::+  MonadIO m =>+  RenderPassEncoder ->+  Range Word32 ->+  Int32 ->+  Range Word32 ->+  m ()+renderPassDrawIndexed renderPassEncoder indices baseVertex instances = do+  let inst = renderPassEncoderInst renderPassEncoder+  RawFun.wgpuRenderPassEncoderDrawIndexed+    (wgpuHsInstance inst)+    (wgpuRenderPassEncoder renderPassEncoder)+    (rangeLength indices)+    (rangeLength instances)+    (rangeStart indices)+    baseVertex     (rangeStart instances)  -- | Finish recording of a render pass.

@@ -1,7 +1,154 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+ -- | -- Module      : WGPU.Internal.Sampler -- Description : Texture sampling. module WGPU.Internal.Sampler-  (+  ( -- * Types+    Sampler (..),+    AddressMode (..),+    FilterMode (..),+    SamplerDescriptor (..),++    -- * Functions+    createSampler,   ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text (Text)+import Data.Word (Word16)+import Foreign (nullPtr)+import Foreign.C (CFloat (CFloat))+import WGPU.Internal.Device (Device, deviceInst, wgpuDevice)+import WGPU.Internal.Instance (wgpuHsInstance)+import WGPU.Internal.Memory (ToRaw, evalContT, raw, rawPtr, showWithPtr)+import WGPU.Internal.Multipurpose (CompareFunction)+import WGPU.Raw.Generated.Enum.WGPUAddressMode (WGPUAddressMode)+import qualified WGPU.Raw.Generated.Enum.WGPUAddressMode as WGPUAddressMode+import qualified WGPU.Raw.Generated.Enum.WGPUAddressMode as WPUAddressMode+import WGPU.Raw.Generated.Enum.WGPUFilterMode (WGPUFilterMode)+import qualified WGPU.Raw.Generated.Enum.WGPUFilterMode as WGPUFilterMode+import qualified WGPU.Raw.Generated.Fun as RawFun+import WGPU.Raw.Generated.Struct.WGPUSamplerDescriptor (WGPUSamplerDescriptor)+import qualified WGPU.Raw.Generated.Struct.WGPUSamplerDescriptor as WGPUSamplerDescriptor+import WGPU.Raw.Types (WGPUSampler (WGPUSampler))++-------------------------------------------------------------------------------++-- | Handle to a 'Sampler'.+--+-- A 'Sampler' defines how a pipeline will sample from a 'TextureView'.+-- Samplers define image filters (include anisotropy) and address (wrapping)+-- modes, among other things.+newtype Sampler = Sampler {wgpuSampler :: WGPUSampler}++instance Show Sampler where+  show s =+    let Sampler (WGPUSampler ptr) = s+     in showWithPtr "Sampler" ptr++instance Eq Sampler where+  (==) s1 s2 =+    let Sampler (WGPUSampler s1_ptr) = s1+        Sampler (WGPUSampler s2_ptr) = s2+     in s1_ptr == s2_ptr++instance ToRaw Sampler WGPUSampler where+  raw = pure . wgpuSampler++-------------------------------------------------------------------------------++-- | How edges should be handled in texture addressing.+data AddressMode+  = AddressModeClampToEdge+  | AddressModeRepeat+  | AddressModeMirrorRepeat+  deriving (Eq, Show)++instance ToRaw AddressMode WGPUAddressMode where+  raw am =+    pure $ case am of+      AddressModeClampToEdge -> WPUAddressMode.ClampToEdge+      AddressModeRepeat -> WGPUAddressMode.Repeat+      AddressModeMirrorRepeat -> WGPUAddressMode.MirrorRepeat++-------------------------------------------------------------------------------++-- | Texel mixing mode when sampling between texels.+data FilterMode+  = FilterModeNearest+  | FilterModeLinear+  deriving (Eq, Show)++instance ToRaw FilterMode WGPUFilterMode where+  raw fm =+    pure $ case fm of+      FilterModeNearest -> WGPUFilterMode.Nearest+      FilterModeLinear -> WGPUFilterMode.Linear++-------------------------------------------------------------------------------++-- | Describes a 'Sampler'.+data SamplerDescriptor = SamplerDescriptor+  { samplerLabel :: !Text,+    addressModeU :: !AddressMode,+    addressModeV :: !AddressMode,+    addressModeW :: !AddressMode,+    magFilter :: !FilterMode,+    minFilter :: !FilterMode,+    mipmapFilter :: !FilterMode,+    lodMinClamp :: !Float,+    lodMaxClamp :: !Float,+    samplerCompare :: !CompareFunction,+    maxAnisotropy :: !Word16+  }+  deriving (Eq, Show)++instance ToRaw SamplerDescriptor WGPUSamplerDescriptor where+  raw SamplerDescriptor {..} = do+    label_ptr <- rawPtr samplerLabel+    n_addressModeU <- raw addressModeU+    n_addressModeV <- raw addressModeV+    n_addressModeW <- raw addressModeW+    n_magFilter <- raw magFilter+    n_minFilter <- raw minFilter+    n_mipmapFilter <- raw mipmapFilter+    n_compare <- raw samplerCompare+    pure $+      WGPUSamplerDescriptor.WGPUSamplerDescriptor+        { nextInChain = nullPtr,+          label = label_ptr,+          addressModeU = n_addressModeU,+          addressModeV = n_addressModeV,+          addressModeW = n_addressModeW,+          magFilter = n_magFilter,+          minFilter = n_minFilter,+          mipmapFilter = n_mipmapFilter,+          lodMinClamp = CFloat lodMinClamp,+          lodMaxClamp = CFloat lodMaxClamp,+          compare = n_compare,+          maxAnisotropy = maxAnisotropy+        }++-------------------------------------------------------------------------------++-- | Create a 'Sampler'.+createSampler ::+  MonadIO m =>+  -- | Device for which to create the sampler.+  Device ->+  -- | Description of the sampler to create.+  SamplerDescriptor ->+  -- | Action to create the sampler.+  m Sampler+createSampler device samplerDescriptor = liftIO . evalContT $ do+  let inst = deviceInst device+  samplerDescriptor_ptr <- rawPtr samplerDescriptor+  Sampler+    <$> RawFun.wgpuDeviceCreateSampler+      (wgpuHsInstance inst)+      (wgpuDevice device)+      samplerDescriptor_ptr

@@ -43,7 +43,6 @@ import WGPU.Raw.Generated.Enum.WGPUPresentMode (WGPUPresentMode) import qualified WGPU.Raw.Generated.Enum.WGPUPresentMode as WGPUPresentMode import WGPU.Raw.Generated.Enum.WGPUTextureFormat (WGPUTextureFormat (WGPUTextureFormat))-import WGPU.Raw.Generated.Enum.WGPUTextureUsage (WGPUTextureUsage (WGPUTextureUsage)) import qualified WGPU.Raw.Generated.Fun as RawFun import WGPU.Raw.Generated.Struct.WGPUSwapChainDescriptor (WGPUSwapChainDescriptor) import qualified WGPU.Raw.Generated.Struct.WGPUSwapChainDescriptor as WGPUSwapChainDescriptor@@ -85,9 +84,9 @@     -- 'getSwapChainPreferredFormat' function.     swapChainFormat :: !TextureFormat,     -- | Width of the swap chain. Must be the same size as the surface.-    width :: !Word32,+    swapChainWidth :: !Word32,     -- | Height of the swap chain. Must be the same size as the surface.-    height :: !Word32,+    swapChainHeight :: !Word32,     -- | Presentation mode of the swap chain.     presentMode :: !PresentMode   }@@ -96,7 +95,7 @@ instance ToRaw SwapChainDescriptor WGPUSwapChainDescriptor where   raw SwapChainDescriptor {..} = do     label_ptr <- rawPtr swapChainLabel-    WGPUTextureUsage n_usage <- raw usage+    n_usage <- raw usage     n_format <- raw swapChainFormat     n_presentMode <- raw presentMode     pure@@ -105,8 +104,8 @@           label = label_ptr,           usage = n_usage,           format = n_format,-          width = width,-          height = height,+          width = swapChainWidth,+          height = swapChainHeight,           presentMode = n_presentMode         } 

@@ -1,4 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}  -- | -- Module      : WGPU.Internal.Texture@@ -9,20 +12,49 @@     TextureFormat (..),     TextureUsage (..),     TextureViewDimension (..),+    TextureDimension (..),+    TextureDescriptor (..),+    TextureViewDescriptor (..),      -- * Functions+    createTexture,+    createView,     textureFormatFromRaw,   ) where -import WGPU.Internal.Memory (ToRaw, raw, showWithPtr)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Bits ((.|.))+import Data.Default (Default, def)+import Data.Text (Text)+import Data.Word (Word32)+import Foreign (nullPtr)+import WGPU.Internal.Device (Device, deviceInst, wgpuDevice)+import WGPU.Internal.Instance (wgpuHsInstance)+import WGPU.Internal.Memory (ToRaw, evalContT, raw, rawPtr, showWithPtr)+import WGPU.Internal.Multipurpose+  ( Extent3D,+    Texture (Texture),+    TextureAspect,+    textureInst,+    wgpuTexture,+  )+import WGPU.Raw.Generated.Enum.WGPUTextureDimension (WGPUTextureDimension)+import qualified WGPU.Raw.Generated.Enum.WGPUTextureDimension as WGPUTextureDimension import WGPU.Raw.Generated.Enum.WGPUTextureFormat (WGPUTextureFormat) import qualified WGPU.Raw.Generated.Enum.WGPUTextureFormat as WGPUTextureFormat-import WGPU.Raw.Generated.Enum.WGPUTextureUsage (WGPUTextureUsage) import qualified WGPU.Raw.Generated.Enum.WGPUTextureUsage as WGPUTextureUsage import WGPU.Raw.Generated.Enum.WGPUTextureViewDimension (WGPUTextureViewDimension) import qualified WGPU.Raw.Generated.Enum.WGPUTextureViewDimension as WGPUTextureViewDimension-import WGPU.Raw.Types (WGPUTextureView (WGPUTextureView))+import qualified WGPU.Raw.Generated.Fun as RawFun+import WGPU.Raw.Generated.Struct.WGPUTextureDescriptor (WGPUTextureDescriptor)+import qualified WGPU.Raw.Generated.Struct.WGPUTextureDescriptor as WGPUTextureDescriptor+import WGPU.Raw.Generated.Struct.WGPUTextureViewDescriptor (WGPUTextureViewDescriptor)+import qualified WGPU.Raw.Generated.Struct.WGPUTextureViewDescriptor as WGPUTextureViewDescriptor+import WGPU.Raw.Types+  ( WGPUTextureUsageFlags,+    WGPUTextureView (WGPUTextureView),+  )  ------------------------------------------------------------------------------- @@ -75,24 +107,34 @@ -- -- The usages determine from what kind of memory the texture is allocated, and -- in what actions the texture can partake.-data TextureUsage-  = TextureUsageCopySrc-  | TextureUsageCopyDst-  | TextureUsageSampled-  | TextureUsageStorage-  | TextureUsageRenderAttachment+data TextureUsage = TextureUsage+  { texCopySrc :: !Bool,+    texCopyDst :: !Bool,+    texSampled :: !Bool,+    texStorage :: !Bool,+    texRenderAttachment :: !Bool+  }   deriving (Eq, Show) -instance ToRaw TextureUsage WGPUTextureUsage where-  raw tu =+instance ToRaw TextureUsage WGPUTextureUsageFlags where+  raw TextureUsage {..} =     pure $-      case tu of-        TextureUsageCopySrc -> WGPUTextureUsage.CopySrc-        TextureUsageCopyDst -> WGPUTextureUsage.CopyDst-        TextureUsageSampled -> WGPUTextureUsage.Sampled-        TextureUsageStorage -> WGPUTextureUsage.Storage-        TextureUsageRenderAttachment -> WGPUTextureUsage.RenderAttachment+      (if texCopySrc then WGPUTextureUsage.CopySrc else 0)+        .|. (if texCopyDst then WGPUTextureUsage.CopyDst else 0)+        .|. (if texSampled then WGPUTextureUsage.Sampled else 0)+        .|. (if texStorage then WGPUTextureUsage.Storage else 0)+        .|. (if texRenderAttachment then WGPUTextureUsage.RenderAttachment else 0) +instance Default TextureUsage where+  def =+    TextureUsage+      { texCopySrc = False,+        texCopyDst = False,+        texSampled = False,+        texStorage = False,+        texRenderAttachment = False+      }+ -------------------------------------------------------------------------------  -- | Texture data format.@@ -271,3 +313,124 @@     WGPUTextureFormat.BC7RGBAUnorm -> TextureFormatBC7RGBAUnorm     WGPUTextureFormat.BC7RGBAUnormSrgb -> TextureFormatBC7RGBAUnormSrgb     _ -> error $ "Unexpected WGPUTextureFormat" <> show rt++-------------------------------------------------------------------------------++-- | Dimensionality of a texture.+data TextureDimension+  = TextureDimension1D+  | TextureDimension2D+  | TextureDimension3D+  deriving (Eq, Show)++instance ToRaw TextureDimension WGPUTextureDimension where+  raw td = pure $+    case td of+      TextureDimension1D -> WGPUTextureDimension.D1D+      TextureDimension2D -> WGPUTextureDimension.D2D+      TextureDimension3D -> WGPUTextureDimension.D3D++-------------------------------------------------------------------------------++-- | Describes a 'Texture'.+data TextureDescriptor = TextureDescriptor+  { textureLabel :: !Text,+    textureSize :: !Extent3D,+    mipLevelCount :: !Word32,+    sampleCount :: !Word32,+    dimension :: !TextureDimension,+    format :: !TextureFormat,+    textureUsage :: !TextureUsage+  }+  deriving (Eq, Show)++instance ToRaw TextureDescriptor WGPUTextureDescriptor where+  raw TextureDescriptor {..} = do+    label_ptr <- rawPtr textureLabel+    n_usage <- raw textureUsage+    n_dimension <- raw dimension+    n_size <- raw textureSize+    n_format <- raw format+    pure $+      WGPUTextureDescriptor.WGPUTextureDescriptor+        { nextInChain = nullPtr,+          label = label_ptr,+          usage = n_usage,+          dimension = n_dimension,+          size = n_size,+          format = n_format,+          mipLevelCount = mipLevelCount,+          sampleCount = sampleCount+        }++-------------------------------------------------------------------------------++-- | Describes a 'TextureView'.+data TextureViewDescriptor = TextureViewDescriptor+  { textureViewLabel :: !Text,+    textureViewFormat :: !TextureFormat,+    textureViewDimension :: !TextureViewDimension,+    textureViewBaseMipLevel :: !Word32,+    textureViewMipLevelCount :: !Word32,+    baseArrayLayer :: !Word32,+    arrayLayerCount :: !Word32,+    textureViewAspect :: !TextureAspect+  }+  deriving (Eq, Show)++instance ToRaw TextureViewDescriptor WGPUTextureViewDescriptor where+  raw TextureViewDescriptor {..} = do+    label_ptr <- rawPtr textureViewLabel+    n_format <- raw textureViewFormat+    n_dimension <- raw textureViewDimension+    n_aspect <- raw textureViewAspect+    pure $+      WGPUTextureViewDescriptor.WGPUTextureViewDescriptor+        { nextInChain = nullPtr,+          label = label_ptr,+          format = n_format,+          dimension = n_dimension,+          baseMipLevel = textureViewBaseMipLevel,+          mipLevelCount = textureViewMipLevelCount,+          baseArrayLayer = baseArrayLayer,+          arrayLayerCount = arrayLayerCount,+          aspect = n_aspect+        }++-------------------------------------------------------------------------------++-- | Create a texture.+createTexture ::+  MonadIO m =>+  -- | Device for which to create the texture.+  Device ->+  -- | Description of the texture to create.+  TextureDescriptor ->+  -- | Action to create the texture.+  m Texture+createTexture device textureDescriptor = liftIO . evalContT $ do+  let inst = deviceInst device+  textureDescriptor_ptr <- rawPtr textureDescriptor+  Texture inst+    <$> RawFun.wgpuDeviceCreateTexture+      (wgpuHsInstance inst)+      (wgpuDevice device)+      textureDescriptor_ptr++-- | Create a view of a texture.+createView ::+  MonadIO m =>+  -- | Texture for which the view should be created.+  Texture ->+  -- | Description of the texture view.+  TextureViewDescriptor ->+  -- | Created texture view.+  m TextureView+createView texture textureViewDescriptor = liftIO . evalContT $ do+  let inst = textureInst texture+  textureViewDescriptor_ptr <- rawPtr textureViewDescriptor+  TextureView+    <$> RawFun.wgpuTextureCreateView+      (wgpuHsInstance inst)+      (wgpuTexture texture)+      textureViewDescriptor_ptr

@@ -41,11 +41,29 @@     Features (..),     requestDevice, +    -- * Buffers+    Buffer,+    BufferDescriptor (..),+    BufferUsage (..),+    createBuffer,+    createBufferInit,+     -- * Textures and Views+    Texture,     TextureView,     TextureViewDimension (..),     TextureFormat (..),     TextureUsage (..),+    Extent3D (..),+    TextureDimension (..),+    TextureDescriptor (..),+    Origin3D (..),+    TextureAspect (..),+    ImageCopyTexture (..),+    TextureDataLayout (..),+    TextureViewDescriptor (..),+    createTexture,+    createView,      -- * Swapchain     SwapChain,@@ -57,9 +75,17 @@     swapChainPresent,      -- * Samplers+    Sampler,+    AddressMode (..),+    FilterMode (..),+    SamplerDescriptor (..),+    createSampler,      -- * Resource Binding+    BindGroup,     BindGroupLayout,+    BindGroupDescriptor (..),+    BindGroupEntry (..),     BindGroupLayoutDescriptor (..),     BindGroupLayoutEntry (..),     Binding (..),@@ -72,6 +98,9 @@     StorageTextureAccess (..),     TextureSampleType (..),     BufferBindingType (..),+    BindingResource (..),+    BufferBinding (..),+    createBindGroup,     createBindGroupLayout,      -- * Shader Modules@@ -138,13 +167,19 @@     commandEncoderFinish,     beginRenderPass,     renderPassSetPipeline,+    renderPassSetBindGroup,+    renderPassSetIndexBuffer,+    renderPassSetVertexBuffer,     renderPassDraw,+    renderPassDrawIndexed,     endRenderPass,      -- * Queue     Queue,     getQueue,     queueSubmit,+    queueWriteTexture,+    queueWriteBuffer,      -- * Version     Version (..),@@ -165,21 +200,30 @@     -- ** Strict Maybe     SMaybe (..),     fromSMaybe,++    -- ** Additional Classes+    ReadableMemoryBuffer (..),++    -- ** Additional Types+    ByteSize (..),   ) where  import WGPU.Internal.Adapter import WGPU.Internal.Binding+import WGPU.Internal.Buffer import WGPU.Internal.Color import WGPU.Internal.CommandBuffer import WGPU.Internal.CommandEncoder import WGPU.Internal.Device import WGPU.Internal.Instance+import WGPU.Internal.Memory import WGPU.Internal.Multipurpose import WGPU.Internal.Pipeline import WGPU.Internal.Queue import WGPU.Internal.RenderPass import WGPU.Internal.SMaybe+import WGPU.Internal.Sampler import WGPU.Internal.Shader import WGPU.Internal.Surface import WGPU.Internal.SwapChain@@ -283,7 +327,8 @@ -- -- A 'Surface' is a handle to a platform-specific presentable surface, like a -- window. First, create either a GLFW or SDL window, and then create a surface--- using either 'createGLFWSurface' or 'createSDLSurface'.+-- using either 'WGPU.GLFW.Surface.createSurface' (GLFW) or+-- 'WGPU.SDL.Surface.createSurface' (SDL2). -- -- Once you have a 'Surface', the next step is usually to -- <WGPU.html#g:adapter request an adapter> that is compatible with it.

@@ -28,6 +28,40 @@     emptySwapChainState,     withSwapChain, +    -- * Buffers++    -- ** Types+    Buffers,+    BufferName,++    -- ** Functions+    emptyBuffers,+    createBuffer,+    createBufferInit,+    getBuffer,++    -- * Textures++    -- ** Types+    Textures,+    TextureName,++    -- ** Functions+    emptyTextures,+    createTexture,+    getTexture,++    -- * Bind Groups++    -- ** Types+    BindGroups,+    BindGroupName,++    -- ** Functions+    emptyBindGroups,+    createBindGroup,+    getBindGroup,+     -- * Render Pipelines      -- ** Types@@ -59,6 +93,8 @@      -- ** Functions     loadResources,+    getWindow,+    getDrawableSize,      -- * Exceptions     AppException (..),@@ -83,17 +119,29 @@ import qualified SDL import WGPU   ( Adapter,+    BindGroup,+    BindGroupDescriptor,+    Buffer,+    BufferDescriptor (BufferDescriptor),+    BufferUsage,+    ByteSize,     Device,     DeviceDescriptor,+    Extent3D,     Instance,     Queue,+    ReadableMemoryBuffer,     RenderPipeline,     RenderPipelineDescriptor,     SMaybe,     ShaderModule,     Surface,     SwapChain,+    Texture,+    TextureDescriptor (TextureDescriptor),+    TextureDimension,     TextureFormat,+    TextureUsage,     WGSL,   ) import qualified WGPU@@ -166,15 +214,195 @@           surface           WGPU.SwapChainDescriptor             { swapChainLabel = "SwapChain",-              usage = WGPU.TextureUsageRenderAttachment,+              usage = def {WGPU.texRenderAttachment = True},               swapChainFormat = textureFormat,-              width = w,-              height = h,+              swapChainWidth = w,+              swapChainHeight = h,               presentMode = WGPU.PresentModeFifo             }       pure (Just (SwapChainDetails (w, h) swapChain), swapChain)  -------------------------------------------------------------------------------+-- Buffer Collection++-- | Name of a buffer.+newtype BufferName = BufferName {unBufferName :: Text}+  deriving (Eq, Ord, IsString, Show)++-- | Container for buffers (map of 'BufferName' to 'Buffer').+newtype Buffers = Buffers+  {unBuffers :: MVarMap BufferName Buffer}++-- | Create an empty 'Buffers' collection.+emptyBuffers :: MonadResource m => m Buffers+emptyBuffers = Buffers <$> emptyMVarMap++-- | Create an uninitialized 'Buffer'.+createBuffer ::+  (MonadIO m, C.HasDevice r m, Has Buffers r) =>+  -- | Name of the buffer.+  BufferName ->+  -- | Size of the buffer in bytes.+  ByteSize ->+  -- | Usage of the buffer.+  BufferUsage ->+  -- | Action which creates the buffer.+  m Buffer+createBuffer bufferName bufferSize bufferUsage = do+  let bufferDescriptor =+        BufferDescriptor+          { bufferLabel = unBufferName bufferName,+            bufferSize = bufferSize,+            bufferUsage = bufferUsage,+            mappedAtCreation = False+          }+  buffer <- C.createBuffer bufferDescriptor+  asks getter >>= insertMVarMap bufferName buffer . unBuffers+  pure buffer++-- | Create a 'Buffer' with specified content, storing it in the 'Buffers' map.+createBufferInit ::+  (MonadIO m, C.HasDevice r m, Has Buffers r, ReadableMemoryBuffer a) =>+  -- | Name of the buffer.+  BufferName ->+  -- | Usage of the buffer.+  BufferUsage ->+  -- | Contents of the buffer.+  a ->+  -- | Action which creates the buffer.+  m Buffer+createBufferInit bufferName bufferUsage content = do+  buffer <- C.createBufferInit (unBufferName bufferName) bufferUsage content+  asks getter >>= insertMVarMap bufferName buffer . unBuffers+  pure buffer++-- | Fetch a buffer that was previously created.+--+-- If the buffer pipeline is not available, this function throws an exception of+-- type 'AppException'.+getBuffer ::+  (MonadIO m, Has Buffers r, MonadReader r m, MonadThrow m) =>+  BufferName ->+  m Buffer+getBuffer bufferName = do+  mBuffer <- asks getter >>= lookupMVarMap bufferName . unBuffers+  case mBuffer of+    Just buffer -> pure buffer+    Nothing -> throwM (UnknownBufferName bufferName)++-------------------------------------------------------------------------------+-- Textures Collection++-- | Name of a texture.+newtype TextureName = TextureName {unTextureName :: Text}+  deriving (Eq, Ord, IsString, Show)++-- | Container for textures (map of 'TextureName' to 'Texture').+newtype Textures = Textures+  {unTextures :: MVarMap TextureName Texture}++-- | Create an empty 'Textures' collection.+emptyTextures :: MonadResource m => m Textures+emptyTextures = Textures <$> emptyMVarMap++-- | Create a 'Texture' and add it to the 'Textures' map.+createTexture ::+  (MonadIO m, C.HasDevice r m, Has Textures r) =>+  -- | Name of the texture to create.+  TextureName ->+  -- | Extent / size of the texture.+  Extent3D ->+  -- | Mip level count.+  Word32 ->+  -- | Sample count.+  Word32 ->+  -- | Dimension (1D, 2D, 3D) of the texture.+  TextureDimension ->+  -- | Format of an element of the texture.+  TextureFormat ->+  -- | Usages of the texture.+  TextureUsage ->+  -- | Action to create the texture.+  m Texture+createTexture+  name+  size+  mipLevelCount+  sampleCount+  dimension+  format+  textureUsage = do+    let textureDescriptor =+          TextureDescriptor+            { textureLabel = unTextureName name,+              textureSize = size,+              mipLevelCount = mipLevelCount,+              sampleCount = sampleCount,+              dimension = dimension,+              format = format,+              textureUsage = textureUsage+            }+    texture <- C.createTexture textureDescriptor+    asks getter >>= insertMVarMap name texture . unTextures+    pure texture++-- | Fetch a texture that was previously created using 'createTexture'.+--+-- If the texture is not available, this function throws an exception of type+-- 'AppException'.+getTexture ::+  (MonadIO m, Has Textures r, MonadReader r m, MonadThrow m) =>+  -- | Name of the texture to fetch.+  TextureName ->+  -- | Action which fetches the texture.+  m Texture+getTexture name = do+  mTexture <- asks getter >>= lookupMVarMap name . unTextures+  case mTexture of+    Just texture -> pure texture+    Nothing -> throwM (UnknownTextureName name)++-------------------------------------------------------------------------------+-- Bind Groups Collection++-- | Name of a bind group.+newtype BindGroupName = BindGroupName {unBindGroupName :: Text}+  deriving (Eq, Ord, IsString, Show)++-- | Container for bind groups that contains a map of bind groups.+newtype BindGroups = BindGroups+  {unBindGroups :: MVarMap BindGroupName BindGroup}++-- | Create an empty 'BindGroups' collection.+emptyBindGroups :: MonadResource m => m BindGroups+emptyBindGroups = BindGroups <$> emptyMVarMap++-- | Create a new 'BindGroup', adding it to the 'BindGroups' collection.+createBindGroup ::+  (MonadIO m, C.HasDevice r m, Has BindGroups r) =>+  BindGroupName ->+  BindGroupDescriptor ->+  m BindGroup+createBindGroup name bindGroupDescriptor = do+  bindGroup <- C.createBindGroup bindGroupDescriptor+  asks getter >>= insertMVarMap name bindGroup . unBindGroups+  pure bindGroup++-- | Fetch a 'BindGroup' that was previously created using 'createBindGroup'.+--+-- If the bind group is not available, this function throws an exception of type+-- 'AppException'.+getBindGroup ::+  (MonadIO m, Has BindGroups r, MonadReader r m, MonadThrow m) =>+  BindGroupName ->+  m BindGroup+getBindGroup bindGroupName = do+  mBindGroup <- asks getter >>= lookupMVarMap bindGroupName . unBindGroups+  case mBindGroup of+    Just bindGroup -> pure bindGroup+    Nothing -> throwM (UnknownBindGroupName bindGroupName)++------------------------------------------------------------------------------- -- Render Pipeline Collection  -- | Name of a render pipeline.@@ -373,6 +601,14 @@ instance Has Queue Resources where   hasLens = lens queue (\s x -> s {queue = x}) +getWindow :: (Has Window r, MonadReader r m) => m Window+getWindow = asks getter++getDrawableSize :: (Has Window r, MonadReader r m, MonadIO m) => m (Int, Int)+getDrawableSize = do+  SDL.V2 w h <- getWindow >>= SDL.glGetDrawableSize+  pure (fromIntegral w, fromIntegral h)+ ------------------------------------------------------------------------------- -- Map inside an MVar @@ -402,6 +638,12 @@     UnknownShaderName ShaderName   | -- | Requesting a render pipeline failed.     UnknownRenderPipelineName RenderPipelineName+  | -- | Requesting a buffer failed.+    UnknownBufferName BufferName+  | -- | Requesting a texture failed.+    UnknownTextureName TextureName+  | -- | Requesting a bind group failed.+    UnknownBindGroupName BindGroupName   deriving (Show)  instance Exception AppException

@@ -34,13 +34,25 @@     -- ** Device     requestDevice, +    -- ** Buffer+    createBuffer,+    createBufferInit,++    -- ** Texture+    createTexture,+    createView,+     -- ** Swapchain     getSwapChainPreferredFormat,     createSwapChain,     getSwapChainCurrentTextureView,     swapChainPresent, +    -- ** Samplers+    createSampler,+     -- ** Resource Binding+    createBindGroup,     createBindGroupLayout,      -- ** Shader Modules@@ -60,12 +72,18 @@     beginRenderPass,     renderPassSetPipeline,     renderPassDraw,+    renderPassSetBindGroup,+    renderPassSetIndexBuffer,+    renderPassSetVertexBuffer,+    renderPassDrawIndexed,     endRenderPass,      -- ** Queue     getQueue,     queueSubmit,     queueSubmit',+    queueWriteTexture,+    queueWriteBuffer,      -- ** Version     getVersion,@@ -89,36 +107,52 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT) import Data.Has (Has, getter)+import Data.Int (Int32) import Data.Text (Text) import Data.Vector (Vector)-import Data.Word (Word32)+import Data.Word (Word32, Word64) import WGPU   ( Adapter,     AdapterProperties,+    BindGroup,+    BindGroupDescriptor,     BindGroupLayout,     BindGroupLayoutDescriptor,+    Buffer,+    BufferDescriptor,+    BufferUsage,     CommandBuffer,     CommandEncoder,     Device,     DeviceDescriptor,+    Extent3D,+    ImageCopyTexture,+    IndexFormat,     Instance,     LogLevel,     PipelineLayout,     PipelineLayoutDescriptor,     Queue,     Range,+    ReadableMemoryBuffer,     RenderPassDescriptor,     RenderPassEncoder,     RenderPipeline,     RenderPipelineDescriptor,     SPIRV,+    Sampler,+    SamplerDescriptor,     ShaderModule,     ShaderModuleDescriptor,     Surface,     SwapChain,     SwapChainDescriptor,+    Texture,+    TextureDataLayout,+    TextureDescriptor,     TextureFormat,     TextureView,+    TextureViewDescriptor,     Version,     WGSL,   )@@ -137,6 +171,8 @@  type HasDevice r m = (RIO r m, Has Device r) +type HasTexture r m = (RIO r m, Has Texture r)+ type HasSwapChain r m = (RIO r m, Has SwapChain r)  type HasCommandEncoder r m = (RIO r m, Has CommandEncoder r)@@ -157,6 +193,27 @@ access3 action y z = asks getter >>= \x -> action x y z {-# INLINEABLE access3 #-} +access4 ::+  (Has q r, MonadReader r m) =>+  (q -> b -> c -> d -> m a) ->+  b ->+  c ->+  d ->+  m a+access4 action x y z = asks getter >>= \w -> action w x y z+{-# INLINEABLE access4 #-}++access5 ::+  (Has q r, MonadReader r m) =>+  (q -> b -> c -> d -> e -> m a) ->+  b ->+  c ->+  d ->+  e ->+  m a+access5 action w x y z = asks getter >>= \v -> action v w x y z+{-# INLINEABLE access5 #-}+ ------------------------------------------------------------------------------- -- Adapter @@ -176,6 +233,33 @@ {-# INLINEABLE requestDevice #-}  -------------------------------------------------------------------------------+-- Buffer++createBuffer :: HasDevice r m => BufferDescriptor -> m Buffer+createBuffer = access2 WGPU.createBuffer+{-# INLINEABLE createBuffer #-}++createBufferInit ::+  (HasDevice r m, ReadableMemoryBuffer a) =>+  Text ->+  BufferUsage ->+  a ->+  m Buffer+createBufferInit = access4 WGPU.createBufferInit+{-# INLINEABLE createBufferInit #-}++-------------------------------------------------------------------------------+-- Texture++createTexture :: HasDevice r m => TextureDescriptor -> m Texture+createTexture = access2 WGPU.createTexture+{-# INLINEABLE createTexture #-}++createView :: HasTexture r m => TextureViewDescriptor -> m TextureView+createView = access2 WGPU.createView+{-# INLINEABLE createView #-}++------------------------------------------------------------------------------- -- Swapchain  getSwapChainPreferredFormat ::@@ -201,8 +285,19 @@ {-# INLINEABLE swapChainPresent #-}  -------------------------------------------------------------------------------+-- Samplers++createSampler :: (HasDevice r m) => SamplerDescriptor -> m Sampler+createSampler = access2 WGPU.createSampler+{-# INLINEABLE createSampler #-}++------------------------------------------------------------------------------- -- Resource Binding +createBindGroup :: HasDevice r m => BindGroupDescriptor -> m BindGroup+createBindGroup = access2 WGPU.createBindGroup+{-# INLINEABLE createBindGroup #-}+ createBindGroupLayout ::   HasDevice r m =>   BindGroupLayoutDescriptor ->@@ -272,6 +367,44 @@ renderPassDraw = access3 WGPU.renderPassDraw {-# INLINEABLE renderPassDraw #-} +renderPassSetBindGroup ::+  HasRenderPassEncoder r m =>+  Word32 ->+  BindGroup ->+  Vector Word32 ->+  m ()+renderPassSetBindGroup = access4 WGPU.renderPassSetBindGroup+{-# INLINEABLE renderPassSetBindGroup #-}++renderPassSetIndexBuffer ::+  HasRenderPassEncoder r m =>+  Buffer ->+  IndexFormat ->+  Word64 ->+  Word64 ->+  m ()+renderPassSetIndexBuffer = access5 WGPU.renderPassSetIndexBuffer+{-# INLINEABLE renderPassSetIndexBuffer #-}++renderPassSetVertexBuffer ::+  HasRenderPassEncoder r m =>+  Word32 ->+  Buffer ->+  Word64 ->+  Word64 ->+  m ()+renderPassSetVertexBuffer = access5 WGPU.renderPassSetVertexBuffer+{-# INLINEABLE renderPassSetVertexBuffer #-}++renderPassDrawIndexed ::+  HasRenderPassEncoder r m =>+  Range Word32 ->+  Int32 ->+  Range Word32 ->+  m ()+renderPassDrawIndexed = access4 WGPU.renderPassDrawIndexed+{-# INLINEABLE renderPassDrawIndexed #-}+ endRenderPass :: HasRenderPassEncoder r m => m () endRenderPass = access WGPU.endRenderPass {-# INLINEABLE endRenderPass #-}@@ -291,6 +424,24 @@ queueSubmit' :: HasDevice r m => Vector CommandBuffer -> m () queueSubmit' = buildQueue . queueSubmit {-# INLINEABLE queueSubmit' #-}++queueWriteTexture ::+  (HasQueue r m, ReadableMemoryBuffer a) =>+  ImageCopyTexture ->+  TextureDataLayout ->+  Extent3D ->+  a ->+  m ()+queueWriteTexture = access5 WGPU.queueWriteTexture+{-# INLINEABLE queueWriteTexture #-}++queueWriteBuffer ::+  (HasQueue r m, ReadableMemoryBuffer a) =>+  Buffer ->+  a ->+  m ()+queueWriteBuffer = access3 WGPU.queueWriteBuffer+{-# INLINEABLE queueWriteBuffer #-}  ------------------------------------------------------------------------------- -- Version

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               wgpu-hs-version:            0.3.0.0+version:            0.4.0.0 synopsis:           WGPU description:        A high-level binding to WGPU. bug-reports:        https://github.com/lancelet/wgpu-hs/issues@@ -42,6 +42,7 @@   exposed-modules:     WGPU.Internal.Adapter     WGPU.Internal.Binding+    WGPU.Internal.Buffer     WGPU.Internal.ChainedStruct     WGPU.Internal.Color     WGPU.Internal.CommandBuffer@@ -94,7 +95,7 @@     , text              ^>=1.2.4     , vector            ^>=0.12.3     , wgpu-hs-internal-    , wgpu-raw-hs       ==0.3.0.0+    , wgpu-raw-hs       ==0.4.0.0    exposed-modules:     WGPU@@ -149,3 +150,29 @@    hs-source-dirs: examples/triangle-glfw   main-is:        TriangleGLFW.hs++executable cube+  import:         base, ghc-options++  if (flag(examples) && flag(sdl2))+    build-depends:+      , data-default     ^>=0.7.1.1+      , data-has         ^>=0.4.0.0+      , derive-storable  ^>=0.3.0.0+      , JuicyPixels      ^>=3.3.5+      , lens             ^>=5.0.1+      , linear           ^>=1.21.6+      , mtl              ^>=2.2.2+      , resourcet        ^>=1.2.4.3+      , safe-exceptions  ^>=0.1.7.2+      , sdl2             ^>=2.5.3.0+      , string-qq        ^>=0.0.4+      , text             ^>=1.2.4+      , vector           ^>=0.12.3+      , wgpu-hs++  else+    buildable: False++  hs-source-dirs: examples/cube+  main-is:        Cube.hs