wgpu-raw-hs 0.1.0.2 → 0.1.0.3
raw patch · 3 files changed
+7/−620 lines, 3 filesdep −wgpu-raw-hsdep ~GLFW-bdep ~base
Dependencies removed: wgpu-raw-hs
Dependency ranges changed: GLFW-b, base
Files
- CHANGELOG.md +5/−0
- examples/triangle/Triangle.hs +0/−601
- wgpu-raw-hs.cabal +2/−19
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Revision history for wgpu-raw-hs +## 0.1.0.3 -- 2021-08-20++- Removed slightly-broken `triangle` example. There is now a fully-working+ `triangle` example in the `wgpu-hs` package instead.+ ## 0.1.0.2 -- 2021-08-16 - Redo attempt at stubbing out `createSurface`.
− examples/triangle/Triangle.hs
@@ -1,601 +0,0 @@-{-# LANGUAGE DisambiguateRecordFields #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Create an SDL window and draw a triangle using WGPU.------ Please note: This is more of a proof-of-concept test for the Raw API. The--- intent is to create a much nicer API on top of the Raw API. So this example--- isn't intended as a template for an actual application.-module Triangle where--import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)-import Control.Monad (unless)-import Data.List (intersperse)-import Data.Word (Word32)-import Foreign (Ptr, alloca, castPtr, freeHaskellFunPtr, nullPtr, poke)-import Foreign.C (CChar, peekCString, withCString)-import Foreign.C.Types (CBool (CBool))-import qualified Graphics.UI.GLFW as GLFW-import System.Exit (exitFailure)-import WGPU.Raw.Dynamic (withWGPU)-import WGPU.Raw.GLFWSurface (createSurface)-import qualified WGPU.Raw.Generated.Enum.WGPUBlendFactor as WGPUBlendFactor-import qualified WGPU.Raw.Generated.Enum.WGPUBlendOperation as WGPUBlendOperation-import qualified WGPU.Raw.Generated.Enum.WGPUColorWriteMask as WGPUColorWriteMask-import qualified WGPU.Raw.Generated.Enum.WGPUCullMode as WGPUCullMode-import qualified WGPU.Raw.Generated.Enum.WGPUFrontFace as WGPUFrontFace-import qualified WGPU.Raw.Generated.Enum.WGPUIndexFormat as WGPUIndexFormat-import WGPU.Raw.Generated.Enum.WGPULogLevel (WGPULogLevel)-import qualified WGPU.Raw.Generated.Enum.WGPULogLevel as WGPULogLevel-import qualified WGPU.Raw.Generated.Enum.WGPUNativeSType as WGPUSType-import qualified WGPU.Raw.Generated.Enum.WGPUPresentMode as WGPUPresentMode-import qualified WGPU.Raw.Generated.Enum.WGPUPrimitiveTopology as WGPUPrimitiveTopology-import qualified WGPU.Raw.Generated.Enum.WGPUSType as WGPUSType-import qualified WGPU.Raw.Generated.Enum.WGPUStoreOp as WGPULoadOp-import qualified WGPU.Raw.Generated.Enum.WGPUStoreOp as WGPUStoreOp-import WGPU.Raw.Generated.Enum.WGPUTextureFormat (WGPUTextureFormat (WGPUTextureFormat))-import qualified WGPU.Raw.Generated.Enum.WGPUTextureUsage as WGPUTextureUsage-import WGPU.Raw.Generated.Fun- ( WGPUHsInstance,- wgpuAdapterRequestDevice,- wgpuCommandEncoderBeginRenderPass,- wgpuCommandEncoderFinish,- wgpuDeviceCreateCommandEncoder,- wgpuDeviceCreatePipelineLayout,- wgpuDeviceCreateRenderPipeline,- wgpuDeviceCreateShaderModule,- wgpuDeviceCreateSwapChain,- wgpuDeviceGetQueue,- wgpuInstanceRequestAdapter,- wgpuQueueSubmit,- wgpuRenderPassEncoderDraw,- wgpuRenderPassEncoderEndPass,- wgpuRenderPassEncoderSetPipeline,- wgpuSetLogCallback,- wgpuSetLogLevel,- wgpuSurfaceGetPreferredFormat,- wgpuSwapChainGetCurrentTextureView,- wgpuSwapChainPresent,- )-import WGPU.Raw.Generated.Struct.WGPUBlendComponent-import WGPU.Raw.Generated.Struct.WGPUBlendState-import WGPU.Raw.Generated.Struct.WGPUChainedStruct-import WGPU.Raw.Generated.Struct.WGPUColor-import WGPU.Raw.Generated.Struct.WGPUColorTargetState-import WGPU.Raw.Generated.Struct.WGPUCommandBufferDescriptor-import WGPU.Raw.Generated.Struct.WGPUCommandEncoderDescriptor-import WGPU.Raw.Generated.Struct.WGPUDeviceDescriptor-import WGPU.Raw.Generated.Struct.WGPUDeviceExtras-import WGPU.Raw.Generated.Struct.WGPUFragmentState-import WGPU.Raw.Generated.Struct.WGPUMultisampleState-import WGPU.Raw.Generated.Struct.WGPUPipelineLayoutDescriptor-import WGPU.Raw.Generated.Struct.WGPUPrimitiveState-import WGPU.Raw.Generated.Struct.WGPURenderPassColorAttachment-import WGPU.Raw.Generated.Struct.WGPURenderPassDescriptor-import WGPU.Raw.Generated.Struct.WGPURenderPipelineDescriptor-import WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions-import WGPU.Raw.Generated.Struct.WGPUShaderModuleDescriptor-import WGPU.Raw.Generated.Struct.WGPUShaderModuleWGSLDescriptor-import WGPU.Raw.Generated.Struct.WGPUSwapChainDescriptor-import WGPU.Raw.Generated.Struct.WGPUVertexState-import WGPU.Raw.Types- ( WGPUAdapter (WGPUAdapter),- WGPUCommandBuffer,- WGPUCommandEncoder,- WGPUDevice (WGPUDevice),- WGPUInstance (WGPUInstance),- WGPULogCallback,- WGPUPipelineLayout,- WGPUQuerySet (WGPUQuerySet),- WGPUQueue,- WGPURenderPassEncoder,- WGPURenderPipeline,- WGPURequestAdapterCallback,- WGPURequestDeviceCallback,- WGPUShaderModule,- WGPUSurface,- WGPUSurfaceGetPreferredFormatCallback,- WGPUSwapChain,- WGPUTextureView (WGPUTextureView),- )--main :: IO ()-main = do- putStrLn "Triangle example"-- let wwidth, wheight :: Int- wwidth = 640- wheight = 480-- initResult <- GLFW.init- unless initResult $ do- putStrLn "GLFW initialization failed"- exitFailure-- GLFW.windowHint (GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI)- window <- do- mWindow <- GLFW.createWindow wwidth wheight "Triangle" Nothing Nothing- case mWindow of- Just w -> pure w- Nothing -> do- putStrLn "Could not create GLFW window"- exitFailure-- withWGPU "libwgpu_native.dylib" $ \inst -> do- withLog inst WGPULogLevel.Warn $ do- surface <- createSurface inst window- adapter <- getAdapterForSurface inst surface- device <- getDevice inst adapter- shader <- compileWGSL inst device "shader" shaderSrc- pipelineLayout <- createPipelineLayout inst device- swapChainFormat <- getSwapChainFormat inst surface adapter- pipeline <-- createRenderPipeline inst device pipelineLayout shader swapChainFormat- swapChain <-- createSwapChain inst device surface swapChainFormat wwidth wheight-- let loop = do- -- render- nextTexture <- wgpuSwapChainGetCurrentTextureView inst swapChain- encoder <- createCommandEncoder inst device- renderPass <- beginRenderPass inst encoder nextTexture- wgpuRenderPassEncoderSetPipeline inst renderPass pipeline- wgpuRenderPassEncoderDraw inst renderPass 3 1 0 0- wgpuRenderPassEncoderEndPass inst renderPass- queue <- wgpuDeviceGetQueue inst device- cmdBuffer <- commandEncoderFinish inst encoder- queueSubmit inst queue 1 cmdBuffer- wgpuSwapChainPresent inst swapChain-- -- handle quit event- GLFW.pollEvents- shouldClose <- GLFW.windowShouldClose window- unless shouldClose loop- loop-- GLFW.destroyWindow window- GLFW.terminate--shaderSrc :: String-shaderSrc =- mconcat $- intersperse- "\n"- [ "[[stage(vertex)]]",- "fn vs_main([[builtin(vertex_index)]] in_vertex_index: u32) -> [[builtin(position)]] vec4<f32> {",- " let x = f32(i32(in_vertex_index) - 1);",- " let y = f32(i32(in_vertex_index & 1u) * 2 - 1);",- " return vec4<f32>(x, y, 0.0, 1.0);",- "}",- "",- "[[stage(fragment)]]",- "fn fs_main([[builtin(position)]] in: vec4<f32>) -> [[location(0)]] vec4<f32> {",- " return vec4<f32>(in.x/640.0, in.y/480.0, 1.0, 1.0);",- "}"- ]-----------------------------------------------------------------------------------withLog :: WGPUHsInstance -> WGPULogLevel -> IO a -> IO a-withLog inst logLevel action = do- let logCallback :: WGPULogLevel -> Ptr CChar -> IO ()- logCallback lLvl cMsg = do- let prefix =- case lLvl of- WGPULogLevel.Error -> "Error"- WGPULogLevel.Warn -> "Warn"- WGPULogLevel.Info -> "Info"- WGPULogLevel.Debug -> "Debug"- WGPULogLevel.Trace -> "Trace"- _ -> "Unknown"- msg <- peekCString cMsg- putStrLn $ "[" <> prefix <> "] " <> msg-- logCallback_c :: WGPULogCallback <- mkLogCallback logCallback- wgpuSetLogCallback inst logCallback_c- wgpuSetLogLevel inst logLevel- result <- action-- freeHaskellFunPtr logCallback_c-- pure result--foreign import ccall "wrapper"- mkLogCallback ::- (WGPULogLevel -> Ptr CChar -> IO ()) ->- IO WGPULogCallback------------------------------------------------------------------------------------- | Get a WGPU Adapter which matches the supplied surface.-getAdapterForSurface :: WGPUHsInstance -> WGPUSurface -> IO WGPUAdapter-getAdapterForSurface inst surface = do- adapterMVar :: MVar WGPUAdapter <- newEmptyMVar-- let adapterCallback :: WGPUAdapter -> Ptr () -> IO ()- adapterCallback adapter _ = putMVar adapterMVar adapter-- adapterCallback_c :: WGPURequestAdapterCallback <-- mkAdapterCallback adapterCallback-- alloca $ \requestAdapterOptions_ptr -> do- let requestAdapterOptions =- WGPURequestAdapterOptions- { nextInChain = nullPtr,- compatibleSurface = surface- }- poke requestAdapterOptions_ptr requestAdapterOptions- wgpuInstanceRequestAdapter- inst- (WGPUInstance nullPtr)- requestAdapterOptions_ptr- adapterCallback_c- nullPtr-- adapter :: WGPUAdapter <- takeMVar adapterMVar- freeHaskellFunPtr adapterCallback_c- pure adapter--foreign import ccall "wrapper"- mkAdapterCallback ::- (WGPUAdapter -> Ptr () -> IO ()) -> IO WGPURequestAdapterCallback------------------------------------------------------------------------------------- | Get a WGPU Device.-getDevice :: WGPUHsInstance -> WGPUAdapter -> IO WGPUDevice-getDevice inst adapter = do- deviceMVar :: MVar WGPUDevice <- newEmptyMVar-- let deviceCallback :: WGPUDevice -> Ptr () -> IO ()- deviceCallback device _ = putMVar deviceMVar device-- deviceCallback_c :: WGPURequestDeviceCallback <-- mkDeviceCallback deviceCallback-- alloca $ \deviceDescriptor_ptr -> do- alloca $ \chainedStruct_ptr -> do- alloca $ \deviceExtras_ptr -> do- let deviceExtras =- WGPUDeviceExtras- { chain =- WGPUChainedStruct- { next = nullPtr,- sType = WGPUSType.DeviceExtras- },- maxTextureDimension1D = 0,- maxTextureDimension2D = 0,- maxTextureDimension3D = 0,- maxTextureArrayLayers = 0,- maxBindGroups = 1,- maxDynamicStorageBuffersPerPipelineLayout = 0,- maxStorageBuffersPerShaderStage = 0,- maxStorageBufferBindingSize = 0,- nativeFeatures = 0,- label = nullPtr,- tracePath = nullPtr- }- poke deviceExtras_ptr deviceExtras-- let chainedStruct =- WGPUChainedStruct- { next = castPtr deviceExtras_ptr,- sType = WGPUSType.DeviceExtras- }- poke chainedStruct_ptr chainedStruct-- let deviceDescriptor =- WGPUDeviceDescriptor- { nextInChain = chainedStruct_ptr- }- poke deviceDescriptor_ptr deviceDescriptor-- wgpuAdapterRequestDevice- inst- adapter- deviceDescriptor_ptr- deviceCallback_c- nullPtr-- device :: WGPUDevice <- takeMVar deviceMVar- freeHaskellFunPtr deviceCallback_c- pure device--foreign import ccall "wrapper"- mkDeviceCallback ::- (WGPUDevice -> Ptr () -> IO ()) -> IO WGPURequestDeviceCallback------------------------------------------------------------------------------------- | Compile a shader.-compileWGSL ::- -- | WGPUHs instance.- WGPUHsInstance ->- -- | WGPU Device.- WGPUDevice ->- -- | Name of the shader.- String ->- -- | Shader source.- String ->- -- | Compiled shader module.- IO WGPUShaderModule-compileWGSL inst device name src = do- withCString name $ \name_ptr -> do- withCString src $ \src_ptr -> do- alloca $ \shaderModuleDescriptor_ptr -> do- alloca $ \chainedStruct_ptr -> do- alloca $ \shaderModuleWGSLDescriptor_ptr -> do- let shaderModuleWGSLDescriptor =- WGPUShaderModuleWGSLDescriptor- { chain =- WGPUChainedStruct- { next = nullPtr,- sType = WGPUSType.ShaderModuleWGSLDescriptor- },- source = src_ptr- }- poke shaderModuleWGSLDescriptor_ptr shaderModuleWGSLDescriptor-- let chainedStruct =- WGPUChainedStruct- { next = castPtr shaderModuleWGSLDescriptor_ptr,- sType = WGPUSType.ShaderModuleWGSLDescriptor- }- poke chainedStruct_ptr chainedStruct-- let shaderModuleDescriptor =- WGPUShaderModuleDescriptor- { nextInChain = chainedStruct_ptr,- label = name_ptr- }- poke shaderModuleDescriptor_ptr shaderModuleDescriptor-- wgpuDeviceCreateShaderModule inst device shaderModuleDescriptor_ptr------------------------------------------------------------------------------------- | Create pipeline layout.-createPipelineLayout :: WGPUHsInstance -> WGPUDevice -> IO WGPUPipelineLayout-createPipelineLayout inst device = do- alloca $ \pipelineLayoutDescriptor_ptr -> do- let pipelineLayoutDescriptor =- WGPUPipelineLayoutDescriptor- { nextInChain = nullPtr,- label = nullPtr,- bindGroupLayoutCount = 0,- bindGroupLayouts = nullPtr- }- poke pipelineLayoutDescriptor_ptr pipelineLayoutDescriptor-- wgpuDeviceCreatePipelineLayout inst device pipelineLayoutDescriptor_ptr------------------------------------------------------------------------------------- | Get preferred format for the swapchain-getSwapChainFormat ::- WGPUHsInstance ->- WGPUSurface ->- WGPUAdapter ->- IO WGPUTextureFormat-getSwapChainFormat inst surface adapter = do- textureFormatMVar :: MVar WGPUTextureFormat <- newEmptyMVar-- let textureFormatCallback :: WGPUTextureFormat -> Ptr () -> IO ()- textureFormatCallback tf _ = putMVar textureFormatMVar tf-- textureFormatCallback_c :: WGPUSurfaceGetPreferredFormatCallback <-- mkSurfaceGetPreferredFormatCallback textureFormatCallback-- wgpuSurfaceGetPreferredFormat- inst- surface- adapter- textureFormatCallback_c- nullPtr-- textureFormat :: WGPUTextureFormat <- takeMVar textureFormatMVar- freeHaskellFunPtr textureFormatCallback_c- pure textureFormat--foreign import ccall "wrapper"- mkSurfaceGetPreferredFormatCallback ::- (WGPUTextureFormat -> Ptr () -> IO ()) ->- IO WGPUSurfaceGetPreferredFormatCallback-----------------------------------------------------------------------------------createRenderPipeline ::- WGPUHsInstance ->- WGPUDevice ->- WGPUPipelineLayout ->- WGPUShaderModule ->- WGPUTextureFormat ->- IO WGPURenderPipeline-createRenderPipeline inst device pipelineLayout shader swapChainFormat = do- withCString "vs_main" $ \vsEntryPoint_ptr -> do- withCString "fs_main" $ \fsEntryPoint_ptr -> do- alloca $ \blendState_ptr -> do- alloca $ \colorTargetState_ptr -> do- alloca $ \fragmentState_ptr -> do- alloca $ \renderPipelineDescriptor_ptr -> do- let blendState =- WGPUBlendState- { color =- WGPUBlendComponent- { srcFactor = WGPUBlendFactor.One,- dstFactor = WGPUBlendFactor.Zero,- operation = WGPUBlendOperation.Add- },- alpha =- WGPUBlendComponent- { srcFactor = WGPUBlendFactor.One,- dstFactor = WGPUBlendFactor.Zero,- operation = WGPUBlendOperation.Add- }- }- poke blendState_ptr blendState-- let colorTargetState =- WGPUColorTargetState- { nextInChain = nullPtr,- format = swapChainFormat,- blend = blendState_ptr,- writeMask = WGPUColorWriteMask.All- }- poke colorTargetState_ptr colorTargetState-- let fragmentState =- WGPUFragmentState- { nextInChain = nullPtr,- shaderModule = shader,- entryPoint = fsEntryPoint_ptr,- targetCount = 1,- targets = colorTargetState_ptr- }- poke fragmentState_ptr fragmentState-- let renderPipelineDescriptor =- WGPURenderPipelineDescriptor- { nextInChain = nullPtr,- label = nullPtr,- layout = pipelineLayout,- vertex =- WGPUVertexState- { nextInChain = nullPtr,- shaderModule = shader,- entryPoint = vsEntryPoint_ptr,- bufferCount = 0,- buffers = nullPtr- },- primitive =- WGPUPrimitiveState- { nextInChain = nullPtr,- topology = WGPUPrimitiveTopology.TriangleList,- stripIndexFormat = WGPUIndexFormat.Undefined,- frontFace = WGPUFrontFace.CCW,- cullMode = WGPUCullMode.None- },- depthStencil = nullPtr,- multisample =- WGPUMultisampleState- { nextInChain = nullPtr,- count = 1,- mask = 0xFFFFFFFF,- alphaToCoverageEnabled = CBool 0- },- fragment = fragmentState_ptr- }- poke renderPipelineDescriptor_ptr renderPipelineDescriptor-- wgpuDeviceCreateRenderPipeline- inst- device- renderPipelineDescriptor_ptr-----------------------------------------------------------------------------------createSwapChain ::- WGPUHsInstance ->- WGPUDevice ->- WGPUSurface ->- WGPUTextureFormat ->- Int ->- Int ->- IO WGPUSwapChain-createSwapChain inst device surface swapChainFormat w h = do- withCString "swapChain" $ \swapChainName_ptr ->- alloca $ \swapChainDescriptor_ptr -> do- let swapChainDescriptor =- WGPUSwapChainDescriptor- { nextInChain = nullPtr,- label = swapChainName_ptr,- usage = WGPUTextureUsage.RenderAttachment,- format = swapChainFormat,- width = fromIntegral w,- height = fromIntegral h,- presentMode = WGPUPresentMode.Fifo- }- poke swapChainDescriptor_ptr swapChainDescriptor- wgpuDeviceCreateSwapChain inst device surface swapChainDescriptor_ptr-----------------------------------------------------------------------------------createCommandEncoder ::- WGPUHsInstance ->- WGPUDevice ->- IO WGPUCommandEncoder-createCommandEncoder inst device = do- alloca $ \commandEncoderDescriptor_ptr -> do- let commandEncoderDescriptor =- WGPUCommandEncoderDescriptor- { nextInChain = nullPtr,- label = nullPtr- }- poke commandEncoderDescriptor_ptr commandEncoderDescriptor- wgpuDeviceCreateCommandEncoder inst device commandEncoderDescriptor_ptr-----------------------------------------------------------------------------------beginRenderPass ::- WGPUHsInstance ->- WGPUCommandEncoder ->- WGPUTextureView ->- IO WGPURenderPassEncoder-beginRenderPass inst cmdEncoder textureView = do- alloca $ \renderPassColorAttachment_ptr -> do- alloca $ \renderPassDescriptor_ptr -> do- let renderPassColorAttachment =- WGPURenderPassColorAttachment- { view = textureView,- resolveTarget = WGPUTextureView nullPtr,- loadOp = WGPULoadOp.Clear,- storeOp = WGPUStoreOp.Store,- clearColor = WGPUColor 0 0 0 1- }- poke renderPassColorAttachment_ptr renderPassColorAttachment-- let renderPassDescriptor =- WGPURenderPassDescriptor- { nextInChain = nullPtr,- label = nullPtr,- colorAttachmentCount = 1,- colorAttachments = renderPassColorAttachment_ptr,- depthStencilAttachment = nullPtr,- occlusionQuerySet = WGPUQuerySet nullPtr- }- poke renderPassDescriptor_ptr renderPassDescriptor-- wgpuCommandEncoderBeginRenderPass inst cmdEncoder renderPassDescriptor_ptr-----------------------------------------------------------------------------------commandEncoderFinish ::- WGPUHsInstance ->- WGPUCommandEncoder ->- IO WGPUCommandBuffer-commandEncoderFinish inst encoder = do- alloca $ \commandBufferDescriptor_ptr -> do- let commandBufferDescriptor =- WGPUCommandBufferDescriptor- { nextInChain = nullPtr,- label = nullPtr- }- poke commandBufferDescriptor_ptr commandBufferDescriptor-- wgpuCommandEncoderFinish inst encoder commandBufferDescriptor_ptr-----------------------------------------------------------------------------------queueSubmit ::- WGPUHsInstance ->- WGPUQueue ->- Word32 ->- WGPUCommandBuffer ->- IO ()-queueSubmit inst queue n cmdBuffer = do- alloca $ \commandBuffer_ptr -> do- poke commandBuffer_ptr cmdBuffer-- wgpuQueueSubmit inst queue n commandBuffer_ptr
wgpu-raw-hs.cabal view
@@ -1,10 +1,9 @@ cabal-version: 3.0 name: wgpu-raw-hs-version: 0.1.0.2+version: 0.1.0.3 synopsis: WGPU Raw description: A very low-level WGPU binding.- . Currently, this package will only work properly on macOS. In the future, support for Linux and Windows is planned. @@ -149,7 +148,7 @@ WGPU.Raw.Types if flag(glfw)- build-depends: GLFW-b+ build-depends: GLFW-b ^>=3.3.0 exposed-modules: WGPU.Raw.GLFWSurface if os(osx)@@ -170,19 +169,3 @@ cpp-options: -DWGPUHS_WINDOWS -DWGPUHS_TARGET_WINDOWS cc-options: -DWGPUHS_TARGET=WGPUHS_TARGET_WINDOWS build-depends: Win32--executable triangle- import: base, ghc-options-- if flag(examples)- build-depends:- , base- , GLFW-b ^>=3.3.0- , wgpu-raw-hs-- else- buildable: False-- hs-source-dirs: examples/triangle- main-is: Triangle.hs- ghc-options: -main-is Triangle