diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/examples/triangle/Triangle.hs b/examples/triangle/Triangle.hs deleted file mode 100644 --- a/examples/triangle/Triangle.hs +++ /dev/null @@ -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 {", - " let x = f32(i32(in_vertex_index) - 1);", - " let y = f32(i32(in_vertex_index & 1u) * 2 - 1);", - " return vec4(x, y, 0.0, 1.0);", - "}", - "", - "[[stage(fragment)]]", - "fn fs_main([[builtin(position)]] in: vec4) -> [[location(0)]] vec4 {", - " return vec4(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 diff --git a/wgpu-raw-hs.cabal b/wgpu-raw-hs.cabal --- a/wgpu-raw-hs.cabal +++ b/wgpu-raw-hs.cabal @@ -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