diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for wgpu-hs + +## 0.1.0.0 -- 2021-08-20 + +- Initial (incomplete) API bindings started. +- Working `triangle` example. diff --git a/examples/triangle/Main.hs b/examples/triangle/Main.hs new file mode 100644 --- /dev/null +++ b/examples/triangle/Main.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Let's draw a triangle! +module Main (main) where + +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) +import Data.Default (def) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import qualified Graphics.UI.GLFW as GLFW +import System.Exit (exitFailure) +import qualified WGPU + +main :: IO () +main = do + TextIO.putStrLn "Triangle Example" + + -- start GLFW + initResult <- GLFW.init + unless initResult $ do + TextIO.putStrLn "Failed to initialize GLFW" + exitFailure + + -- create the GLFW window without a "client API" + let initWidth, initHeight :: Int + initWidth = 640 + initHeight = 480 + GLFW.windowHint (GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI) + window <- do + mWin <- GLFW.createWindow initWidth initHeight "Triangle" Nothing Nothing + case mWin of + Just w -> pure w + Nothing -> do + TextIO.putStrLn "Failed to create GLFW window" + exitFailure + + WGPU.withInstance "libwgpu_native.dylib" (Just WGPU.logStdout) $ \inst -> do + -- set the logging level + WGPU.setLogLevel inst WGPU.Warn + + -- print the version of the WGPU library + version <- WGPU.getVersion inst + TextIO.putStrLn $ "WGPU version: " <> WGPU.versionToText version + + -- fetch resources (surface, adpater, device) + Resources {..} <- getResources inst window >>= getOrFail + + shader <- WGPU.createShaderModuleWGSL device "shader" shaderSrc + swapChainFormat <- WGPU.getSwapChainPreferredFormat surface adapter + swapChain <- + WGPU.createSwapChain + device + surface + WGPU.SwapChainDescriptor + { swapChainLabel = "SwapChain", + usage = WGPU.TextureUsageRenderAttachment, + swapChainFormat = swapChainFormat, + width = fromIntegral initWidth, + height = fromIntegral initHeight, + presentMode = WGPU.PresentModeFifo + } + pipelineLayout <- + WGPU.createPipelineLayout + device + (WGPU.PipelineLayoutDescriptor "Pipeline" []) + pipeline <- + WGPU.createRenderPipeline + device + WGPU.RenderPipelineDescriptor + { renderPipelineLabel = "Render Pipeline", + layout = WGPU.SJust pipelineLayout, + vertex = WGPU.VertexState shader "vs_main" [], + primitive = def, + depthStencil = WGPU.SNothing, + multisample = WGPU.MultisampleState 1 0xFFFFFFFF False, + fragment = + WGPU.SJust $ + WGPU.FragmentState + shader + "fs_main" + [ WGPU.ColorTargetState + swapChainFormat + (WGPU.SJust (WGPU.BlendState def def)) + WGPU.colorWriteMaskAll + ] + } + + let loop = do + -- render + nextTexture <- WGPU.getSwapChainCurrentTextureView swapChain + encoder <- WGPU.createCommandEncoder device "Command Encoder" + renderPass <- + WGPU.beginRenderPass + encoder + ( WGPU.RenderPassDescriptor + { renderPassLabel = "Render Pass", + colorAttachments = + [ WGPU.RenderPassColorAttachment + nextTexture + WGPU.SNothing + ( WGPU.Operations + (WGPU.LoadOpClear (WGPU.Color 0 0 0 1)) + WGPU.StoreOpStore + ) + ], + depthStencilAttachment = WGPU.SNothing + } + ) + WGPU.renderPassSetPipeline renderPass pipeline + WGPU.renderPassDraw renderPass (WGPU.Range 0 3) (WGPU.Range 0 1) + WGPU.endRenderPass renderPass + commandBuffer <- WGPU.commandEncoderFinish encoder "Command Buffer" + WGPU.queueSubmit queue [commandBuffer] + WGPU.swapChainPresent swapChain + + -- handle GLFW quit event + GLFW.pollEvents + shouldClose <- GLFW.windowShouldClose window + unless shouldClose loop + + loop + + -- close down GLFW + GLFW.destroyWindow window + GLFW.terminate + +newtype Error = Error Text deriving (Eq, Show) + +getOrFail :: Either Error a -> IO a +getOrFail ma = + case ma of + Right x -> pure x + Left err -> failWith err + +failWith :: Error -> IO a +failWith (Error err) = do + TextIO.putStrLn err + exitFailure + +data Resources = Resources + { surface :: WGPU.Surface, + adapter :: WGPU.Adapter, + device :: WGPU.Device, + queue :: WGPU.Queue + } + +getResources :: WGPU.Instance -> GLFW.Window -> IO (Either Error Resources) +getResources inst window = runExceptT $ do + -- fetch a surface for the window + surface <- lift $ WGPU.createGLFWSurface inst window + -- fetch an adapter for the surface + adapter <- + maybeToExceptT + (Error "Failed to obtain WGPU Adapter") + (MaybeT $ WGPU.requestAdapter surface) + -- fetch a device for the adapter + let deviceDescriptor :: WGPU.DeviceDescriptor + deviceDescriptor = def {WGPU.limits = def {WGPU.maxBindGroups = 1}} + device <- + maybeToExceptT + (Error "Failed to obtain WGPU Device") + (MaybeT $ WGPU.requestDevice adapter deviceDescriptor) + + queue <- lift $ WGPU.getQueue device + + pure Resources {..} + +shaderSrc :: WGPU.WGSL +shaderSrc = + WGPU.WGSL $ + Text.intercalate + "\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);", + "}" + ] diff --git a/src-internal/WGPU/Internal/Adapter.hs b/src-internal/WGPU/Internal/Adapter.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Adapter.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : WGPU.Internal.Adapter +-- Description : Adapter (physical device). +module WGPU.Internal.Adapter + ( -- * Types + Adapter (..), + + -- * Functions + requestAdapter, + ) +where + +import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Foreign (freeHaskellFunPtr, nullPtr) +import Foreign.Ptr (Ptr) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawPtr, showWithPtr) +import WGPU.Internal.Surface (Surface, surfaceInst) +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions + ( WGPURequestAdapterOptions, + ) +import qualified WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions as WGPURequestAdapterOptions +import WGPU.Raw.Types + ( WGPUAdapter (WGPUAdapter), + WGPUInstance (WGPUInstance), + WGPURequestAdapterCallback, + ) + +------------------------------------------------------------------------------- + +-- | Handle to a physical graphics and/or compute device. +-- +-- Request an 'Adapter' for a 'Surface' using the 'requestAdapter' function. +data Adapter = Adapter + { adapterInst :: !Instance, + wgpuAdapter :: !WGPUAdapter + } + +instance Show Adapter where + show a = + let Adapter _ (WGPUAdapter ptr) = a + in showWithPtr "Adapter" ptr + +instance Eq Adapter where + (==) a1 a2 = + let Adapter _ (WGPUAdapter a1_ptr) = a1 + Adapter _ (WGPUAdapter a2_ptr) = a2 + in a1_ptr == a2_ptr + +instance ToRaw Adapter WGPUAdapter where + raw = pure . wgpuAdapter + +------------------------------------------------------------------------------- + +-- | Request an 'Adapter' that is compatible with a given 'Surface'. +-- +-- This action blocks until an available adapter is returned. +requestAdapter :: + -- | Existing surface for which to request an @Adapter@. + Surface -> + -- | The returned @Adapter@, if it could be retrieved. + IO (Maybe Adapter) +requestAdapter surface = evalContT $ do + let inst = surfaceInst surface + + adapterMVar :: MVar WGPUAdapter <- liftIO newEmptyMVar + + let adapterCallback :: WGPUAdapter -> Ptr () -> IO () + adapterCallback adapter _ = putMVar adapterMVar adapter + adapterCallback_c <- liftIO $ mkAdapterCallback adapterCallback + + requestAdapterOptions_ptr <- rawPtr (RequestAdapterOptions surface) + liftIO $ + RawFun.wgpuInstanceRequestAdapter + (wgpuHsInstance inst) + (WGPUInstance nullPtr) + requestAdapterOptions_ptr + adapterCallback_c + nullPtr + + adapter <- liftIO $ takeMVar adapterMVar + liftIO $ freeHaskellFunPtr adapterCallback_c + + pure $ case adapter of + WGPUAdapter ptr | ptr == nullPtr -> Nothing + WGPUAdapter _ -> Just (Adapter inst adapter) + +foreign import ccall "wrapper" + mkAdapterCallback :: + (WGPUAdapter -> Ptr () -> IO ()) -> IO WGPURequestAdapterCallback + +newtype RequestAdapterOptions = RequestAdapterOptions {compatibleSurface :: Surface} + +instance ToRaw RequestAdapterOptions WGPURequestAdapterOptions where + raw RequestAdapterOptions {..} = do + n_surface <- raw compatibleSurface + pure + WGPURequestAdapterOptions.WGPURequestAdapterOptions + { nextInChain = nullPtr, + compatibleSurface = n_surface + } diff --git a/src-internal/WGPU/Internal/Binding.hs b/src-internal/WGPU/Internal/Binding.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Binding.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module : WGPU.Internal.Binding +-- Description : Resource Binding +module WGPU.Internal.Binding + ( -- * Types + BindGroupLayout (..), + BindGroupLayoutDescriptor (..), + BindGroupLayoutEntry (..), + Binding (..), + ShaderStage (..), + BindingType (..), + BufferBindingLayout (..), + SamplerBindingLayout (..), + TextureBindingLayout (..), + StorageTextureBindingLayout (..), + StorageTextureAccess (..), + TextureSampleType (..), + BufferBindingType (..), + + -- * Functions + createBindGroupLayout, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Data.Bits ((.|.)) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Word (Word32, Word64) +import Foreign (nullPtr) +import Foreign.C (CBool (CBool)) +import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawArrayPtr, rawPtr, showWithPtr) +import WGPU.Internal.SMaybe (SMaybe, fromSMaybe) +import WGPU.Internal.Texture (TextureFormat, TextureViewDimension) +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 +import qualified WGPU.Raw.Generated.Enum.WGPUShaderStage as WGPUShaderStage +import WGPU.Raw.Generated.Enum.WGPUStorageTextureAccess (WGPUStorageTextureAccess) +import qualified WGPU.Raw.Generated.Enum.WGPUStorageTextureAccess as WGPUStorageTextureAccess +import qualified WGPU.Raw.Generated.Enum.WGPUTextureFormat as WGPUTextureFormat +import WGPU.Raw.Generated.Enum.WGPUTextureSampleType (WGPUTextureSampleType) +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.WGPUBindGroupLayoutDescriptor (WGPUBindGroupLayoutDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPUBindGroupLayoutDescriptor as WGPUBindGroupLayoutDescriptor +import WGPU.Raw.Generated.Struct.WGPUBindGroupLayoutEntry (WGPUBindGroupLayoutEntry) +import qualified WGPU.Raw.Generated.Struct.WGPUBindGroupLayoutEntry as WGPUBindGroupLayoutEntry +import WGPU.Raw.Generated.Struct.WGPUBufferBindingLayout (WGPUBufferBindingLayout) +import qualified WGPU.Raw.Generated.Struct.WGPUBufferBindingLayout as WGPUBufferBindingLayout +import WGPU.Raw.Generated.Struct.WGPUSamplerBindingLayout (WGPUSamplerBindingLayout) +import qualified WGPU.Raw.Generated.Struct.WGPUSamplerBindingLayout as WGPUSamplerBindingLayout +import WGPU.Raw.Generated.Struct.WGPUStorageTextureBindingLayout (WGPUStorageTextureBindingLayout) +import qualified WGPU.Raw.Generated.Struct.WGPUStorageTextureBindingLayout as WGPUStorageTextureBindingLayout +import WGPU.Raw.Generated.Struct.WGPUTextureBindingLayout (WGPUTextureBindingLayout) +import qualified WGPU.Raw.Generated.Struct.WGPUTextureBindingLayout as WGPUTextureBindingLayout +import WGPU.Raw.Types + ( WGPUBindGroupLayout (WGPUBindGroupLayout), + WGPUShaderStageFlags, + ) + +------------------------------------------------------------------------------- + +-- | Handle to a binding group layout. +-- +-- A @BindGroupLayout@ is a handle to the GPU-side layout of a binding group. +newtype BindGroupLayout = BindGroupLayout {wgpuBindGroupLayout :: WGPUBindGroupLayout} + +instance Show BindGroupLayout where + show b = + let BindGroupLayout (WGPUBindGroupLayout ptr) = b + in showWithPtr "BindGroupLayout" ptr + +instance Eq BindGroupLayout where + (==) b1 b2 = + let BindGroupLayout (WGPUBindGroupLayout b1_ptr) = b1 + BindGroupLayout (WGPUBindGroupLayout b2_ptr) = b2 + in b1_ptr == b2_ptr + +instance ToRaw BindGroupLayout WGPUBindGroupLayout where + raw = pure . wgpuBindGroupLayout + +------------------------------------------------------------------------------- + +-- | Creates a 'BindGroupLayout'. +createBindGroupLayout :: + -- | The device for which the bind group layout will be created. + Device -> + -- | Description of the bind group layout. + BindGroupLayoutDescriptor -> + -- | IO action that creates a bind group layout. + IO BindGroupLayout +createBindGroupLayout device ld = evalContT $ do + let inst :: Instance + inst = deviceInst device + + bindGroupLayoutDescriptor_ptr <- rawPtr ld + rawBindGroupLayout <- + liftIO $ + RawFun.wgpuDeviceCreateBindGroupLayout + (wgpuHsInstance inst) + (wgpuDevice device) + bindGroupLayoutDescriptor_ptr + pure (BindGroupLayout rawBindGroupLayout) + +------------------------------------------------------------------------------- + +-- | Describes a 'BindGroupLayout'. +data BindGroupLayoutDescriptor = BindGroupLayoutDescriptor + { -- | Debug label of the bind group layout. + bindGroupLabel :: !Text, + -- | Sequence of entries in this bind group layout. + entries :: 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 + pure + WGPUBindGroupLayoutDescriptor.WGPUBindGroupLayoutDescriptor + { nextInChain = nullPtr, + label = label_ptr, + entryCount = n_entryCount, + entries = entries_ptr + } + +------------------------------------------------------------------------------- + +-- | Describes a single binding inside a bind group. +data BindGroupLayoutEntry = BindGroupLayoutEntry + { -- | Binding index. Must match a shader index, and be unique inside a + -- bind group layout. + binding :: !Binding, + -- | Which shader stages can see this binding. + visibility :: !ShaderStage, + -- | Type of the binding. + bindGroupLayoutEntryType :: !BindingType + } + deriving (Eq, Show) + +instance ToRaw BindGroupLayoutEntry WGPUBindGroupLayoutEntry where + raw BindGroupLayoutEntry {..} = do + n_binding <- raw binding + n_visibility <- raw visibility + (n_buffer, n_sampler, n_texture, n_storageTexture) <- + case bindGroupLayoutEntryType of + BindingTypeBuffer bbl -> do + nn_buffer <- raw bbl + pure (nn_buffer, noSampler, noTexture, noStorageTexture) + BindingTypeSampler sbl -> do + nn_sampler <- raw sbl + pure (noBuffer, nn_sampler, noTexture, noStorageTexture) + BindingTypeTexture tbl -> do + nn_texture <- raw tbl + pure (noBuffer, noSampler, nn_texture, noStorageTexture) + BindingTypeStorageTexture stbl -> do + nn_storageTexture <- raw stbl + pure (noBuffer, noSampler, noTexture, nn_storageTexture) + pure + WGPUBindGroupLayoutEntry.WGPUBindGroupLayoutEntry + { nextInChain = nullPtr, + binding = n_binding, + visibility = n_visibility, + buffer = n_buffer, + sampler = n_sampler, + texture = n_texture, + storageTexture = n_storageTexture + } + where + noBuffer :: WGPUBufferBindingLayout + noBuffer = + WGPUBufferBindingLayout.WGPUBufferBindingLayout + { nextInChain = nullPtr, + typ = WGPUBufferBindingType.Undefined, + hasDynamicOffset = CBool 0, + minBindingSize = 0 + } + + noSampler :: WGPUSamplerBindingLayout + noSampler = + WGPUSamplerBindingLayout.WGPUSamplerBindingLayout + { nextInChain = nullPtr, + typ = WGPUSamplerBindingType.Undefined + } + + noTexture :: WGPUTextureBindingLayout + noTexture = + WGPUTextureBindingLayout.WGPUTextureBindingLayout + { nextInChain = nullPtr, + sampleType = WGPUTextureSampleType.Undefined, + viewDimension = WGPUTextureViewDimension.Undefined, + multisampled = CBool 0 + } + + noStorageTexture :: WGPUStorageTextureBindingLayout + noStorageTexture = + WGPUStorageTextureBindingLayout.WGPUStorageTextureBindingLayout + { nextInChain = nullPtr, + access = WGPUStorageTextureAccess.Undefined, + format = WGPUTextureFormat.Undefined, + viewDimension = WGPUTextureViewDimension.Undefined + } + +------------------------------------------------------------------------------- + +-- | Binding index. +-- +-- This must match a shader index, and be unique inside a binding group +-- layout. +newtype Binding = Binding {unBinding :: Word32} deriving (Eq, Show) + +instance ToRaw Binding Word32 where + raw = pure . unBinding + +------------------------------------------------------------------------------- + +-- | Describes the shader stages from which a binding will be visible. +data ShaderStage = ShaderStage + { -- | Binding is visible from the vertex shader of a render pipeline. + stageVertex :: !Bool, + -- | Binding is visible from the fragment shader of a render pipeline. + stageFragment :: !Bool, + -- | Binding is visible from the compute shader of a compute pipeline. + stageCompute :: !Bool + } + deriving (Eq, Show) + +instance ToRaw ShaderStage WGPUShaderStageFlags where + raw ShaderStage {..} = + pure $ + (if stageVertex then WGPUShaderStage.Vertex else 0) + .|. (if stageFragment then WGPUShaderStage.Fragment else 0) + .|. (if stageCompute then WGPUShaderStage.Compute else 0) + +------------------------------------------------------------------------------- + +-- | Specifies type of a binding. +data BindingType + = -- | A buffer binding. + BindingTypeBuffer !BufferBindingLayout + | -- | A sampler that can be used to sample a texture. + BindingTypeSampler !SamplerBindingLayout + | -- | A texture binding. + BindingTypeTexture !TextureBindingLayout + | -- | A storage texture. + BindingTypeStorageTexture !StorageTextureBindingLayout + deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- | A buffer binding. +data BufferBindingLayout = BufferBindingLayout + { -- | Sub-type of the buffer binding. + bindingBufferLayoutType :: !BufferBindingType, + -- | Indicates that the binding has a dynamic offset. One offset must be + -- passed when setting the bind group in the render pass. + hasDynamicOffset :: !Bool, + -- | Minimum size of a corresponding buffer binding required to match this + -- entry. + minBindingSize :: !(SMaybe Word64) + } + deriving (Eq, Show) + +instance ToRaw BufferBindingLayout WGPUBufferBindingLayout where + raw BufferBindingLayout {..} = do + n_typ <- raw bindingBufferLayoutType + n_hasDynamicOffset <- raw hasDynamicOffset + pure + WGPUBufferBindingLayout.WGPUBufferBindingLayout + { nextInChain = nullPtr, + typ = n_typ, + hasDynamicOffset = n_hasDynamicOffset, + minBindingSize = fromSMaybe 0 minBindingSize + } + +------------------------------------------------------------------------------- + +-- | A sampler binding that can be used to sample a texture. +data SamplerBindingLayout + = SamplerBindingLayoutFiltering + | SamplerBindingLayoutNonFiltering + | SamplerBindingLayoutComparison + deriving (Eq, Show) + +instance ToRaw SamplerBindingLayout WGPUSamplerBindingLayout where + raw sbl = + pure $ + WGPUSamplerBindingLayout.WGPUSamplerBindingLayout + { nextInChain = nullPtr, + typ = + case sbl of + SamplerBindingLayoutFiltering -> + WGPUSamplerBindingType.Filtering + SamplerBindingLayoutNonFiltering -> + WGPUSamplerBindingType.NonFiltering + SamplerBindingLayoutComparison -> + WGPUSamplerBindingType.Comparison + } + +------------------------------------------------------------------------------- + +-- | A texture binding. +data TextureBindingLayout = TextureBindingLayout + { -- | Sample type of the texture binding. + sampleType :: !TextureSampleType, + -- | Dimension of the texture view that is going to be sampled. + textureViewDimension :: !TextureViewDimension, + -- | True if the texture has a sample count greater than 1. + multiSampled :: !Bool + } + deriving (Eq, Show) + +instance ToRaw TextureBindingLayout WGPUTextureBindingLayout where + raw TextureBindingLayout {..} = do + n_sampleType <- raw sampleType + n_viewDimension <- raw textureViewDimension + n_multisampled <- raw multiSampled + pure + WGPUTextureBindingLayout.WGPUTextureBindingLayout + { nextInChain = nullPtr, + sampleType = n_sampleType, + viewDimension = n_viewDimension, + multisampled = n_multisampled + } + +------------------------------------------------------------------------------- + +-- | A storage texture binding. +data StorageTextureBindingLayout = StorageTextureBindingLayout + { -- | Permitted access to this texture. + access :: !StorageTextureAccess, + -- | Format of the texture. + storageTextureFormat :: !TextureFormat, + -- | Dimension of the texture view that is going to be sampled. + storageTextureViewDimension :: !TextureViewDimension + } + deriving (Eq, Show) + +instance ToRaw StorageTextureBindingLayout WGPUStorageTextureBindingLayout where + raw StorageTextureBindingLayout {..} = do + n_access <- raw access + n_format <- raw storageTextureFormat + n_viewDimension <- raw storageTextureViewDimension + pure + WGPUStorageTextureBindingLayout.WGPUStorageTextureBindingLayout + { nextInChain = nullPtr, + access = n_access, + format = n_format, + viewDimension = n_viewDimension + } + +------------------------------------------------------------------------------- + +-- | Specific method of allowed access to a storage texture. +data StorageTextureAccess + = StorageTextureAccessReadOnly + | StorageTextureAccessWriteOnly + | StorageTextureAccessReadWrite + deriving (Eq, Show) + +instance ToRaw StorageTextureAccess WGPUStorageTextureAccess where + raw sta = + pure $ + case sta of + StorageTextureAccessReadOnly -> WGPUStorageTextureAccess.ReadOnly + StorageTextureAccessWriteOnly -> WGPUStorageTextureAccess.WriteOnly + StorageTextureAccessReadWrite -> WGPUStorageTextureAccess.Undefined -- ? + +------------------------------------------------------------------------------- + +-- | Specific type of a sample in a texture binding. +data TextureSampleType + = TextureSampleTypeFloat {filterable :: !Bool} + | TextureSampleTypeDepth + | TextureSampleTypeSignedInt + | TextureSampleTypeUnsignedInt + deriving (Eq, Show) + +instance ToRaw TextureSampleType WGPUTextureSampleType where + raw tt = + pure $ + case tt of + TextureSampleTypeFloat False -> WGPUTextureSampleType.UnfilterableFloat + TextureSampleTypeFloat True -> WGPUTextureSampleType.Float + TextureSampleTypeDepth -> WGPUTextureSampleType.Depth + TextureSampleTypeSignedInt -> WGPUTextureSampleType.Sint + TextureSampleTypeUnsignedInt -> WGPUTextureSampleType.Uint + +------------------------------------------------------------------------------- + +-- | Specific type of a buffer binding. +data BufferBindingType + = Uniform + | Storage {readOnly :: !Bool} + deriving (Eq, Show) + +instance ToRaw BufferBindingType WGPUBufferBindingType where + raw bt = + pure $ + case bt of + Uniform -> WGPUBufferBindingType.Uniform + Storage False -> WGPUBufferBindingType.Storage + Storage True -> WGPUBufferBindingType.ReadOnlyStorage diff --git a/src-internal/WGPU/Internal/ChainedStruct.hs b/src-internal/WGPU/Internal/ChainedStruct.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/ChainedStruct.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +module WGPU.Internal.ChainedStruct + ( -- * Types + ChainedStruct (..), + ) +where + +import Foreign (Ptr, castPtr, nullPtr) +import WGPU.Internal.Memory (ToRaw, raw) +import WGPU.Raw.Generated.Enum.WGPUSType (WGPUSType) +import WGPU.Raw.Generated.Struct.WGPUChainedStruct (WGPUChainedStruct) +import qualified WGPU.Raw.Generated.Struct.WGPUChainedStruct as WGPUChainedStruct + +-- | Represents a chained structure. +data ChainedStruct a + = -- | Empty chained structure, but with a type tag. + EmptyChain WGPUSType + | -- | Chained structue that points to the next structure in a chain. + PtrChain WGPUSType (Ptr a) + +instance ToRaw (ChainedStruct a) WGPUChainedStruct where + raw chainedStruct = + case chainedStruct of + EmptyChain sType -> + pure + WGPUChainedStruct.WGPUChainedStruct + { next = nullPtr, + sType = sType + } + PtrChain sType ptr -> + pure + WGPUChainedStruct.WGPUChainedStruct + { next = castPtr ptr, + sType = sType + } diff --git a/src-internal/WGPU/Internal/Color.hs b/src-internal/WGPU/Internal/Color.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Color.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.Color +-- Description : Color. +module WGPU.Internal.Color + ( -- * Types + Color (..), + + -- * Functions + transparentBlack, + ) +where + +import Foreign.C (CDouble (CDouble)) +import WGPU.Internal.Memory (ToRaw, raw) +import WGPU.Raw.Generated.Struct.WGPUColor (WGPUColor) +import qualified WGPU.Raw.Generated.Struct.WGPUColor as WGPUColor + +-- | RGBA double-precision color. +data Color = Color + { red :: Double, + green :: Double, + blue :: Double, + alpha :: Double + } + deriving (Eq, Show) + +transparentBlack :: Color +transparentBlack = Color 0 0 0 0 + +instance ToRaw Color WGPUColor where + raw Color {..} = + pure $ + WGPUColor.WGPUColor + (CDouble red) + (CDouble green) + (CDouble blue) + (CDouble alpha) diff --git a/src-internal/WGPU/Internal/CommandBuffer.hs b/src-internal/WGPU/Internal/CommandBuffer.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/CommandBuffer.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : WGPU.Internal.CommandBuffer +-- Description : Command buffers. +module WGPU.Internal.CommandBuffer + ( -- * Types + CommandBuffer (..), + ) +where + +import WGPU.Internal.Memory (ToRaw, raw, showWithPtr) +import WGPU.Raw.Types (WGPUCommandBuffer (WGPUCommandBuffer)) + +------------------------------------------------------------------------------- + +newtype CommandBuffer = CommandBuffer {wgpuCommandBuffer :: WGPUCommandBuffer} + +instance Show CommandBuffer where + show b = + let CommandBuffer (WGPUCommandBuffer ptr) = b + in showWithPtr "CommandBuffer" ptr + +instance Eq CommandBuffer where + (==) b1 b2 = + let CommandBuffer (WGPUCommandBuffer b1_ptr) = b1 + CommandBuffer (WGPUCommandBuffer b2_ptr) = b2 + in b1_ptr == b2_ptr + +instance ToRaw CommandBuffer WGPUCommandBuffer where + raw = pure . wgpuCommandBuffer diff --git a/src-internal/WGPU/Internal/CommandEncoder.hs b/src-internal/WGPU/Internal/CommandEncoder.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/CommandEncoder.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.CommandEncoder +-- Description : Command encoding. +module WGPU.Internal.CommandEncoder + ( -- * Types + CommandEncoder (..), + + -- * Functions + createCommandEncoder, + commandEncoderFinish, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (ContT (ContT), evalContT) +import Data.Text (Text) +import Foreign (nullPtr, with) +import WGPU.Internal.CommandBuffer (CommandBuffer (CommandBuffer)) +import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawPtr, showWithPtr) +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Generated.Struct.WGPUCommandBufferDescriptor (WGPUCommandBufferDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPUCommandBufferDescriptor as WGPUCommandBufferDescriptor +import qualified WGPU.Raw.Generated.Struct.WGPUCommandEncoderDescriptor as WGPUCommandEncoderDescriptor +import WGPU.Raw.Types (WGPUCommandEncoder (WGPUCommandEncoder)) + +------------------------------------------------------------------------------- + +-- | Handle to an encoder for a series of GPU operations. +-- +-- A command encoder can record render passes, compute passes, and transfer +-- operations between driver-managed resources like buffers and textures. +data CommandEncoder = CommandEncoder + { commandEncoderInst :: !Instance, + wgpuCommandEncoder :: !WGPUCommandEncoder + } + +instance Show CommandEncoder where + show e = + let CommandEncoder _ (WGPUCommandEncoder ptr) = e + in showWithPtr "CommandEncoder" ptr + +instance Eq CommandEncoder where + (==) e1 e2 = + let CommandEncoder _ (WGPUCommandEncoder e1_ptr) = e1 + CommandEncoder _ (WGPUCommandEncoder e2_ptr) = e2 + in e1_ptr == e2_ptr + +instance ToRaw CommandEncoder WGPUCommandEncoder where + raw = pure . wgpuCommandEncoder + +------------------------------------------------------------------------------- + +-- | Create an empty command encoder. +createCommandEncoder :: + -- | Device for which to create the command encoder. + Device -> + -- | Debug label for the command encoder. + Text -> + -- | IO action that returns the command encoder. + IO CommandEncoder +createCommandEncoder device label = evalContT $ do + let inst = deviceInst device + label_ptr <- rawPtr label + commandEncoderDescriptor_ptr <- + ContT . with $ + WGPUCommandEncoderDescriptor.WGPUCommandEncoderDescriptor + { nextInChain = nullPtr, + label = label_ptr + } + commandEncoderRaw <- + liftIO $ + RawFun.wgpuDeviceCreateCommandEncoder + (wgpuHsInstance inst) + (wgpuDevice device) + commandEncoderDescriptor_ptr + pure (CommandEncoder inst commandEncoderRaw) + +-- | Finish encoding commands, returning a command buffer. +commandEncoderFinish :: + -- | Command encoder to finish. + CommandEncoder -> + -- | Debugging label for the command buffer. + Text -> + -- | IO action which returns the command buffer. + IO CommandBuffer +commandEncoderFinish commandEncoder label = evalContT $ do + let inst = commandEncoderInst commandEncoder + commandBufferDescriptor_ptr <- rawPtr $ CommandBufferDescriptor label + commandBufferRaw <- + liftIO $ + RawFun.wgpuCommandEncoderFinish + (wgpuHsInstance inst) + (wgpuCommandEncoder commandEncoder) + commandBufferDescriptor_ptr + pure (CommandBuffer commandBufferRaw) + +------------------------------------------------------------------------------- + +newtype CommandBufferDescriptor = CommandBufferDescriptor + {commandBufferLabel :: Text} + deriving (Eq, Show) + +instance ToRaw CommandBufferDescriptor WGPUCommandBufferDescriptor where + raw CommandBufferDescriptor {..} = do + label_ptr <- rawPtr commandBufferLabel + pure + WGPUCommandBufferDescriptor.WGPUCommandBufferDescriptor + { nextInChain = nullPtr, + label = label_ptr + } diff --git a/src-internal/WGPU/Internal/Device.hs b/src-internal/WGPU/Internal/Device.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Device.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} + +-- | +-- Module : WGPU.Internal.Device. +-- Description : Device (open connection to a device). +module WGPU.Internal.Device + ( -- * Types + Device (..), + DeviceDescriptor (..), + Features (..), + Limits (..), + + -- * Functions + requestDevice, + ) +where + +import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (ContT (ContT), evalContT) +import Data.Default (Default, def) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word (Word32) +import Foreign (Ptr, freeHaskellFunPtr, nullPtr, with) +import WGPU.Internal.Adapter (Adapter, adapterInst, wgpuAdapter) +import WGPU.Internal.ChainedStruct (ChainedStruct (EmptyChain, PtrChain)) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawPtr, showWithPtr) +import WGPU.Raw.Generated.Enum.WGPUNativeFeature (WGPUNativeFeature) +import qualified WGPU.Raw.Generated.Enum.WGPUNativeFeature as WGPUNativeFeature +import qualified WGPU.Raw.Generated.Enum.WGPUNativeSType as WGPUSType +import qualified WGPU.Raw.Generated.Fun as RawFun +import qualified WGPU.Raw.Generated.Struct.WGPUDeviceDescriptor as WGPUDeviceDescriptor +import WGPU.Raw.Generated.Struct.WGPUDeviceExtras (WGPUDeviceExtras) +import qualified WGPU.Raw.Generated.Struct.WGPUDeviceExtras as WGPUDeviceExtras +import WGPU.Raw.Types (WGPUDevice (WGPUDevice), WGPURequestDeviceCallback) + +------------------------------------------------------------------------------- + +-- | An open connection to a graphics and/or compute device. +-- +-- A 'Device' may be created using the 'requestDevice' function. +data Device = Device + { deviceInst :: !Instance, + wgpuDevice :: !WGPUDevice + } + +instance Show Device where + show d = + let Device _ (WGPUDevice ptr) = d + in showWithPtr "Device" ptr + +instance Eq Device where + (==) d1 d2 = + let Device _ (WGPUDevice d1_ptr) = d1 + Device _ (WGPUDevice d2_ptr) = d2 + in d1_ptr == d2_ptr + +instance ToRaw Device WGPUDevice where + raw = pure . wgpuDevice + +------------------------------------------------------------------------------- + +-- | Device features that are not guaranteed to be supported. +-- +-- * NOTE: The Rust API currently has far more extensive @Features@. Perhaps +-- they have not yet been ported to the C API? +-- +newtype Features = Features + { textureAdapterSpecificFormatFeatures :: Bool + } + deriving (Eq, Show) + +instance Default Features where + def = + Features + { textureAdapterSpecificFormatFeatures = False + } + +instance ToRaw Features WGPUNativeFeature where + raw Features {..} = + pure $ + if textureAdapterSpecificFormatFeatures + then WGPUNativeFeature.TEXTURE_ADAPTER_SPECIFIC_FORMAT_FEATURES + else 0 + +------------------------------------------------------------------------------- + +-- | Device limits. +-- +-- Represents the set of limits an adapter/device supports. +data Limits = Limits + { -- | Maximum allowed value for the width of a 1D texture. + maxTextureDimension1D :: !Word32, + -- | Maximum allowed value for the width and height of a 2D texture. + maxTextureDimension2D :: !Word32, + -- | Maximum allowed value for the width, height or depth of a 3D texture. + maxTextureDimension3D :: !Word32, + -- | Maximum allowed value for the array layers of a texture. + maxTextureArrayLayers :: !Word32, + -- | Amount of bind groups that can be attached to a pipeline at the same + -- time. + maxBindGroups :: !Word32, + -- | Amount of storage buffer bindings that can be dynamic in a single + -- pipeline. + maxDynamicStorageBuffersPerPipelineLayout :: !Word32, + -- | Amount of sampled textures visible in a single shader stage. + maxStorageBuffersPerShaderStage :: !Word32, + -- | Maximum size in bytes of a binding to a uniform buffer. + maxStorageBufferBindingSize :: !Word32 + } + deriving (Eq, Show) + +instance Default Limits where + def = + Limits + { maxTextureDimension1D = 0, + maxTextureDimension2D = 0, + maxTextureDimension3D = 0, + maxTextureArrayLayers = 0, + maxBindGroups = 0, + maxDynamicStorageBuffersPerPipelineLayout = 0, + maxStorageBuffersPerShaderStage = 0, + maxStorageBufferBindingSize = 0 + } + +------------------------------------------------------------------------------- + +-- | Describes a 'Device'. +data DeviceDescriptor = DeviceDescriptor + { -- | Debug label for the device. + deviceLabel :: !Text, + -- | Features that the device should support. + features :: !Features, + -- | Limits that the device should support (minimum values). + limits :: !Limits + } + deriving (Eq, Show) + +instance Default DeviceDescriptor where + def = + DeviceDescriptor + { deviceLabel = Text.empty, + features = def, + limits = def + } + +instance ToRaw DeviceDescriptor WGPUDeviceExtras where + raw DeviceDescriptor {..} = do + chain_ptr <- raw (EmptyChain WGPUSType.DeviceExtras) + label_ptr <- rawPtr deviceLabel + n_nativeFeatures <- raw features + pure + WGPUDeviceExtras.WGPUDeviceExtras + { chain = chain_ptr, + maxTextureDimension1D = maxTextureDimension1D limits, + maxTextureDimension2D = maxTextureDimension2D limits, + maxTextureDimension3D = maxTextureDimension3D limits, + maxTextureArrayLayers = maxTextureArrayLayers limits, + maxBindGroups = maxBindGroups limits, + maxDynamicStorageBuffersPerPipelineLayout = + maxDynamicStorageBuffersPerPipelineLayout limits, + maxStorageBuffersPerShaderStage = + maxStorageBuffersPerShaderStage limits, + maxStorageBufferBindingSize = + maxStorageBufferBindingSize limits, + nativeFeatures = n_nativeFeatures, + label = label_ptr, + tracePath = nullPtr + } + +-- | Requests a connection to a physical device, creating a logical device. +-- +-- This action blocks until an available device is returned. +requestDevice :: + -- | @Adapter@ for which the device will be returned. + Adapter -> + -- | The features and limits requested for the device. + DeviceDescriptor -> + -- | The returned @Device@, if it could be retrieved. + IO (Maybe Device) +requestDevice adapter deviceDescriptor = evalContT $ do + let inst = adapterInst adapter + + deviceMVar :: MVar WGPUDevice <- liftIO newEmptyMVar + + let deviceCallback :: WGPUDevice -> Ptr () -> IO () + deviceCallback device _ = putMVar deviceMVar device + deviceCallback_c <- liftIO $ mkDeviceCallback deviceCallback + + deviceExtras_ptr <- rawPtr deviceDescriptor + nextInChain_ptr <- rawPtr (PtrChain WGPUSType.DeviceExtras deviceExtras_ptr) + deviceDescriptor_ptr <- + ContT . with $ + WGPUDeviceDescriptor.WGPUDeviceDescriptor + { nextInChain = nextInChain_ptr + } + + liftIO $ + RawFun.wgpuAdapterRequestDevice + (wgpuHsInstance inst) + (wgpuAdapter adapter) + deviceDescriptor_ptr + deviceCallback_c + nullPtr + + device <- liftIO $ takeMVar deviceMVar + liftIO $ freeHaskellFunPtr deviceCallback_c + + pure $ case device of + WGPUDevice ptr | ptr == nullPtr -> Nothing + WGPUDevice _ -> Just (Device inst device) + +foreign import ccall "wrapper" + mkDeviceCallback :: + (WGPUDevice -> Ptr () -> IO ()) -> IO WGPURequestDeviceCallback diff --git a/src-internal/WGPU/Internal/Instance.hs b/src-internal/WGPU/Internal/Instance.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Instance.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.Instance +-- Description : Instance. +-- +-- Instance of the WGPU API Haskell bindings. +module WGPU.Internal.Instance + ( -- * Instance + + -- + -- $instance + Instance (..), + withInstance, + + -- * Logging + LogCallback, + LogLevel (..), + setLogLevel, + logLevelToText, + logStdout, + + -- * Version + Version (..), + getVersion, + versionToText, + ) +where + +import Data.Bits (shiftR, (.&.)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import Data.Word (Word32, Word8) +import Foreign (Ptr, freeHaskellFunPtr, nullFunPtr) +import Foreign.C (CChar, peekCString) +import WGPU.Internal.Memory (ToRaw, raw) +import WGPU.Raw.Dynamic (withWGPU) +import WGPU.Raw.Generated.Enum.WGPULogLevel (WGPULogLevel (WGPULogLevel)) +import qualified WGPU.Raw.Generated.Enum.WGPULogLevel as WGPULogLevel +import WGPU.Raw.Generated.Fun (WGPUHsInstance) +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Types (WGPULogCallback) + +-- $instance +-- +-- The Haskell bindings to WGPU use a value of type 'Instance' as a handle to +-- the rest of the API. An 'Instance' value is obtained by loading a dynamic +-- library at runtime, using the 'withInstance' function. A typical invocation +-- might look like this: +-- +-- @ +-- 'withInstance' "libwgpu_native.dylib" (Just 'logStdOut') $ \inst -> do +-- -- set the logging level for the instance +-- 'setLogLevel' inst 'Warn' +-- -- run the rest of the program ... +-- @ +-- +-- The dynamic library @libwgpu_native.dylib@ is obtained by compiling the +-- Rust project . Care +-- should be take to compile a version of @libwgpu_native.dylib@ which is +-- compatible with the API in these bindings. + +------------------------------------------------------------------------------- + +-- | Instance of the WGPU API. +-- +-- An instance is loaded from a dynamic library using the 'withInstance' +-- function. +newtype Instance = Instance {wgpuHsInstance :: WGPUHsInstance} + +instance Show Instance where show _ = "" + +instance ToRaw Instance WGPUHsInstance where + raw = pure . wgpuHsInstance + +------------------------------------------------------------------------------- + +-- | Logging level. +data LogLevel + = Trace + | Debug + | Info + | Warn + | Error + deriving (Eq, Show) + +-- | Logging callback function. +type LogCallback = LogLevel -> Text -> IO () + +-- | Load the WGPU API from a dynamic library and supply an 'Instance' to a +-- program. +withInstance :: + -- | Name of the @wgpu-native@ dynamic library, or a complete path to it. + FilePath -> + -- | Optional logging callback. @'Just' 'logStdout'@ can be supplied here to + -- print log messages to @stdout@ for debugging purposes. + Maybe LogCallback -> + -- | The Program. A function which takes an 'Instance' and returns an IO + -- action that uses the instance. + (Instance -> IO a) -> + -- | IO action which loads the WGPU 'Instance', passes it to the program, and + -- returns the result of running the program. + IO a +withInstance dylibPath mLog program = + withWGPU dylibPath $ + \winst -> do + -- create the logging callback if necessary + logCallback_c <- case mLog of + Nothing -> pure nullFunPtr + Just logFn -> mkLogCallback . toRawLogCallback $ logFn + RawFun.wgpuSetLogCallback winst logCallback_c + + -- run the program + result <- program (Instance winst) + + -- free the logging callback + case mLog of + Nothing -> pure () + Just _ -> do + RawFun.wgpuSetLogCallback winst nullFunPtr + freeHaskellFunPtr logCallback_c + + pure result + +-- | Set the current logging level for the instance. +setLogLevel :: Instance -> LogLevel -> IO () +setLogLevel inst lvl = + RawFun.wgpuSetLogLevel (wgpuHsInstance inst) (logLevelToWLogLevel lvl) + +-- | Create a C callback from a Haskell logging function. +foreign import ccall "wrapper" + mkLogCallback :: + (WGPULogLevel -> Ptr CChar -> IO ()) -> + IO WGPULogCallback + +-- | Convert a logging callback function to the form required by the Raw API. +toRawLogCallback :: LogCallback -> (WGPULogLevel -> Ptr CChar -> IO ()) +toRawLogCallback logFn wLogLevel cMsg = do + msg <- Text.pack <$> peekCString cMsg + logFn (wLogLevelToLogLevel wLogLevel) msg + +-- | Convert a raw API logging level into a 'LogLevel'. +-- +-- Any unknown log levels become an 'Error'. +wLogLevelToLogLevel :: WGPULogLevel -> LogLevel +wLogLevelToLogLevel wLvl = + case wLvl of + WGPULogLevel.Trace -> Trace + WGPULogLevel.Debug -> Debug + WGPULogLevel.Info -> Info + WGPULogLevel.Warn -> Warn + WGPULogLevel.Error -> Error + _ -> Error + +-- | Convert a 'LogLevel' value into the type required by the raw API. +logLevelToWLogLevel :: LogLevel -> WGPULogLevel +logLevelToWLogLevel lvl = + case lvl of + Trace -> WGPULogLevel.Trace + Debug -> WGPULogLevel.Debug + Info -> WGPULogLevel.Info + Warn -> WGPULogLevel.Warn + Error -> WGPULogLevel.Error + +-- | Convert a 'LogLevel' to a text string. +logLevelToText :: LogLevel -> Text +logLevelToText lvl = + case lvl of + Trace -> "Trace" + Debug -> "Debug" + Info -> "Info" + Warn -> "Warn" + Error -> "Error" + +-- | A logging function which prints to @stdout@. +-- +-- This logging function can be supplied to 'withInstance' to print logging +-- messages to @stdout@ for debugging purposes. +logStdout :: LogLevel -> Text -> IO () +logStdout lvl msg = TextIO.putStrLn $ "[" <> logLevelToText lvl <> "]: " <> msg + +------------------------------------------------------------------------------- + +-- | Version of WGPU native. +data Version = Version + { major :: !Word8, + minor :: !Word8, + patch :: !Word8, + subPatch :: !Word8 + } + deriving (Eq, Show) + +-- | Return the exact version of the WGPU native instance. +getVersion :: Instance -> IO Version +getVersion inst = w32ToVersion <$> RawFun.wgpuGetVersion (wgpuHsInstance inst) + where + w32ToVersion :: Word32 -> Version + w32ToVersion w = + let major = fromIntegral $ (w `shiftR` 24) .&. 0xFF + minor = fromIntegral $ (w `shiftR` 16) .&. 0xFF + patch = fromIntegral $ (w `shiftR` 8) .&. 0xFF + subPatch = fromIntegral $ w .&. 0xFF + in Version {..} + +-- | Convert a 'Version' value to a text string. +-- +-- >>> versionToText (Version 0 9 2 2) +-- "v0.9.2.2" +versionToText :: Version -> Text +versionToText ver = + "" <> showt (major ver) + <> "." + <> showt (minor ver) + <> "." + <> showt (patch ver) + <> "." + <> showt (subPatch ver) + +-- | Show a value as a 'Text' string. +showt :: Show a => a -> Text +showt = Text.pack . show diff --git a/src-internal/WGPU/Internal/Memory.hs b/src-internal/WGPU/Internal/Memory.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Memory.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : WGPU.Internal.Memory +-- Description : Managing memory. +-- +-- This module contains type classes used to manage marshalling of objects into +-- memory before calling C functions. +-- +-- = Motivation +-- +-- In many locations in the API, we have: +-- +-- A type (example only) which contains a nice Haskell representation of +-- some data: +-- +-- @ +-- data ApiType = ApiType { things :: Vector Thing } +-- @ +-- +-- and a raw type which is required for a C function: +-- +-- @ +-- data WGPUApiType = WGPUApiType +-- { thingsCount :: 'Word8', -- this is an array length +-- things :: 'Ptr' WGPUApiThing -- this is a pointer to an array +-- } +-- @ +-- +-- This type class constraint represents the ability to encode @ApiType@ as +-- @WGPUApiType@, performing any necessary memory allocation and freeing: +-- +-- @ +-- 'ToRaw' ApiType WGPUApiType +-- @ +-- +-- 'ToRaw' uses the 'ContT' monad so that bracketing of the memory resources +-- can be performed around some continuation that uses the memory. +-- +-- In the example above, we could write a 'ToRaw' instance as follows: +-- +-- @ +-- instance 'ToRaw' ApiType WGPUApiType where +-- 'raw' ApiType{..} = do +-- names_ptr <- 'rawArrayPtr' names +-- 'pure' $ WGPUApiType +-- { namesCount = fromIntegral . length $ names, +-- names = names_ptr +-- } +-- @ +-- +-- The 'ToRawPtr' type class represents similar functionality, except that it +-- creates a pointer to a value. Thus it does both raw conversion and storing +-- the raw value in allocated memory. It exists as a separate type class so +-- that library types (eg. 'Text' and 'ByteString') can be marshalled into +-- pointers more easily. +module WGPU.Internal.Memory + ( -- * Classes + ToRaw (raw), + ToRawPtr (rawPtr), + + -- * Functions + rawArrayPtr, + showWithPtr, + ) +where + +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (ContT (ContT), evalContT) +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCString) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector.Generic (Vector) +import qualified Data.Vector.Generic as Vector +import Data.Word (Word8) +import Foreign + ( Ptr, + Storable, + advancePtr, + allocaArray, + castPtr, + fillBytes, + poke, + sizeOf, + with, + ) +import Foreign.C (CBool, CChar, withCString) + +------------------------------------------------------------------------------- +-- Type Classes + +-- | Represents a value of type @a@ that can be stored as type @b@ in the +-- 'ContT' monad. +-- +-- Implementations of this type class should bracket any resource management for +-- creating the @b@ value around the continuation. For example. memory to hold +-- elements of @b@ should be allocated and freed in a bracketed fashion. +class ToRaw a b | a -> b where + -- | Convert a value to a raw representation, bracketing any resource + -- management. + raw :: a -> ContT c IO b + +-- | Represents a value of type @a@ that can be stored as type @(Ptr b)@ in the +-- 'ContT' monad. +-- +-- Implementations of this type class should bracket resource management for +-- creating @('Ptr' b)@ around the continuation. In particular, the memory +-- allocated for @('Ptr' b)@ must be allocated before the continuation is +-- called, and freed afterward. +class ToRawPtr a b where + rawPtr :: a -> ContT c IO (Ptr b) + +------------------------------------------------------------------------------- +-- Derived Functionality + +-- | Return a pointer to an allocated array, populated with raw values from a +-- vector. +rawArrayPtr :: + forall v a b c. + (ToRaw a b, Storable b, Vector v a) => + -- | Vector of values to store in a C array. + v a -> + -- | Pointer to the array with raw values stored in it. + ContT c IO (Ptr b) +rawArrayPtr xs = + ContT $ \action -> do + let n :: Int + n = Vector.length xs + allocaArray n $ \arrayPtr -> + evalContT $ do + forM_ + (zip (Vector.toList xs) [0 ..]) + (\(x, i) -> pokeRaw x (advancePtr arrayPtr i)) + liftIO (action arrayPtr) + where + pokeRaw :: a -> Ptr b -> ContT c IO () + pokeRaw value raw_ptr = raw value >>= liftIO . poke raw_ptr + +------------------------------------------------------------------------------- +-- Instances + +-- Allow every ToRaw instance to be a ToRawPtr instance. +instance {-# OVERLAPPABLE #-} (Storable b, ToRaw a b) => ToRawPtr a b where + rawPtr x = do + rawX <- raw x + ContT $ zeroingWith rawX + +instance ToRaw Bool CBool where raw x = pure (if x then 1 else 0) + +instance ToRawPtr Text CChar where rawPtr = ContT . withCString . Text.unpack + +instance ToRawPtr ByteString Word8 where + rawPtr byteString = + ContT $ \action -> unsafeUseAsCString byteString (action . castPtr) + +------------------------------------------------------------------------------- +-- Utils + +-- | Like 'with', but zeroes memory after the action has been performed. +-- +-- Allocates memory for a value of type @a@ and fills the memory with the +-- 'Foreign.Storable' representation of the @a@ value. +zeroingWith :: + Storable a => + -- | Value to use. + a -> + -- | Action to perform with a pointer to the value. + (Ptr a -> IO b) -> + -- | Result of running the action. + IO b +zeroingWith value action = + with value $ \value_ptr -> do + result <- action value_ptr + fillBytes value_ptr 0x00 (sizeOf value) + pure result + +-- | Formatter for 'Show' instances for opaque pointers. +-- +-- Displays a name and a corresponding opaque pointer. +showWithPtr :: + -- | Name of the type. + String -> + -- | Opaque pointer that the type contains. + Ptr a -> + -- | Final show string. + String +showWithPtr name ptr = "<" <> name <> ":" <> show ptr <> ">" diff --git a/src-internal/WGPU/Internal/Multipurpose.hs b/src-internal/WGPU/Internal/Multipurpose.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Multipurpose.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : WGPU.Internal.Multipurpose +-- Description : Multipurpose +-- +-- This is a bit like a "Types" module. It exists to collect things which are +-- somewhat generic and are used in more than one part of the API. +module WGPU.Internal.Multipurpose + ( -- * Types + CompareFunction (..), + ) +where + +import WGPU.Internal.Memory (ToRaw, raw) +import WGPU.Raw.Generated.Enum.WGPUCompareFunction (WGPUCompareFunction) +import qualified WGPU.Raw.Generated.Enum.WGPUCompareFunction as WGPUCompareFunction + +------------------------------------------------------------------------------- + +-- | Comparison function used for depth and stencil operations. +data CompareFunction + = CompareFunctionNever + | CompareFunctionLess + | CompareFunctionEqual + | CompareFunctionLessEqual + | CompareFunctionGreater + | CompareFunctionNotEqual + | CompareFunctionGreaterEqual + | CompareFunctionAlways + deriving (Eq, Show) + +-- | Convert a 'CompareFunction' to its raw value. +instance ToRaw CompareFunction WGPUCompareFunction where + raw cf = + pure $ + case cf of + CompareFunctionNever -> WGPUCompareFunction.Never + CompareFunctionLess -> WGPUCompareFunction.Less + CompareFunctionEqual -> WGPUCompareFunction.Equal + CompareFunctionLessEqual -> WGPUCompareFunction.LessEqual + CompareFunctionGreater -> WGPUCompareFunction.Greater + CompareFunctionNotEqual -> WGPUCompareFunction.NotEqual + CompareFunctionGreaterEqual -> WGPUCompareFunction.GreaterEqual + CompareFunctionAlways -> WGPUCompareFunction.Always diff --git a/src-internal/WGPU/Internal/Pipeline.hs b/src-internal/WGPU/Internal/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Pipeline.hs @@ -0,0 +1,897 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.Pipeline +-- Description : Pipelines. +module WGPU.Internal.Pipeline + ( -- * Types + PipelineLayout (..), + PipelineLayoutDescriptor (..), + VertexFormat (..), + VertexAttribute (..), + InputStepMode (..), + VertexBufferLayout (..), + VertexState (..), + PrimitiveTopology (..), + IndexFormat (..), + FrontFace (..), + CullMode (..), + PrimitiveState (..), + StencilOperation (..), + StencilFaceState (..), + StencilState (..), + DepthBiasState (..), + DepthStencilState (..), + MultisampleState (..), + BlendFactor (..), + BlendOperation (..), + BlendComponent (..), + BlendState (..), + ColorWriteMask (..), + ColorTargetState (..), + FragmentState (..), + RenderPipelineDescriptor (..), + + -- * Functions + createPipelineLayout, + createRenderPipeline, + colorWriteMaskAll, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Data.Bits ((.|.)) +import Data.Default (Default, def) +import Data.Int (Int32) +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Word (Word32, Word64, Word8) +import Foreign (nullPtr) +import Foreign.C (CFloat (CFloat)) +import WGPU.Internal.Binding (BindGroupLayout) +import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawArrayPtr, rawPtr, showWithPtr) +import WGPU.Internal.Multipurpose (CompareFunction) +import WGPU.Internal.RenderPass (RenderPipeline (RenderPipeline)) +import WGPU.Internal.SMaybe (SMaybe (SJust, SNothing)) +import WGPU.Internal.Shader (ShaderEntryPoint, ShaderModule) +import WGPU.Internal.Texture (TextureFormat) +import WGPU.Raw.Generated.Enum.WGPUBlendFactor (WGPUBlendFactor) +import qualified WGPU.Raw.Generated.Enum.WGPUBlendFactor as WGPUBlendFactor +import WGPU.Raw.Generated.Enum.WGPUBlendOperation (WGPUBlendOperation) +import qualified WGPU.Raw.Generated.Enum.WGPUBlendOperation as WGPUBlendOperation +import WGPU.Raw.Generated.Enum.WGPUColorWriteMask (WGPUColorWriteMask (WGPUColorWriteMask)) +import qualified WGPU.Raw.Generated.Enum.WGPUColorWriteMask as WGPUColorWriteMask +import WGPU.Raw.Generated.Enum.WGPUCullMode (WGPUCullMode) +import qualified WGPU.Raw.Generated.Enum.WGPUCullMode as WGPUCullMode +import WGPU.Raw.Generated.Enum.WGPUFrontFace (WGPUFrontFace) +import qualified WGPU.Raw.Generated.Enum.WGPUFrontFace as WGPUFrontFace +import WGPU.Raw.Generated.Enum.WGPUIndexFormat (WGPUIndexFormat) +import qualified WGPU.Raw.Generated.Enum.WGPUIndexFormat as WGPUIndexFormat +import WGPU.Raw.Generated.Enum.WGPUInputStepMode (WGPUInputStepMode) +import qualified WGPU.Raw.Generated.Enum.WGPUInputStepMode as WGPUInputStepMode +import WGPU.Raw.Generated.Enum.WGPUPrimitiveTopology (WGPUPrimitiveTopology) +import qualified WGPU.Raw.Generated.Enum.WGPUPrimitiveTopology as WGPUPrimitiveTopology +import WGPU.Raw.Generated.Enum.WGPUStencilOperation (WGPUStencilOperation) +import qualified WGPU.Raw.Generated.Enum.WGPUStencilOperation as WGPUStencilOperation +import WGPU.Raw.Generated.Enum.WGPUVertexFormat (WGPUVertexFormat) +import qualified WGPU.Raw.Generated.Enum.WGPUVertexFormat as WGPUVertexFormat +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Generated.Struct.WGPUBlendComponent (WGPUBlendComponent) +import qualified WGPU.Raw.Generated.Struct.WGPUBlendComponent as WGPUBlendComponent +import WGPU.Raw.Generated.Struct.WGPUBlendState (WGPUBlendState) +import qualified WGPU.Raw.Generated.Struct.WGPUBlendState as WGPUBlendState +import WGPU.Raw.Generated.Struct.WGPUColorTargetState (WGPUColorTargetState) +import qualified WGPU.Raw.Generated.Struct.WGPUColorTargetState as WGPUColorTargetState +import WGPU.Raw.Generated.Struct.WGPUDepthStencilState (WGPUDepthStencilState) +import qualified WGPU.Raw.Generated.Struct.WGPUDepthStencilState as WGPUDepthStencilState +import WGPU.Raw.Generated.Struct.WGPUFragmentState (WGPUFragmentState) +import qualified WGPU.Raw.Generated.Struct.WGPUFragmentState as WGPUFragmentState +import WGPU.Raw.Generated.Struct.WGPUMultisampleState (WGPUMultisampleState) +import qualified WGPU.Raw.Generated.Struct.WGPUMultisampleState as WGPUMultisampleState +import WGPU.Raw.Generated.Struct.WGPUPipelineLayoutDescriptor (WGPUPipelineLayoutDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPUPipelineLayoutDescriptor as WGPUPipelineLayoutDescriptor +import WGPU.Raw.Generated.Struct.WGPUPrimitiveState (WGPUPrimitiveState) +import qualified WGPU.Raw.Generated.Struct.WGPUPrimitiveState as WGPUPrimitiveState +import WGPU.Raw.Generated.Struct.WGPURenderPipelineDescriptor (WGPURenderPipelineDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPURenderPipelineDescriptor as WGPURenderPipelineDescriptor +import WGPU.Raw.Generated.Struct.WGPUStencilFaceState (WGPUStencilFaceState) +import qualified WGPU.Raw.Generated.Struct.WGPUStencilFaceState as WGPUStencilFaceState +import WGPU.Raw.Generated.Struct.WGPUVertexAttribute (WGPUVertexAttribute) +import qualified WGPU.Raw.Generated.Struct.WGPUVertexAttribute as WGPUVertexAttribute +import WGPU.Raw.Generated.Struct.WGPUVertexBufferLayout (WGPUVertexBufferLayout) +import qualified WGPU.Raw.Generated.Struct.WGPUVertexBufferLayout as WGPUVertexBufferLayout +import WGPU.Raw.Generated.Struct.WGPUVertexState (WGPUVertexState) +import qualified WGPU.Raw.Generated.Struct.WGPUVertexState as WGPUVertexState +import WGPU.Raw.Types (WGPUPipelineLayout (WGPUPipelineLayout)) +import Prelude hiding (compare) + +------------------------------------------------------------------------------- + +newtype PipelineLayout = PipelineLayout {wgpuPipelineLayout :: WGPUPipelineLayout} + +instance Show PipelineLayout where + show p = + let PipelineLayout (WGPUPipelineLayout ptr) = p + in showWithPtr "PipelineLayout" ptr + +instance Eq PipelineLayout where + (==) p1 p2 = + let PipelineLayout (WGPUPipelineLayout p1_ptr) = p1 + PipelineLayout (WGPUPipelineLayout p2_ptr) = p2 + in p1_ptr == p2_ptr + +instance ToRaw PipelineLayout WGPUPipelineLayout where + raw = pure . wgpuPipelineLayout + +------------------------------------------------------------------------------- + +-- | Describes a pipeline layout. +data PipelineLayoutDescriptor = PipelineLayoutDescriptor + { -- | Debug label of the pipeline layout. + pipelineLabel :: !Text, + -- | Bind groups that this pipeline uses. + bindGroupLayouts :: !(Vector BindGroupLayout) + } + deriving (Eq, Show) + +instance ToRaw PipelineLayoutDescriptor WGPUPipelineLayoutDescriptor where + raw PipelineLayoutDescriptor {..} = do + label_ptr <- rawPtr pipelineLabel + bindGroupLayouts_ptr <- rawArrayPtr bindGroupLayouts + pure + WGPUPipelineLayoutDescriptor.WGPUPipelineLayoutDescriptor + { nextInChain = nullPtr, + label = label_ptr, + bindGroupLayoutCount = fromIntegral . Vector.length $ bindGroupLayouts, + bindGroupLayouts = bindGroupLayouts_ptr + } + +------------------------------------------------------------------------------- + +-- | Create a pipeline layout. +createPipelineLayout :: + -- | The device for which the pipeline layout will be created. + Device -> + -- | Descriptor of the pipeline. + PipelineLayoutDescriptor -> + IO PipelineLayout +createPipelineLayout device pdl = evalContT $ do + let inst = deviceInst device + pipelineLayoutDescriptor_ptr <- rawPtr pdl + rawPipelineLayout <- + liftIO $ + RawFun.wgpuDeviceCreatePipelineLayout + (wgpuHsInstance inst) + (wgpuDevice device) + pipelineLayoutDescriptor_ptr + pure (PipelineLayout rawPipelineLayout) + +------------------------------------------------------------------------------- + +-- | Vertex format for a vertex attribute. +data VertexFormat + = VertexFormatUint8x2 + | VertexFormatUint8x4 + | VertexFormatSint8x2 + | VertexFormatSint8x4 + | VertexFormatUnorm8x2 + | VertexFormatUnorm8x4 + | VertexFormatSnorm8x2 + | VertexFormatSnorm8x4 + | VertexFormatUint16x2 + | VertexFormatUint16x4 + | VertexFormatSint16x2 + | VertexFormatSint16x4 + | VertexFormatUnorm16x2 + | VertexFormatUnorm16x4 + | VertexFormatSnorm16x2 + | VertexFormatSnorm16x4 + | VertexFormatFloat16x2 + | VertexFormatFloat16x4 + | VertexFormatFloat32 + | VertexFormatFloat32x2 + | VertexFormatFloat32x3 + | VertexFormatFloat32x4 + | VertexFormatUint32 + | VertexFormatUint32x2 + | VertexFormatUint32x3 + | VertexFormatUint32x4 + | VertexFormatSint32 + | VertexFormatSint32x2 + | VertexFormatSint32x3 + | VertexFormatSint32x4 + deriving (Eq, Show) + +-- | Convert a 'VertexFormat' to its raw representation. +instance ToRaw VertexFormat WGPUVertexFormat where + raw vf = + pure $ + case vf of + VertexFormatUint8x2 -> WGPUVertexFormat.Uint8x2 + VertexFormatUint8x4 -> WGPUVertexFormat.Uint8x4 + VertexFormatSint8x2 -> WGPUVertexFormat.Sint8x2 + VertexFormatSint8x4 -> WGPUVertexFormat.Sint8x4 + VertexFormatUnorm8x2 -> WGPUVertexFormat.Unorm8x2 + VertexFormatUnorm8x4 -> WGPUVertexFormat.Unorm8x4 + VertexFormatSnorm8x2 -> WGPUVertexFormat.Snorm8x2 + VertexFormatSnorm8x4 -> WGPUVertexFormat.Snorm8x4 + VertexFormatUint16x2 -> WGPUVertexFormat.Uint16x2 + VertexFormatUint16x4 -> WGPUVertexFormat.Uint16x4 + VertexFormatSint16x2 -> WGPUVertexFormat.Sint16x2 + VertexFormatSint16x4 -> WGPUVertexFormat.Sint16x4 + VertexFormatUnorm16x2 -> WGPUVertexFormat.Unorm16x2 + VertexFormatUnorm16x4 -> WGPUVertexFormat.Unorm16x4 + VertexFormatSnorm16x2 -> WGPUVertexFormat.Snorm16x2 + VertexFormatSnorm16x4 -> WGPUVertexFormat.Snorm16x4 + VertexFormatFloat16x2 -> WGPUVertexFormat.Float16x2 + VertexFormatFloat16x4 -> WGPUVertexFormat.Float16x4 + VertexFormatFloat32 -> WGPUVertexFormat.Float32 + VertexFormatFloat32x2 -> WGPUVertexFormat.Float32x2 + VertexFormatFloat32x3 -> WGPUVertexFormat.Float32x3 + VertexFormatFloat32x4 -> WGPUVertexFormat.Float32x4 + VertexFormatUint32 -> WGPUVertexFormat.Uint32 + VertexFormatUint32x2 -> WGPUVertexFormat.Uint32x2 + VertexFormatUint32x3 -> WGPUVertexFormat.Uint32x3 + VertexFormatUint32x4 -> WGPUVertexFormat.Uint32x4 + VertexFormatSint32 -> WGPUVertexFormat.Sint32 + VertexFormatSint32x2 -> WGPUVertexFormat.Sint32x2 + VertexFormatSint32x3 -> WGPUVertexFormat.Sint32x3 + VertexFormatSint32x4 -> WGPUVertexFormat.Sint32x4 + +------------------------------------------------------------------------------- + +-- | Vertex inputs (attributes) to shaders. +data VertexAttribute = VertexAttribute + { -- | Format of the input. + vertexFormat :: VertexFormat, + -- | Byte offset of the start of the input. + offset :: Word64, + -- | Location for this input. Must match the location in the shader. + shaderLocation :: Word32 + } + deriving (Eq, Show) + +instance ToRaw VertexAttribute WGPUVertexAttribute where + raw VertexAttribute {..} = do + n_format <- raw vertexFormat + pure + WGPUVertexAttribute.WGPUVertexAttribute + { format = n_format, + offset = offset, + shaderLocation = shaderLocation + } + +------------------------------------------------------------------------------- + +-- | Determines when vertex data is advanced. +data InputStepMode + = -- | Input data is advanced every vertex. + InputStepModeVertex + | -- | Input data is advanced every instance. + InputStepModeInstance + deriving (Eq, Show) + +-- | Convert an 'InputStepMode' to its raw value. +instance ToRaw InputStepMode WGPUInputStepMode where + raw ism = + pure $ + case ism of + InputStepModeVertex -> WGPUInputStepMode.Vertex + InputStepModeInstance -> WGPUInputStepMode.Instance + +------------------------------------------------------------------------------- + +-- | Describes how a vertex buffer is interpreted. +data VertexBufferLayout = VertexBufferLayout + { -- | The stride, in bytes, between elements of the buffer. + arrayStride :: !Word64, + -- | How often the vertex buffer is stepped forward (per vertex or + -- per instance). + stepMode :: !InputStepMode, + -- | List of attributes that comprise a single vertex. + attributes :: !(Vector VertexAttribute) + } + deriving (Eq, Show) + +instance ToRaw VertexBufferLayout WGPUVertexBufferLayout where + raw VertexBufferLayout {..} = do + n_stepMode <- raw stepMode + attributes_ptr <- rawArrayPtr attributes + pure + WGPUVertexBufferLayout.WGPUVertexBufferLayout + { arrayStride = arrayStride, + stepMode = n_stepMode, + attributeCount = fromIntegral . length $ attributes, + attributes = attributes_ptr + } + +------------------------------------------------------------------------------- + +-- | Describes the vertex process in a render pipeline. +data VertexState = VertexState + { -- | The compiled shader module for this stage. + vertexShaderModule :: !ShaderModule, + -- | The name of the entry point in the compiled shader. There must be a + -- function that returns @void@ with this name in the shader. + vertexEntryPoint :: !ShaderEntryPoint, + -- | The format of any vertex buffers used with this pipeline. + buffers :: !(Vector VertexBufferLayout) + } + deriving (Eq, Show) + +instance ToRaw VertexState WGPUVertexState where + raw VertexState {..} = do + n_shaderModule <- raw vertexShaderModule + entryPoint_ptr <- rawPtr vertexEntryPoint + buffers_ptr <- rawArrayPtr buffers + pure + WGPUVertexState.WGPUVertexState + { nextInChain = nullPtr, + shaderModule = n_shaderModule, + entryPoint = entryPoint_ptr, + bufferCount = fromIntegral . length $ buffers, + buffers = buffers_ptr + } + +------------------------------------------------------------------------------- + +-- | Primitive type out of which an input mesh is composed. +data PrimitiveTopology + = PrimitiveTopologyPointList + | PrimitiveTopologyLineList + | PrimitiveTopologyLineStrip + | PrimitiveTopologyTriangleList + | PrimitiveTopologyTriangleStrip + deriving (Eq, Show) + +instance Default PrimitiveTopology where def = PrimitiveTopologyTriangleList + +-- | Convert a 'PrimitiveTopology' to its raw value. +instance ToRaw PrimitiveTopology WGPUPrimitiveTopology where + raw pt = + pure $ + case pt of + PrimitiveTopologyPointList -> WGPUPrimitiveTopology.PointList + PrimitiveTopologyLineList -> WGPUPrimitiveTopology.LineList + PrimitiveTopologyLineStrip -> WGPUPrimitiveTopology.LineStrip + PrimitiveTopologyTriangleList -> WGPUPrimitiveTopology.TriangleList + PrimitiveTopologyTriangleStrip -> WGPUPrimitiveTopology.TriangleStrip + +------------------------------------------------------------------------------- + +-- | Format of indices used within a pipeline. +data IndexFormat + = -- | Indices are 16-bit unsigned integers ('Word16') + IndexFormatUint16 + | -- | Indices are 32-bit unsigned integers ('Word32') + IndexFormatUint32 + deriving (Eq, Show) + +-- | Convert an 'IndexFormat' to its raw value. +instance ToRaw IndexFormat WGPUIndexFormat where + raw idxFmt = + pure $ + case idxFmt of + IndexFormatUint16 -> WGPUIndexFormat.Uint16 + IndexFormatUint32 -> WGPUIndexFormat.Uint32 + +------------------------------------------------------------------------------- + +-- | Winding order which classifies the "front" face. +data FrontFace + = -- | Triangles with counter-clockwise vertices are the front face. + FrontFaceCCW + | -- | Triangles with clockwise vertices are the front face. + FrontFaceCW + deriving (Eq, Show) + +instance Default FrontFace where def = FrontFaceCCW + +-- | Convert a 'FrontFace' to its raw value. +instance ToRaw FrontFace WGPUFrontFace where + raw ff = + pure $ + case ff of + FrontFaceCCW -> WGPUFrontFace.CCW + FrontFaceCW -> WGPUFrontFace.CW + +------------------------------------------------------------------------------- + +-- | Whether to cull the face of a vertex. +data CullMode + = -- | Cull the front face. + CullModeFront + | -- | Cull the back face. + CullModeBack + | -- | Do not cull either face. + CullModeNone + deriving (Eq, Show) + +instance Default CullMode where def = CullModeNone + +-- | Convert a 'CullMode' to its raw value. +instance ToRaw CullMode WGPUCullMode where + raw cm = + pure $ + case cm of + CullModeFront -> WGPUCullMode.Front + CullModeBack -> WGPUCullMode.Back + CullModeNone -> WGPUCullMode.None + +------------------------------------------------------------------------------- + +-- | Describes the state of primitive assembly and rasterization in a render +-- pipeline. +-- +-- Differences between this and the Rust API: +-- - no `clamp_depth` member +-- - no `polygon_mode` member +-- - no `conservative` member +data PrimitiveState = PrimitiveState + { -- | The primitive topology used to interpret vertices. + topology :: !PrimitiveTopology, + -- | When drawing strip topologies with indices, this is the required + -- format for the index buffer. This has no effect for non-indexed or + -- non-strip draws. + stripIndexFormat :: !(SMaybe IndexFormat), + -- | The face to consider the front for the purpose of culling and + -- stencil operations. + frontFace :: !FrontFace, + -- | The face culling mode. + cullMode :: !CullMode + } + deriving (Eq, Show) + +instance Default PrimitiveState where + def = + PrimitiveState + { topology = def, + stripIndexFormat = SNothing, + frontFace = def, + cullMode = def + } + +instance ToRaw PrimitiveState WGPUPrimitiveState where + raw PrimitiveState {..} = do + n_topology <- raw topology + n_stripIndexFormat <- + case stripIndexFormat of + SNothing -> pure WGPUIndexFormat.Undefined + SJust sif -> raw sif + n_frontFace <- raw frontFace + n_cullMode <- raw cullMode + pure + WGPUPrimitiveState.WGPUPrimitiveState + { nextInChain = nullPtr, + topology = n_topology, + stripIndexFormat = n_stripIndexFormat, + frontFace = n_frontFace, + cullMode = n_cullMode + } + +------------------------------------------------------------------------------- + +-- | Operation to perform on a stencil value. +data StencilOperation + = StencilOperationKeep + | StencilOperationZero + | StencilOperationReplace + | StencilOperationInvert + | StencilOperationIncrementClamp + | StencilOperationDecrementClamp + | StencilOperationIncrementWrap + | StencilOperationDecrementWrap + deriving (Eq, Show) + +-- | Convert a 'StencilOperation' to its raw value. +instance ToRaw StencilOperation WGPUStencilOperation where + raw so = + pure $ + case so of + StencilOperationKeep -> WGPUStencilOperation.Keep + StencilOperationZero -> WGPUStencilOperation.Zero + StencilOperationReplace -> WGPUStencilOperation.Replace + StencilOperationInvert -> WGPUStencilOperation.Invert + StencilOperationIncrementClamp -> WGPUStencilOperation.IncrementClamp + StencilOperationDecrementClamp -> WGPUStencilOperation.DecrementClamp + StencilOperationIncrementWrap -> WGPUStencilOperation.IncrementWrap + StencilOperationDecrementWrap -> WGPUStencilOperation.DecrementWrap + +------------------------------------------------------------------------------- + +-- | Describes stencil state in a render pipeline. +data StencilFaceState = StencilFaceState + { compare :: !CompareFunction, + failOp :: !StencilOperation, + depthFailOp :: !StencilOperation, + passOp :: !StencilOperation + } + deriving (Eq, Show) + +instance ToRaw StencilFaceState WGPUStencilFaceState where + raw StencilFaceState {..} = do + n_compare <- raw compare + n_failOp <- raw failOp + n_depthFailOp <- raw depthFailOp + n_passOp <- raw passOp + pure + WGPUStencilFaceState.WGPUStencilFaceState + { compare = n_compare, + failOp = n_failOp, + depthFailOp = n_depthFailOp, + passOp = n_passOp + } + +------------------------------------------------------------------------------- + +-- | State of the stencil operation (fixed pipeline stage). +data StencilState = StencilState + { -- | Front face mode. + front :: !StencilFaceState, + -- | Back face mode. + back :: !StencilFaceState, + -- | Stencil values are AND-ed with this mask when reading and writing from + -- the stencil buffer. + readMask :: !Word8, + -- | Stencil values are AND-ed with this mask when writing to the stencil + -- buffer. + writeMask :: !Word8 + } + deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- | Describes the biasing setting for the depth target. +data DepthBiasState = DepthBiasState + { -- Constant depth biasing factor, in basic units of the depth format. + constant :: !Int32, + -- | Slope depth biasing factor. + slopeScale :: !Float, + -- | Depth bias clamp value (absolute). + clamp :: !Float + } + deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- | Describes the depth / stencil state of a render pipeline. +data DepthStencilState = DepthStencilState + { -- | Format of the depth/stencil buffer. This must be a special depth + -- format, and must match the format of the depth/stencil attachment in + -- the command encoder. + depthStencilTextureFormat :: !TextureFormat, + -- | If disabled, depth will not be written to. + depthWriteEnabled :: !Bool, + -- | Comparison function used to compare depth values in the depth test. + depthCompare :: !CompareFunction, + -- | Stencil state. + stencil :: !StencilState, + -- | Depth bias state. + bias :: !DepthBiasState + } + deriving (Eq, Show) + +instance ToRaw DepthStencilState WGPUDepthStencilState where + raw DepthStencilState {..} = do + n_format <- raw depthStencilTextureFormat + n_depthWriteEnabled <- raw depthWriteEnabled + n_depthCompare <- raw depthCompare + n_stencilFront <- raw . front $ stencil + n_stencilBack <- raw . back $ stencil + pure + WGPUDepthStencilState.WGPUDepthStencilState + { nextInChain = nullPtr, + format = n_format, + depthWriteEnabled = n_depthWriteEnabled, + depthCompare = n_depthCompare, + stencilFront = n_stencilFront, + stencilBack = n_stencilBack, + stencilReadMask = fromIntegral . readMask $ stencil, + stencilWriteMask = fromIntegral $ writeMask (stencil :: StencilState), + depthBias = constant bias, + depthBiasSlopeScale = CFloat (slopeScale bias), + depthBiasClamp = CFloat (clamp bias) + } + +------------------------------------------------------------------------------- + +-- | Describes the multi-sampling state of a render pipeline. +data MultisampleState = MultisampleState + { -- | Number of samples calculated per pixel (for MSAA). For + -- non-multisampled textures, this should be 1. + count :: Word32, + -- | Bitmask that restricts the samples of a pixel modified by this + -- pipeline. All samples can be enabled by using + -- @0XFFFFFFFF@ (ie. zero complement). + mask :: Word32, + -- | When enabled, produces another sample mask per pixel based on the + -- alpha output value, and that is AND-ed with the sample mask and the + -- primitive coverage to restrict the set of samples affected by a + -- primitive. + alphaToCoverageEnabled :: Bool + } + deriving (Eq, Show) + +instance ToRaw MultisampleState WGPUMultisampleState where + raw MultisampleState {..} = do + n_alphaToCoverageEnabled <- raw alphaToCoverageEnabled + pure + WGPUMultisampleState.WGPUMultisampleState + { nextInChain = nullPtr, + count = count, + mask = mask, + alphaToCoverageEnabled = n_alphaToCoverageEnabled + } + +------------------------------------------------------------------------------- + +-- | Alpha blend factor. +data BlendFactor + = BlendFactorZero + | BlendFactorOne + | BlendFactorSrc + | BlendFactorOneMinusSrc + | BlendFactorSrcAlpha + | BlendFactorOneMinusSrcAlpha + | BlendFactorDst + | BlendFactorOneMinusDst + | BlendFactorDstAlpha + | BlendFactorOneMinusDstAlpha + | BlendFactorSrcAlphaSaturated + | BlendFactorConstant + | BlendFactorOneMinusConstant + deriving (Eq, Show) + +-- | Convert a 'BlendFactor' to its raw value. +instance ToRaw BlendFactor WGPUBlendFactor where + raw bf = + pure $ + case bf of + BlendFactorZero -> WGPUBlendFactor.Zero + BlendFactorOne -> WGPUBlendFactor.One + BlendFactorSrc -> WGPUBlendFactor.Src + BlendFactorOneMinusSrc -> WGPUBlendFactor.OneMinusSrc + BlendFactorSrcAlpha -> WGPUBlendFactor.SrcAlpha + BlendFactorOneMinusSrcAlpha -> WGPUBlendFactor.OneMinusSrcAlpha + BlendFactorDst -> WGPUBlendFactor.Dst + BlendFactorOneMinusDst -> WGPUBlendFactor.OneMinusDst + BlendFactorDstAlpha -> WGPUBlendFactor.DstAlpha + BlendFactorOneMinusDstAlpha -> WGPUBlendFactor.OneMinusDstAlpha + BlendFactorSrcAlphaSaturated -> WGPUBlendFactor.SrcAlphaSaturated + BlendFactorConstant -> WGPUBlendFactor.Constant + BlendFactorOneMinusConstant -> WGPUBlendFactor.OneMinusConstant + +------------------------------------------------------------------------------- + +-- | Alpha blending operation. +data BlendOperation + = BlendOperationAdd + | BlendOperationSubtract + | BlendOperationReverseSubtract + | BlendOperationMin + | BlendOperationMax + deriving (Eq, Show) + +-- | Convert a 'BlendOperation' to its raw value. +instance ToRaw BlendOperation WGPUBlendOperation where + raw bo = + pure $ + case bo of + BlendOperationAdd -> WGPUBlendOperation.Add + BlendOperationSubtract -> WGPUBlendOperation.Subtract + BlendOperationReverseSubtract -> WGPUBlendOperation.ReverseSubtract + BlendOperationMin -> WGPUBlendOperation.Min + BlendOperationMax -> WGPUBlendOperation.Max + +------------------------------------------------------------------------------- + +-- | Describes the blend component of a pipeline. +data BlendComponent = BlendComponent + { -- | Multiplier for the source, which is produced by the fragment shader. + srcFactor :: !BlendFactor, + -- | Multiplier for the destination, which is stored in the target. + dstFactor :: !BlendFactor, + -- | Binary operation applied to the source and destination, multiplied by + -- their respective factors. + operation :: !BlendOperation + } + deriving (Eq, Show) + +instance Default BlendComponent where + def = + BlendComponent + { srcFactor = BlendFactorOne, + dstFactor = BlendFactorZero, + operation = BlendOperationAdd + } + +instance ToRaw BlendComponent WGPUBlendComponent where + raw BlendComponent {..} = do + n_srcFactor <- raw srcFactor + n_dstFactor <- raw dstFactor + n_operation <- raw operation + pure + WGPUBlendComponent.WGPUBlendComponent + { srcFactor = n_srcFactor, + dstFactor = n_dstFactor, + operation = n_operation + } + +------------------------------------------------------------------------------- + +-- | Describes the blend state of a render pipeline. +data BlendState = BlendState + { -- | Color equation. + blendColor :: !BlendComponent, + -- | Alpha equation. + blendAlpha :: !BlendComponent + } + deriving (Eq, Show) + +instance ToRaw BlendState WGPUBlendState where + raw BlendState {..} = do + n_color <- raw blendColor + n_alpha <- raw blendAlpha + pure + WGPUBlendState.WGPUBlendState + { color = n_color, + alpha = n_alpha + } + +------------------------------------------------------------------------------- + +-- | Describes which color channels are written. +data ColorWriteMask = ColorWriteMask + { maskRed :: !Bool, + maskGreen :: !Bool, + maskBlue :: !Bool, + maskAlpha :: !Bool + } + deriving (Eq, Show) + +-- | A 'ColorWriteMask' that writes all colors and the alpha value. +colorWriteMaskAll :: ColorWriteMask +colorWriteMaskAll = ColorWriteMask True True True True + +instance ToRaw ColorWriteMask WGPUColorWriteMask where + raw ColorWriteMask {..} = + pure $ + WGPUColorWriteMask + ( (if maskRed then WGPUColorWriteMask.Red else 0) + .|. (if maskGreen then WGPUColorWriteMask.Green else 0) + .|. (if maskBlue then WGPUColorWriteMask.Blue else 0) + .|. (if maskAlpha then WGPUColorWriteMask.Alpha else 0) + ) + +------------------------------------------------------------------------------- + +-- | Describes the color state of a render pipeline. +data ColorTargetState = ColorTargetState + { -- | The texture format of the image that this pipeline will render to. + -- Must match the format of the corresponding color attachment in the + -- command encoder. + colorTextureFormat :: !TextureFormat, + -- | The blending that is used for this pipeline. + blend :: !(SMaybe BlendState), + -- | Mask which enables or disables writes to different color/alpha + -- channels. + colorWriteMask :: !ColorWriteMask + } + deriving (Eq, Show) + +instance ToRaw ColorTargetState WGPUColorTargetState where + raw ColorTargetState {..} = do + n_format <- raw colorTextureFormat + blend_ptr <- + case blend of + SNothing -> pure nullPtr + SJust x -> rawPtr x + WGPUColorWriteMask n_writeMask <- raw colorWriteMask + pure + WGPUColorTargetState.WGPUColorTargetState + { nextInChain = nullPtr, + format = n_format, + blend = blend_ptr, + writeMask = n_writeMask + } + +------------------------------------------------------------------------------- + +-- | Describes the fragment processing in a render pipeline. +data FragmentState = FragmentState + { -- | The compiled shader module for this stage. + fragmentShaderModule :: !ShaderModule, + -- | The entry point in the compiled shader. There must be a function that + -- returns @void@ with this name in the shader. + fragmentEntryPoint :: !ShaderEntryPoint, + -- | The color state of the render targets. + targets :: !(Vector ColorTargetState) + } + deriving (Eq, Show) + +instance ToRaw FragmentState WGPUFragmentState where + raw FragmentState {..} = do + n_shaderModule <- raw fragmentShaderModule + entryPoint_ptr <- rawPtr fragmentEntryPoint + targets_ptr <- rawArrayPtr targets + pure + WGPUFragmentState.WGPUFragmentState + { nextInChain = nullPtr, + shaderModule = n_shaderModule, + entryPoint = entryPoint_ptr, + targetCount = fromIntegral . length $ targets, + targets = targets_ptr + } + +------------------------------------------------------------------------------- + +-- | Describes a render (graphics) pipeline. +data RenderPipelineDescriptor = RenderPipelineDescriptor + { -- | Debug label of the pipeline. + renderPipelineLabel :: !Text, + -- | The layout of bind groups for this pipeline. + layout :: !(SMaybe PipelineLayout), + -- | Vertex state. + vertex :: !VertexState, + -- | Primitive state. + primitive :: !PrimitiveState, + -- | Depth stencil state. + depthStencil :: !(SMaybe DepthStencilState), + -- | Multisample state. + multisample :: !MultisampleState, + -- | Fragment state. + fragment :: !(SMaybe FragmentState) + } + deriving (Eq, Show) + +instance ToRaw RenderPipelineDescriptor WGPURenderPipelineDescriptor where + raw RenderPipelineDescriptor {..} = do + label_ptr <- rawPtr renderPipelineLabel + n_layout <- + case layout of + SNothing -> pure (WGPUPipelineLayout nullPtr) + SJust x -> raw x + n_vertex <- raw vertex + n_primitive <- raw primitive + n_depthStencil <- + case depthStencil of + SNothing -> pure nullPtr + SJust x -> rawPtr x + n_multisample <- raw multisample + n_fragment <- + case fragment of + SNothing -> pure nullPtr + SJust x -> rawPtr x + pure + WGPURenderPipelineDescriptor.WGPURenderPipelineDescriptor + { nextInChain = nullPtr, + label = label_ptr, + layout = n_layout, + vertex = n_vertex, + primitive = n_primitive, + depthStencil = n_depthStencil, + multisample = n_multisample, + fragment = n_fragment + } + +createRenderPipeline :: + Device -> + RenderPipelineDescriptor -> + IO RenderPipeline +createRenderPipeline device rpd = evalContT $ do + let inst :: Instance + inst = deviceInst device + + renderPipelineDescriptor_ptr <- rawPtr rpd + renderPipelineRaw <- + liftIO $ + RawFun.wgpuDeviceCreateRenderPipeline + (wgpuHsInstance inst) + (wgpuDevice device) + renderPipelineDescriptor_ptr + pure (RenderPipeline renderPipelineRaw) diff --git a/src-internal/WGPU/Internal/Queue.hs b/src-internal/WGPU/Internal/Queue.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Queue.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.Queue +-- Description : Queues +module WGPU.Internal.Queue + ( -- * Types + Queue, + + -- * Functions + getQueue, + queueSubmit, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Data.Vector (Vector) +import Data.Word (Word32) +import WGPU.Internal.CommandBuffer (CommandBuffer) +import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawArrayPtr, showWithPtr) +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Types (WGPUQueue (WGPUQueue)) + +------------------------------------------------------------------------------- + +data Queue = Queue + { queueInst :: !Instance, + wgpuQueue :: !WGPUQueue + } + +instance Show Queue where + show q = + let Queue _ (WGPUQueue ptr) = q + in showWithPtr "Queue" ptr + +instance Eq Queue where + (==) q1 q2 = + let Queue _ (WGPUQueue q1_ptr) = q1 + Queue _ (WGPUQueue q2_ptr) = q2 + in q1_ptr == q2_ptr + +instance ToRaw Queue WGPUQueue where + raw = pure . wgpuQueue + +------------------------------------------------------------------------------- + +-- | Get the queue for a device. +getQueue :: Device -> IO Queue +getQueue device = do + let queueInst :: Instance + queueInst = deviceInst device + wgpuQueue <- + RawFun.wgpuDeviceGetQueue (wgpuHsInstance queueInst) (wgpuDevice device) + pure Queue {..} + +-- | Submit a list of command buffers to a device queue. +queueSubmit :: Queue -> Vector CommandBuffer -> IO () +queueSubmit queue cbs = evalContT $ do + let inst :: Instance + inst = queueInst queue + let commandCount :: Word32 + commandCount = fromIntegral . length $ cbs + + commandBuffer_ptr <- rawArrayPtr cbs + liftIO $ + RawFun.wgpuQueueSubmit + (wgpuHsInstance inst) + (wgpuQueue queue) + commandCount + commandBuffer_ptr diff --git a/src-internal/WGPU/Internal/RenderPass.hs b/src-internal/WGPU/Internal/RenderPass.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/RenderPass.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.RenderPass +-- Description : Render passes. +module WGPU.Internal.RenderPass + ( -- * Types + RenderPipeline (..), + RenderPassEncoder, + LoadOp (..), + StoreOp (..), + Operations (..), + RenderPassColorAttachment (..), + RenderPassDepthStencilAttachment (..), + RenderPassDescriptor (..), + Range (..), + + -- * Functions + beginRenderPass, + renderPassSetPipeline, + renderPassDraw, + endRenderPass, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Word (Word32) +import Foreign (nullPtr) +import Foreign.C (CBool (CBool), CFloat (CFloat)) +import WGPU.Internal.Color (Color, transparentBlack) +import WGPU.Internal.CommandEncoder (CommandEncoder, commandEncoderInst, wgpuCommandEncoder) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawArrayPtr, rawPtr, showWithPtr) +import WGPU.Internal.SMaybe (SMaybe (SJust, SNothing)) +import WGPU.Internal.Texture (TextureView) +import qualified WGPU.Raw.Generated.Enum.WGPULoadOp as WGPULoadOp +import WGPU.Raw.Generated.Enum.WGPUStoreOp (WGPUStoreOp) +import qualified WGPU.Raw.Generated.Enum.WGPUStoreOp as WGPUStoreOp +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Generated.Struct.WGPURenderPassColorAttachment (WGPURenderPassColorAttachment) +import qualified WGPU.Raw.Generated.Struct.WGPURenderPassColorAttachment as WGPURenderPassColorAttachment +import WGPU.Raw.Generated.Struct.WGPURenderPassDepthStencilAttachment (WGPURenderPassDepthStencilAttachment) +import qualified WGPU.Raw.Generated.Struct.WGPURenderPassDepthStencilAttachment as WGPURenderPassDepthStencilAttachment +import WGPU.Raw.Generated.Struct.WGPURenderPassDescriptor (WGPURenderPassDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPURenderPassDescriptor as WGPURenderPassDescriptor +import WGPU.Raw.Types + ( WGPUQuerySet (WGPUQuerySet), + WGPURenderPassEncoder (WGPURenderPassEncoder), + WGPURenderPipeline (WGPURenderPipeline), + WGPUTextureView (WGPUTextureView), + ) + +------------------------------------------------------------------------------- + +newtype RenderPipeline = RenderPipeline {wgpuRenderPipeline :: WGPURenderPipeline} + +instance Show RenderPipeline where + show p = + let RenderPipeline (WGPURenderPipeline ptr) = p + in showWithPtr "RenderPipeline" ptr + +instance Eq RenderPipeline where + (==) p1 p2 = + let RenderPipeline (WGPURenderPipeline p1_ptr) = p1 + RenderPipeline (WGPURenderPipeline p2_ptr) = p2 + in p1_ptr == p2_ptr + +instance ToRaw RenderPipeline WGPURenderPipeline where + raw = pure . wgpuRenderPipeline + +------------------------------------------------------------------------------- + +data RenderPassEncoder = RenderPassEncoder + { renderPassEncoderInst :: !Instance, + wgpuRenderPassEncoder :: !WGPURenderPassEncoder + } + +instance Show RenderPassEncoder where + show e = + let RenderPassEncoder _ (WGPURenderPassEncoder ptr) = e + in showWithPtr "RenderPassEncoder" ptr + +instance Eq RenderPassEncoder where + (==) e1 e2 = + let RenderPassEncoder _ (WGPURenderPassEncoder e1_ptr) = e1 + RenderPassEncoder _ (WGPURenderPassEncoder e2_ptr) = e2 + in e1_ptr == e2_ptr + +instance ToRaw RenderPassEncoder WGPURenderPassEncoder where + raw = pure . wgpuRenderPassEncoder + +------------------------------------------------------------------------------- + +-- | Operation to perform to the output attachment at the start of a render +-- pass. +data LoadOp a + = -- | Clear with the specified color value. + LoadOpClear !a + | -- | Load from memory. + LoadOpLoad + deriving (Eq, Show) + +-- | Operation to perform to the output attachment at the end of the render +-- pass. +data StoreOp + = -- | Store the result. + StoreOpStore + | -- | Discard the result. + StoreOpClear + deriving (Eq, Show) + +instance ToRaw StoreOp WGPUStoreOp where + raw storeOp = + pure $ + case storeOp of + StoreOpStore -> WGPUStoreOp.Store + StoreOpClear -> WGPUStoreOp.Clear + +data Operations a = Operations + { load :: !(LoadOp a), + store :: StoreOp + } + deriving (Eq, Show) + +-- | Describes a color attachment to a render pass. +data RenderPassColorAttachment = RenderPassColorAttachment + { -- | The view to use as an attachment. + colorView :: !TextureView, + -- | The view that will receive output if multisampling is used. + resolveTarget :: !(SMaybe TextureView), + -- | What operations will be performed on this color attachment. + operations :: !(Operations Color) + } + deriving (Eq, Show) + +instance ToRaw RenderPassColorAttachment WGPURenderPassColorAttachment where + raw RenderPassColorAttachment {..} = do + n_view <- raw colorView + n_resolveTarget <- + case resolveTarget of + SNothing -> pure (WGPUTextureView nullPtr) + SJust t -> raw t + n_storeOp <- raw . store $ operations + (n_loadOp, n_clearColor) <- + case load operations of + LoadOpClear color -> do + n_color <- raw color + pure (WGPULoadOp.Clear, n_color) + LoadOpLoad -> do + n_color <- raw transparentBlack + pure (WGPULoadOp.Load, n_color) + pure + WGPURenderPassColorAttachment.WGPURenderPassColorAttachment + { view = n_view, + resolveTarget = n_resolveTarget, + loadOp = n_loadOp, + storeOp = n_storeOp, + clearColor = n_clearColor + } + +-- | Describes a depth/stencil attachment to a render pass. +data RenderPassDepthStencilAttachment = RenderPassDepthStencilAttachment + { -- | The view to use as an attachment. + depthStencilView :: !TextureView, + -- | What operations will be performed on the depth part. + depthOps :: !(SMaybe (Operations Float)), + -- | What operations will be performed on the stencil part. + stencilOps :: !(SMaybe (Operations Word32)) + } + deriving (Eq, Show) + +instance + ToRaw + RenderPassDepthStencilAttachment + WGPURenderPassDepthStencilAttachment + where + raw RenderPassDepthStencilAttachment {..} = do + n_view <- raw depthStencilView + + (n_depthLoadOp, n_depthStoreOp, n_clearDepth, n_depthReadOnly) <- + case depthOps of + SNothing -> + pure + ( WGPULoadOp.Clear, + WGPUStoreOp.Clear, + CFloat 0, + CBool 1 + ) + SJust Operations {..} -> do + (loadOp, depth) <- + case load of + LoadOpClear d -> pure (WGPULoadOp.Clear, CFloat d) + LoadOpLoad -> pure (WGPULoadOp.Load, CFloat 0) + storeOp <- raw store + pure (loadOp, storeOp, depth, CBool 0) + + (n_stencilLoadOp, n_stencilStoreOp, n_clearStencil, n_stencilReadOnly) <- + case stencilOps of + SNothing -> + pure + ( WGPULoadOp.Clear, + WGPUStoreOp.Clear, + 0, + CBool 1 + ) + SJust Operations {..} -> do + (loadOp, stencil) <- + case load of + LoadOpClear s -> pure (WGPULoadOp.Clear, s) + LoadOpLoad -> pure (WGPULoadOp.Load, 0) + storeOp <- raw store + pure (loadOp, storeOp, stencil, CBool 0) + + pure + WGPURenderPassDepthStencilAttachment.WGPURenderPassDepthStencilAttachment + { view = n_view, + depthLoadOp = n_depthLoadOp, + depthStoreOp = n_depthStoreOp, + clearDepth = n_clearDepth, + depthReadOnly = n_depthReadOnly, + stencilLoadOp = n_stencilLoadOp, + stencilStoreOp = n_stencilStoreOp, + clearStencil = n_clearStencil, + stencilReadOnly = n_stencilReadOnly + } + +-- | Describes the attachments of a render pass. +data RenderPassDescriptor = RenderPassDescriptor + { -- | Debugging label for the render pass. + renderPassLabel :: !Text, + -- | Color attachments of the render pass. + colorAttachments :: !(Vector RenderPassColorAttachment), + -- | Depth and stencil attachments of the render pass. + depthStencilAttachment :: !(SMaybe RenderPassDepthStencilAttachment) + } + deriving (Eq, Show) + +instance ToRaw RenderPassDescriptor WGPURenderPassDescriptor where + raw RenderPassDescriptor {..} = do + label_ptr <- rawPtr renderPassLabel + colorAttachments_ptr <- rawArrayPtr colorAttachments + depthStencilAttachment_ptr <- + case depthStencilAttachment of + SNothing -> pure nullPtr + SJust x -> rawPtr x + pure + WGPURenderPassDescriptor.WGPURenderPassDescriptor + { nextInChain = nullPtr, + label = label_ptr, + colorAttachmentCount = fromIntegral . length $ colorAttachments, + colorAttachments = colorAttachments_ptr, + depthStencilAttachment = depthStencilAttachment_ptr, + occlusionQuerySet = WGPUQuerySet nullPtr + } + +-- | Half open range. It includes the 'start' value but not the 'end' value. +data Range a = Range + { rangeStart :: !a, + rangeLength :: !a + } + deriving (Eq, Show) + +-- | Begins recording of a render pass. +beginRenderPass :: + -- | @CommandEncoder@ to contain the render pass. + CommandEncoder -> + -- | Description of the render pass. + RenderPassDescriptor -> + -- | IO action which returns the render pass encoder. + IO RenderPassEncoder +beginRenderPass commandEncoder rpd = evalContT $ do + let inst :: Instance + inst = commandEncoderInst commandEncoder + + renderPassDescriptor_ptr <- rawPtr rpd + renderPassEncoderRaw <- + liftIO $ + RawFun.wgpuCommandEncoderBeginRenderPass + (wgpuHsInstance inst) + (wgpuCommandEncoder commandEncoder) + renderPassDescriptor_ptr + pure (RenderPassEncoder inst renderPassEncoderRaw) + +-- | Sets the active render pipeline. +-- +-- Subsequent draw calls will exhibit the behaviour defined by the pipeline. +renderPassSetPipeline :: + -- | Render pass encoder on which to act. + RenderPassEncoder -> + -- | Render pipeline to set active. + RenderPipeline -> + -- | IO action which sets the active render pipeline. + IO () +renderPassSetPipeline renderPassEncoder renderPipeline = do + let inst :: Instance + inst = renderPassEncoderInst renderPassEncoder + + RawFun.wgpuRenderPassEncoderSetPipeline + (wgpuHsInstance inst) + (wgpuRenderPassEncoder renderPassEncoder) + (wgpuRenderPipeline renderPipeline) + +-- | Draws primitives from the active vertex buffers. +renderPassDraw :: + -- | Render pass encoder on which to act. + RenderPassEncoder -> + -- | Range of vertices to draw. + Range Word32 -> + -- | Range of instances to draw. + Range Word32 -> + -- | IO action which stores the draw command. + IO () +renderPassDraw renderPassEncoder vertices instances = do + let inst :: Instance + inst = renderPassEncoderInst renderPassEncoder + + RawFun.wgpuRenderPassEncoderDraw + (wgpuHsInstance inst) + (wgpuRenderPassEncoder renderPassEncoder) + (rangeLength (vertices :: Range Word32)) + (rangeLength (instances :: Range Word32)) + (rangeStart vertices) + (rangeStart instances) + +-- | Finish recording of a render pass. +endRenderPass :: + -- | Render pass encoder on which to finish recording. + RenderPassEncoder -> + -- | IO action that finishes recording. + IO () +endRenderPass renderPassEncoder = do + let inst :: Instance + inst = renderPassEncoderInst renderPassEncoder + + RawFun.wgpuRenderPassEncoderEndPass + (wgpuHsInstance inst) + (wgpuRenderPassEncoder renderPassEncoder) diff --git a/src-internal/WGPU/Internal/SMaybe.hs b/src-internal/WGPU/Internal/SMaybe.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/SMaybe.hs @@ -0,0 +1,33 @@ +-- | +-- Module : WGPU.Internal.SMaybe +-- Description : Strict maybe. +module WGPU.Internal.SMaybe + ( -- * Types + SMaybe (SNothing, SJust), + + -- * Functions + fromSMaybe, + ) +where + +-- | Strict version of the 'Maybe' type. +data SMaybe a + = SNothing + | SJust !a + deriving (Eq, Show) + +-- | Return a value from an 'SMaybe' with a default. +-- +-- This function returns the 'SJust' value from an 'SMaybe', or the default +-- value if the 'SMaybe' is 'SNothing'. +fromSMaybe :: + -- | Default value. + a -> + -- | 'SMaybe' from which to return the 'SJust' value if possible. + SMaybe a -> + -- | 'SJust' value, if present, or the default value, if not. + a +fromSMaybe defaultValue sMaybe = + case sMaybe of + SNothing -> defaultValue + SJust providedValue -> providedValue diff --git a/src-internal/WGPU/Internal/Sampler.hs b/src-internal/WGPU/Internal/Sampler.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Sampler.hs @@ -0,0 +1,7 @@ +-- | +-- Module : WGPU.Internal.Sampler +-- Description : Texture sampling. +module WGPU.Internal.Sampler + ( + ) +where diff --git a/src-internal/WGPU/Internal/Shader.hs b/src-internal/WGPU/Internal/Shader.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Shader.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : WGPU.Internal.Shader +-- Description : Shader modules. +module WGPU.Internal.Shader + ( -- * Types + ShaderModule, + ShaderModuleDescriptor (..), + ShaderSource (..), + SPIRV (..), + WGSL (..), + ShaderEntryPoint (..), + + -- * Functions + createShaderModule, + createShaderModuleSPIRV, + createShaderModuleWGSL, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.String (IsString) +import Data.Text (Text) +import Data.Word (Word32, Word8) +import Foreign (Ptr, castPtr, sizeOf) +import Foreign.C (CChar) +import WGPU.Internal.ChainedStruct (ChainedStruct (EmptyChain, PtrChain)) +import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, ToRawPtr, raw, rawPtr, showWithPtr) +import qualified WGPU.Raw.Generated.Enum.WGPUSType as WGPUSType +import qualified WGPU.Raw.Generated.Fun as RawFun +import WGPU.Raw.Generated.Struct.WGPUShaderModuleDescriptor (WGPUShaderModuleDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPUShaderModuleDescriptor as WGPUShaderModuleDescriptor +import WGPU.Raw.Generated.Struct.WGPUShaderModuleSPIRVDescriptor (WGPUShaderModuleSPIRVDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPUShaderModuleSPIRVDescriptor as WGPUShaderModuleSPIRVDescriptor +import WGPU.Raw.Generated.Struct.WGPUShaderModuleWGSLDescriptor (WGPUShaderModuleWGSLDescriptor) +import qualified WGPU.Raw.Generated.Struct.WGPUShaderModuleWGSLDescriptor as WGPUShaderModuleWGSLDescriptor +import WGPU.Raw.Types (WGPUShaderModule (WGPUShaderModule)) + +------------------------------------------------------------------------------- + +-- | Handle to a compiled shader module. +newtype ShaderModule = ShaderModule {wgpuShaderModule :: WGPUShaderModule} + +instance Show ShaderModule where + show m = + let ShaderModule (WGPUShaderModule ptr) = m + in showWithPtr "ShaderModule" ptr + +instance Eq ShaderModule where + (==) m1 m2 = + let ShaderModule (WGPUShaderModule m1_ptr) = m1 + ShaderModule (WGPUShaderModule m2_ptr) = m2 + in m1_ptr == m2_ptr + +instance ToRaw ShaderModule WGPUShaderModule where + raw = pure . wgpuShaderModule + +------------------------------------------------------------------------------- + +-- | Create a shader module from either SPIR-V or WGSL source code. +createShaderModule :: + -- | Device for the shader. + Device -> + -- | Descriptor of the shader module. + ShaderModuleDescriptor -> + -- | IO action producing the shader module. + IO ShaderModule +createShaderModule device smd = evalContT $ do + let inst :: Instance + inst = deviceInst device + shaderModuleDescriptor_ptr <- rawPtr smd + rawShaderModule <- + liftIO $ + RawFun.wgpuDeviceCreateShaderModule + (wgpuHsInstance inst) + (wgpuDevice device) + shaderModuleDescriptor_ptr + pure (ShaderModule rawShaderModule) + +-- | Create a shader module from SPIR-V source code. +createShaderModuleSPIRV :: + -- | Device for which the shader should be created. + Device -> + -- | Debugging label for the shader. + Text -> + -- | Shader source code (SPIR-V bytestring). + SPIRV -> + -- | IO action creating the shader module. + IO ShaderModule +createShaderModuleSPIRV device label spirv = + createShaderModule device smd + where + smd :: ShaderModuleDescriptor + smd = + ShaderModuleDescriptor + { shaderLabel = label, + source = ShaderSourceSPIRV spirv + } + +-- | Create a shader module from WGSL source code. +createShaderModuleWGSL :: + -- | Device for which the shader should be created. + Device -> + -- | Debugging label for the shader. + Text -> + -- | Shader source code (WGSL source string). + WGSL -> + -- | IO action creating the shader module. + IO ShaderModule +createShaderModuleWGSL device label wgsl = + createShaderModule device smd + where + smd :: ShaderModuleDescriptor + smd = + ShaderModuleDescriptor + { shaderLabel = label, + source = ShaderSourceWGSL wgsl + } + +------------------------------------------------------------------------------- + +-- | Descriptor for a shader module. +data ShaderModuleDescriptor = ShaderModuleDescriptor + { -- | Debug label of the shader module. + shaderLabel :: !Text, + -- | Source code for the shader. + source :: !ShaderSource + } + deriving (Eq, Show) + +instance ToRaw ShaderModuleDescriptor WGPUShaderModuleDescriptor where + raw ShaderModuleDescriptor {..} = do + nextInChain_ptr <- + case source of + ShaderSourceSPIRV spirv -> do + ptr <- rawPtr spirv + rawPtr (PtrChain WGPUSType.ShaderModuleSPIRVDescriptor ptr) + ShaderSourceWGSL wgsl -> do + ptr <- rawPtr wgsl + rawPtr (PtrChain WGPUSType.ShaderModuleWGSLDescriptor ptr) + label_ptr <- rawPtr shaderLabel + pure + WGPUShaderModuleDescriptor.WGPUShaderModuleDescriptor + { nextInChain = nextInChain_ptr, + label = label_ptr + } + +------------------------------------------------------------------------------- + +-- | Source for a shader module. +data ShaderSource + = -- | Use shader source from a SPIRV module (pre-compiled). + ShaderSourceSPIRV !SPIRV + | -- | Use shader source from WGSL string. + ShaderSourceWGSL !WGSL + deriving (Eq, Show) + +-- | Pre-compiled SPIRV module bytes. +newtype SPIRV = SPIRV ByteString deriving (Eq, Show) + +instance ToRaw SPIRV WGPUShaderModuleSPIRVDescriptor where + raw (SPIRV bs) = + WGPUShaderModuleSPIRVDescriptor.WGPUShaderModuleSPIRVDescriptor + <$> raw (EmptyChain WGPUSType.ShaderModuleSPIRVDescriptor) + <*> pure + ( fromIntegral $ + ByteString.length bs `div` sizeOf (undefined :: Word32) + ) + <*> ((castPtr :: Ptr Word8 -> Ptr Word32) <$> rawPtr bs) + +-- | WGSL shader source code. +newtype WGSL = WGSL Text deriving (Eq, Show) + +instance ToRaw WGSL WGPUShaderModuleWGSLDescriptor where + raw (WGSL txt) = + WGPUShaderModuleWGSLDescriptor.WGPUShaderModuleWGSLDescriptor + <$> raw (EmptyChain WGPUSType.ShaderModuleWGSLDescriptor) + <*> rawPtr txt + +------------------------------------------------------------------------------- + +-- | Name of a shader entry point. +newtype ShaderEntryPoint = ShaderEntryPoint {unShaderEntryPoint :: Text} + deriving (Eq, Show, IsString) + +instance ToRawPtr ShaderEntryPoint CChar where + rawPtr = rawPtr . unShaderEntryPoint diff --git a/src-internal/WGPU/Internal/Surface.hs b/src-internal/WGPU/Internal/Surface.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Surface.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : WGPU.Internal.Surface +-- Description : Platform-specific surfaces. +-- +-- Device-specific surfaces. +module WGPU.Internal.Surface + ( -- * Types + Surface (..), + + -- * Functions + createGLFWSurface, + ) +where + +import qualified Graphics.UI.GLFW as GLFW +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, showWithPtr) +import qualified WGPU.Raw.GLFWSurface +import WGPU.Raw.Types (WGPUSurface (WGPUSurface)) + +------------------------------------------------------------------------------- + +-- | Handle to a presentable surface. +-- +-- A 'Surface' presents a platform-specific surface (eg. a window) on to which +-- rendered images may be presented. A 'Surface' can be created for a GLFW +-- window using 'createGLFWSurface'. +data Surface = Surface + { surfaceInst :: !Instance, + wgpuSurface :: !WGPUSurface + } + +instance Show Surface where + show s = + let Surface _ (WGPUSurface ptr) = s + in showWithPtr "Surface" ptr + +instance Eq Surface where + (==) s1 s2 = + let Surface _ (WGPUSurface s1_ptr) = s1 + Surface _ (WGPUSurface s2_ptr) = s2 + in s1_ptr == s2_ptr + +instance ToRaw Surface WGPUSurface where + raw = pure . wgpuSurface + +------------------------------------------------------------------------------- + +-- | Create a WGPU 'Surface' for a GLFW 'GLFW.Window'. +-- +-- This function is not part of the @wgpu-native@ API, but is part of the +-- Haskell API until the native WGPU API has a better story around windowing. +createGLFWSurface :: + -- | API instance. + Instance -> + -- | GLFW window for which the surface will be created. + GLFW.Window -> + -- | IO action to create the surface. + IO Surface +createGLFWSurface inst window = do + Surface inst + <$> WGPU.Raw.GLFWSurface.createSurface (wgpuHsInstance inst) window diff --git a/src-internal/WGPU/Internal/SwapChain.hs b/src-internal/WGPU/Internal/SwapChain.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/SwapChain.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : WGPU.Internal.SwapChain +-- Description : Swap chain. +module WGPU.Internal.SwapChain + ( -- * Types + SwapChain, + SwapChainDescriptor (..), + PresentMode (..), + + -- * Functions + getSwapChainPreferredFormat, + createSwapChain, + getSwapChainCurrentTextureView, + swapChainPresent, + ) +where + +import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (evalContT) +import Data.Text (Text) +import Data.Word (Word32) +import Foreign (Ptr, freeHaskellFunPtr, nullPtr) +import WGPU.Internal.Adapter (Adapter, wgpuAdapter) +import WGPU.Internal.Device (Device, deviceInst, wgpuDevice) +import WGPU.Internal.Instance (Instance, wgpuHsInstance) +import WGPU.Internal.Memory (ToRaw, raw, rawPtr, showWithPtr) +import WGPU.Internal.Surface (Surface, surfaceInst, wgpuSurface) +import WGPU.Internal.Texture (TextureFormat, TextureUsage, TextureView (TextureView), textureFormatFromRaw) +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 +import WGPU.Raw.Types (WGPUSurfaceGetPreferredFormatCallback, WGPUSwapChain (WGPUSwapChain)) + +------------------------------------------------------------------------------- + +data SwapChain = SwapChain + { swapChainInst :: !Instance, + wgpuSwapChain :: !WGPUSwapChain + } + +instance Show SwapChain where + show s = + let SwapChain _ (WGPUSwapChain ptr) = s + in showWithPtr "SwapChain" ptr + +instance Eq SwapChain where + (==) s1 s2 = + let SwapChain _ (WGPUSwapChain s1_ptr) = s1 + SwapChain _ (WGPUSwapChain s2_ptr) = s2 + in s1_ptr == s2_ptr + +instance ToRaw SwapChain WGPUSwapChain where + raw = pure . wgpuSwapChain + +------------------------------------------------------------------------------- + +-- | Describes a swapchain. +data SwapChainDescriptor = SwapChainDescriptor + { -- | Debugging label for the swap chain. + swapChainLabel :: !Text, + -- | The usage of the swap chain. The only supported usage is + -- 'TextureUsageRenderAttachment'. + usage :: !TextureUsage, + -- | Texture format of the swap chain. The only guaranteed formats are + -- 'TextureFormatBgra8Unorm' and 'TextureFormatBgra8UnormSrgb'. To + -- determine the preferred texture format for a surface, use the + -- 'getSwapChainPreferredFormat' function. + swapChainFormat :: !TextureFormat, + -- | Width of the swap chain. Must be the same size as the surface. + width :: !Word32, + -- | Height of the swap chain. Must be the same size as the surface. + height :: !Word32, + -- | Presentation mode of the swap chain. + presentMode :: !PresentMode + } + deriving (Eq, Show) + +instance ToRaw SwapChainDescriptor WGPUSwapChainDescriptor where + raw SwapChainDescriptor {..} = do + label_ptr <- rawPtr swapChainLabel + WGPUTextureUsage n_usage <- raw usage + n_format <- raw swapChainFormat + n_presentMode <- raw presentMode + pure + WGPUSwapChainDescriptor.WGPUSwapChainDescriptor + { nextInChain = nullPtr, + label = label_ptr, + usage = n_usage, + format = n_format, + width = width, + height = height, + presentMode = n_presentMode + } + +------------------------------------------------------------------------------- + +-- | Behaviour of the presentation engine based on frame rate. +data PresentMode + = -- | The presentation engine does __not__ wait for a vertical blanking + -- period and the request is presented immediately. This is a low-latency + -- presentation mode, but visible tearing may be observed. Will fallback to + -- @Fifo@ if unavailable on the selected platform and backend. Not optimal + -- for mobile. + PresentModeImmediate + | -- | The presentation engine waits for the next vertical blanking period to + -- update the current image, but frames may be submitted without delay. This + -- is a low-latency presentation mode and visible tearing will not be + -- observed. Will fallback to Fifo if unavailable on the selected platform + -- and backend. Not optimal for mobile. + PresentModeMailbox + | -- | The presentation engine waits for the next vertical blanking period to + -- update the current image. The framerate will be capped at the display + -- refresh rate, corresponding to the VSync. Tearing cannot be observed. + -- Optimal for mobile. + PresentModeFifo + deriving (Eq, Show) + +instance ToRaw PresentMode WGPUPresentMode where + raw pm = + pure $ + case pm of + PresentModeImmediate -> WGPUPresentMode.Immediate + PresentModeMailbox -> WGPUPresentMode.Mailbox + PresentModeFifo -> WGPUPresentMode.Fifo + +------------------------------------------------------------------------------- + +-- | Returns an optimal texture format to use for the swapchain with this +-- adapter and surface. +getSwapChainPreferredFormat :: + -- | @Surface@ for which to obtain an optimal texture format. + Surface -> + -- | @Adapter@ for which to obtain an optimal texture format. + Adapter -> + -- | IO action which returns the optimal texture format. + IO TextureFormat +getSwapChainPreferredFormat surface adapter = do + let inst :: Instance + inst = surfaceInst surface + + textureFormatMVar :: MVar WGPUTextureFormat <- newEmptyMVar + + let textureFormatCallback :: WGPUTextureFormat -> Ptr () -> IO () + textureFormatCallback tf _ = putMVar textureFormatMVar tf + + textureFormatCallback_c <- + mkSurfaceGetPreferredFormatCallback textureFormatCallback + + RawFun.wgpuSurfaceGetPreferredFormat + (wgpuHsInstance inst) + (wgpuSurface surface) + (wgpuAdapter adapter) + textureFormatCallback_c + nullPtr + + textureFormat <- textureFormatFromRaw <$> takeMVar textureFormatMVar + freeHaskellFunPtr textureFormatCallback_c + pure textureFormat + +foreign import ccall "wrapper" + mkSurfaceGetPreferredFormatCallback :: + (WGPUTextureFormat -> Ptr () -> IO ()) -> + IO WGPUSurfaceGetPreferredFormatCallback + +------------------------------------------------------------------------------- + +-- | Createa a new 'SwapChain' which targets a 'Surface'. +-- +-- To determine the preferred 'TextureFormat' for the 'Surface', use the +-- 'getSwapChainPreferredFormat' function. +createSwapChain :: + -- | @Device@ for which the @SwapChain@ will be created. + Device -> + -- | @Surface@ for which the @SwapChain@ will be created. + Surface -> + -- | Description of the @SwapChain@ to be created. + SwapChainDescriptor -> + -- | IO action which creates the swap chain. + IO SwapChain +createSwapChain device surface scd = evalContT $ do + let inst :: Instance + inst = deviceInst device + + swapChainDescriptor_ptr <- rawPtr scd + rawSwapChain <- + liftIO $ + RawFun.wgpuDeviceCreateSwapChain + (wgpuHsInstance inst) + (wgpuDevice device) + (wgpuSurface surface) + swapChainDescriptor_ptr + pure (SwapChain inst rawSwapChain) + +------------------------------------------------------------------------------- + +-- | Get the 'TextureView' for the current swap chain frame. +getSwapChainCurrentTextureView :: + -- | Swap chain from which to fetch the current texture view. + SwapChain -> + -- | IO action which returns the current swap chain texture view. + IO TextureView +getSwapChainCurrentTextureView swapChain = do + let inst :: Instance + inst = swapChainInst swapChain + TextureView + <$> RawFun.wgpuSwapChainGetCurrentTextureView + (wgpuHsInstance inst) + (wgpuSwapChain swapChain) + +------------------------------------------------------------------------------- + +-- | Present the latest swap chain image. +swapChainPresent :: + -- | Swap chain to present. + SwapChain -> + -- | IO action which presents the swap chain image. + IO () +swapChainPresent swapChain = do + let inst :: Instance + inst = swapChainInst swapChain + RawFun.wgpuSwapChainPresent (wgpuHsInstance inst) (wgpuSwapChain swapChain) diff --git a/src-internal/WGPU/Internal/Texture.hs b/src-internal/WGPU/Internal/Texture.hs new file mode 100644 --- /dev/null +++ b/src-internal/WGPU/Internal/Texture.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : WGPU.Internal.Texture +-- Description : Textures and texture views. +module WGPU.Internal.Texture + ( -- * Types + TextureView (..), + TextureFormat (..), + TextureUsage (..), + TextureViewDimension (..), + + -- * Functions + textureFormatFromRaw, + ) +where + +import WGPU.Internal.Memory (ToRaw, raw, showWithPtr) +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)) + +------------------------------------------------------------------------------- + +-- | Handle to a texture view. +-- +-- A 'TextureView' describes a texture and associated metadata needed by a +-- rendering pipeline or bind group. +newtype TextureView = TextureView {wgpuTextureView :: WGPUTextureView} + +instance Show TextureView where + show v = + let TextureView (WGPUTextureView ptr) = v + in showWithPtr "TextureView" ptr + +instance Eq TextureView where + (==) v1 v2 = + let TextureView (WGPUTextureView v1_ptr) = v1 + TextureView (WGPUTextureView v2_ptr) = v2 + in v1_ptr == v2_ptr + +instance ToRaw TextureView WGPUTextureView where + raw = pure . wgpuTextureView + +------------------------------------------------------------------------------- + +-- | Dimensions of a particular texture view. +data TextureViewDimension + = TextureViewDimension1D + | TextureViewDimension2D + | TextureViewDimension2DArray + | TextureViewDimensionCube + | TextureViewDimensionCubeArray + | TextureViewDimension3D + deriving (Eq, Show) + +instance ToRaw TextureViewDimension WGPUTextureViewDimension where + raw tvd = + pure $ + case tvd of + TextureViewDimension1D -> WGPUTextureViewDimension.D1D + TextureViewDimension2D -> WGPUTextureViewDimension.D2D + TextureViewDimension2DArray -> WGPUTextureViewDimension.D2DArray + TextureViewDimensionCube -> WGPUTextureViewDimension.Cube + TextureViewDimensionCubeArray -> WGPUTextureViewDimension.CubeArray + TextureViewDimension3D -> WGPUTextureViewDimension.D3D + +------------------------------------------------------------------------------- + +-- | Different ways you can use a texture. +-- +-- 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 + deriving (Eq, Show) + +instance ToRaw TextureUsage WGPUTextureUsage where + raw tu = + pure $ + case tu of + TextureUsageCopySrc -> WGPUTextureUsage.CopySrc + TextureUsageCopyDst -> WGPUTextureUsage.CopyDst + TextureUsageSampled -> WGPUTextureUsage.Sampled + TextureUsageStorage -> WGPUTextureUsage.Storage + TextureUsageRenderAttachment -> WGPUTextureUsage.RenderAttachment + +------------------------------------------------------------------------------- + +-- | Texture data format. +data TextureFormat + = TextureFormatR8Unorm + | TextureFormatR8Snorm + | TextureFormatR8Uint + | TextureFormatR8Sint + | TextureFormatR16Uint + | TextureFormatR16Sint + | TextureFormatR16Float + | TextureFormatRG8Unorm + | TextureFormatRG8Snorm + | TextureFormatRG8Uint + | TextureFormatRG8Sint + | TextureFormatR32Float + | TextureFormatR32Uint + | TextureFormatR32Sint + | TextureFormatRG16Uint + | TextureFormatRG16Sint + | TextureFormatRG16Float + | TextureFormatRGBA8Unorm + | TextureFormatRGBA8UnormSrgb + | TextureFormatRGBA8Snorm + | TextureFormatRGBA8Uint + | TextureFormatRGBA8Sint + | TextureFormatBGRA8Unorm + | TextureFormatBGRA8UnormSrgb + | TextureFormatRGB10A2Unorm + | TextureFormatRG11B10Ufloat + | TextureFormatRGB9E5Ufloat + | TextureFormatRG32Float + | TextureFormatRG32Uint + | TextureFormatRG32Sint + | TextureFormatRGBA16Uint + | TextureFormatRGBA16Sint + | TextureFormatRGBA16Float + | TextureFormatRGBA32Float + | TextureFormatRGBA32Uint + | TextureFormatRGBA32Sint + | TextureFormatDepth32Float + | TextureFormatDepth24Plus + | TextureFormatDepth24PlusStencil8 + | TextureFormatStencil8 + | TextureFormatBC1RGBAUnorm + | TextureFormatBC1RGBAUnormSrgb + | TextureFormatBC2RGBAUnorm + | TextureFormatBC2RGBAUnormSrgb + | TextureFormatBC3RGBAUnorm + | TextureFormatBC3RGBAUnormSrgb + | TextureFormatBC4RUnorm + | TextureFormatBC4RSnorm + | TextureFormatBC5RGUnorm + | TextureFormatBC5RGSnorm + | TextureFormatBC6HRGBUfloat + | TextureFormatBC6HRGBFloat + | TextureFormatBC7RGBAUnorm + | TextureFormatBC7RGBAUnormSrgb + deriving (Eq, Show) + +instance ToRaw TextureFormat WGPUTextureFormat where + raw tf = + pure $ + case tf of + TextureFormatR8Unorm -> WGPUTextureFormat.R8Unorm + TextureFormatR8Snorm -> WGPUTextureFormat.R8Snorm + TextureFormatR8Uint -> WGPUTextureFormat.R8Uint + TextureFormatR8Sint -> WGPUTextureFormat.R8Sint + TextureFormatR16Uint -> WGPUTextureFormat.R16Uint + TextureFormatR16Sint -> WGPUTextureFormat.R16Sint + TextureFormatR16Float -> WGPUTextureFormat.R16Float + TextureFormatRG8Unorm -> WGPUTextureFormat.RG8Unorm + TextureFormatRG8Snorm -> WGPUTextureFormat.RG8Snorm + TextureFormatRG8Uint -> WGPUTextureFormat.RG8Uint + TextureFormatRG8Sint -> WGPUTextureFormat.RG8Sint + TextureFormatR32Float -> WGPUTextureFormat.R32Float + TextureFormatR32Uint -> WGPUTextureFormat.R32Uint + TextureFormatR32Sint -> WGPUTextureFormat.R32Sint + TextureFormatRG16Uint -> WGPUTextureFormat.RG16Uint + TextureFormatRG16Sint -> WGPUTextureFormat.RG16Sint + TextureFormatRG16Float -> WGPUTextureFormat.RG16Float + TextureFormatRGBA8Unorm -> WGPUTextureFormat.RGBA8Unorm + TextureFormatRGBA8UnormSrgb -> WGPUTextureFormat.RGBA8UnormSrgb + TextureFormatRGBA8Snorm -> WGPUTextureFormat.RGBA8Snorm + TextureFormatRGBA8Uint -> WGPUTextureFormat.RGBA8Uint + TextureFormatRGBA8Sint -> WGPUTextureFormat.RGBA8Sint + TextureFormatBGRA8Unorm -> WGPUTextureFormat.BGRA8Unorm + TextureFormatBGRA8UnormSrgb -> WGPUTextureFormat.BGRA8UnormSrgb + TextureFormatRGB10A2Unorm -> WGPUTextureFormat.RGB10A2Unorm + TextureFormatRG11B10Ufloat -> WGPUTextureFormat.RG11B10Ufloat + TextureFormatRGB9E5Ufloat -> WGPUTextureFormat.RGB9E5Ufloat + TextureFormatRG32Float -> WGPUTextureFormat.RG32Float + TextureFormatRG32Uint -> WGPUTextureFormat.RG32Uint + TextureFormatRG32Sint -> WGPUTextureFormat.RG32Sint + TextureFormatRGBA16Uint -> WGPUTextureFormat.RGBA16Uint + TextureFormatRGBA16Sint -> WGPUTextureFormat.RGBA16Sint + TextureFormatRGBA16Float -> WGPUTextureFormat.RGBA16Float + TextureFormatRGBA32Float -> WGPUTextureFormat.RGBA32Float + TextureFormatRGBA32Uint -> WGPUTextureFormat.RGBA32Uint + TextureFormatRGBA32Sint -> WGPUTextureFormat.RGBA32Sint + TextureFormatDepth32Float -> WGPUTextureFormat.Depth32Float + TextureFormatDepth24Plus -> WGPUTextureFormat.Depth24Plus + TextureFormatDepth24PlusStencil8 -> + WGPUTextureFormat.Depth24PlusStencil8 + TextureFormatStencil8 -> WGPUTextureFormat.Stencil8 + TextureFormatBC1RGBAUnorm -> WGPUTextureFormat.BC1RGBAUnorm + TextureFormatBC1RGBAUnormSrgb -> WGPUTextureFormat.BC1RGBAUnormSrgb + TextureFormatBC2RGBAUnorm -> WGPUTextureFormat.BC2RGBAUnorm + TextureFormatBC2RGBAUnormSrgb -> WGPUTextureFormat.BC2RGBAUnormSrgb + TextureFormatBC3RGBAUnorm -> WGPUTextureFormat.BC3RGBAUnorm + TextureFormatBC3RGBAUnormSrgb -> WGPUTextureFormat.BC3RGBAUnormSrgb + TextureFormatBC4RUnorm -> WGPUTextureFormat.BC4RUnorm + TextureFormatBC4RSnorm -> WGPUTextureFormat.BC4RSnorm + TextureFormatBC5RGUnorm -> WGPUTextureFormat.BC5RGUnorm + TextureFormatBC5RGSnorm -> WGPUTextureFormat.BC5RGSnorm + TextureFormatBC6HRGBUfloat -> WGPUTextureFormat.BC6HRGBUfloat + TextureFormatBC6HRGBFloat -> WGPUTextureFormat.BC6HRGBFloat + TextureFormatBC7RGBAUnorm -> WGPUTextureFormat.BC7RGBAUnorm + TextureFormatBC7RGBAUnormSrgb -> WGPUTextureFormat.BC7RGBAUnormSrgb + +textureFormatFromRaw :: WGPUTextureFormat -> TextureFormat +textureFormatFromRaw rt = + case rt of + WGPUTextureFormat.R8Unorm -> TextureFormatR8Unorm + WGPUTextureFormat.R8Snorm -> TextureFormatR8Snorm + WGPUTextureFormat.R8Uint -> TextureFormatR8Uint + WGPUTextureFormat.R8Sint -> TextureFormatR8Sint + WGPUTextureFormat.R16Uint -> TextureFormatR16Uint + WGPUTextureFormat.R16Sint -> TextureFormatR16Sint + WGPUTextureFormat.R16Float -> TextureFormatR16Float + WGPUTextureFormat.RG8Unorm -> TextureFormatRG8Unorm + WGPUTextureFormat.RG8Snorm -> TextureFormatRG8Snorm + WGPUTextureFormat.RG8Uint -> TextureFormatRG8Uint + WGPUTextureFormat.RG8Sint -> TextureFormatRG8Sint + WGPUTextureFormat.R32Float -> TextureFormatR32Float + WGPUTextureFormat.R32Uint -> TextureFormatR32Uint + WGPUTextureFormat.R32Sint -> TextureFormatR32Sint + WGPUTextureFormat.RG16Uint -> TextureFormatRG16Uint + WGPUTextureFormat.RG16Sint -> TextureFormatRG16Sint + WGPUTextureFormat.RG16Float -> TextureFormatRG16Float + WGPUTextureFormat.RGBA8Unorm -> TextureFormatRGBA8Unorm + WGPUTextureFormat.RGBA8UnormSrgb -> TextureFormatRGBA8UnormSrgb + WGPUTextureFormat.RGBA8Snorm -> TextureFormatRGBA8Snorm + WGPUTextureFormat.RGBA8Uint -> TextureFormatRGBA8Uint + WGPUTextureFormat.RGBA8Sint -> TextureFormatRGBA8Sint + WGPUTextureFormat.BGRA8Unorm -> TextureFormatBGRA8Unorm + WGPUTextureFormat.BGRA8UnormSrgb -> TextureFormatBGRA8UnormSrgb + WGPUTextureFormat.RGB10A2Unorm -> TextureFormatRGB10A2Unorm + WGPUTextureFormat.RG11B10Ufloat -> TextureFormatRG11B10Ufloat + WGPUTextureFormat.RGB9E5Ufloat -> TextureFormatRGB9E5Ufloat + WGPUTextureFormat.RG32Float -> TextureFormatRG32Float + WGPUTextureFormat.RG32Uint -> TextureFormatRG32Uint + WGPUTextureFormat.RG32Sint -> TextureFormatRG32Sint + WGPUTextureFormat.RGBA16Uint -> TextureFormatRGBA16Uint + WGPUTextureFormat.RGBA16Sint -> TextureFormatRGBA16Sint + WGPUTextureFormat.RGBA16Float -> TextureFormatRGBA16Float + WGPUTextureFormat.RGBA32Float -> TextureFormatRGBA32Float + WGPUTextureFormat.RGBA32Uint -> TextureFormatRGBA32Uint + WGPUTextureFormat.RGBA32Sint -> TextureFormatRGBA32Sint + WGPUTextureFormat.Depth32Float -> TextureFormatDepth32Float + WGPUTextureFormat.Depth24Plus -> TextureFormatDepth24Plus + WGPUTextureFormat.Depth24PlusStencil8 -> TextureFormatDepth24PlusStencil8 + WGPUTextureFormat.Stencil8 -> TextureFormatStencil8 + WGPUTextureFormat.BC1RGBAUnorm -> TextureFormatBC1RGBAUnorm + WGPUTextureFormat.BC1RGBAUnormSrgb -> TextureFormatBC1RGBAUnormSrgb + WGPUTextureFormat.BC2RGBAUnorm -> TextureFormatBC2RGBAUnorm + WGPUTextureFormat.BC2RGBAUnormSrgb -> TextureFormatBC2RGBAUnormSrgb + WGPUTextureFormat.BC3RGBAUnorm -> TextureFormatBC3RGBAUnorm + WGPUTextureFormat.BC3RGBAUnormSrgb -> TextureFormatBC3RGBAUnormSrgb + WGPUTextureFormat.BC4RUnorm -> TextureFormatBC4RUnorm + WGPUTextureFormat.BC4RSnorm -> TextureFormatBC4RSnorm + WGPUTextureFormat.BC5RGUnorm -> TextureFormatBC5RGUnorm + WGPUTextureFormat.BC5RGSnorm -> TextureFormatBC5RGSnorm + WGPUTextureFormat.BC6HRGBUfloat -> TextureFormatBC6HRGBUfloat + WGPUTextureFormat.BC6HRGBFloat -> TextureFormatBC6HRGBFloat + WGPUTextureFormat.BC7RGBAUnorm -> TextureFormatBC7RGBAUnorm + WGPUTextureFormat.BC7RGBAUnormSrgb -> TextureFormatBC7RGBAUnormSrgb + _ -> error $ "Unexpected WGPUTextureFormat" <> show rt diff --git a/src/WGPU.hs b/src/WGPU.hs new file mode 100644 --- /dev/null +++ b/src/WGPU.hs @@ -0,0 +1,344 @@ +-- | +-- Module : WGPU +-- Description : WebGPU Native +-- License : BSD-3-Clause +-- Copyright : Copyright (C) Jonathan Merritt 2021 +-- Maintainer : Jonathan Merritt +-- Stability : experimental +-- Portability : macOS +-- +-- Layout of this module should be guided by the evolving +-- . +module WGPU + ( -- ** Introduction + -- $introduction + + -- * Initialization #initialization# + -- $initialization + Instance, + withInstance, + + -- * Surface #surface# + -- $surface + Surface, + createGLFWSurface, + + -- * Adapter #adapter# + -- $adapter + Adapter, + requestAdapter, + + -- * Device #device# + -- $device + Device, + DeviceDescriptor (..), + Limits (..), + Features (..), + requestDevice, + + -- * Textures and Views + TextureView, + TextureViewDimension (..), + TextureFormat (..), + TextureUsage (..), + + -- * Swapchain + SwapChain, + SwapChainDescriptor (..), + PresentMode (..), + getSwapChainPreferredFormat, + createSwapChain, + getSwapChainCurrentTextureView, + swapChainPresent, + + -- * Samplers + + -- * Resource Binding + BindGroupLayout, + BindGroupLayoutDescriptor (..), + BindGroupLayoutEntry (..), + Binding (..), + ShaderStage (..), + BindingType (..), + BufferBindingLayout (..), + SamplerBindingLayout (..), + TextureBindingLayout (..), + StorageTextureBindingLayout (..), + StorageTextureAccess (..), + TextureSampleType (..), + BufferBindingType (..), + createBindGroupLayout, + + -- * Shader Modules + ShaderModule, + ShaderModuleDescriptor (..), + ShaderSource (..), + SPIRV (..), + WGSL (..), + ShaderEntryPoint (..), + createShaderModule, + createShaderModuleSPIRV, + createShaderModuleWGSL, + + -- * Pipelines + + -- ** Compute + + -- ** Render + PipelineLayout, + RenderPipeline, + PipelineLayoutDescriptor (..), + RenderPipelineDescriptor (..), + VertexFormat (..), + VertexAttribute (..), + InputStepMode (..), + VertexBufferLayout (..), + VertexState (..), + PrimitiveTopology (..), + IndexFormat (..), + FrontFace (..), + CullMode (..), + PrimitiveState (..), + StencilOperation (..), + StencilState (..), + DepthBiasState (..), + DepthStencilState (..), + MultisampleState (..), + BlendFactor (..), + BlendOperation (..), + BlendComponent (..), + BlendState (..), + ColorWriteMask (..), + ColorTargetState (..), + FragmentState (..), + createPipelineLayout, + createRenderPipeline, + colorWriteMaskAll, + + -- * Command Buffers + CommandBuffer, + + -- * Command Encoding + CommandEncoder, + RenderPassEncoder, + Color (..), + LoadOp (..), + StoreOp (..), + Operations (..), + RenderPassColorAttachment (..), + RenderPassDepthStencilAttachment (..), + RenderPassDescriptor (..), + Range (..), + createCommandEncoder, + commandEncoderFinish, + beginRenderPass, + renderPassSetPipeline, + renderPassDraw, + endRenderPass, + + -- * Queue + Queue, + getQueue, + queueSubmit, + + -- * Version + Version (..), + getVersion, + versionToText, + + -- * Logging + LogLevel (..), + LogCallback, + setLogLevel, + logStdout, + logLevelToText, + + -- * Multipurpose + CompareFunction (..), + + -- * Extras + + -- ** Strict Maybe + SMaybe (..), + ) +where + +import WGPU.Internal.Adapter +import WGPU.Internal.Binding +import WGPU.Internal.Color +import WGPU.Internal.CommandBuffer +import WGPU.Internal.CommandEncoder +import WGPU.Internal.Device +import WGPU.Internal.Instance +import WGPU.Internal.Multipurpose +import WGPU.Internal.Pipeline +import WGPU.Internal.Queue +import WGPU.Internal.RenderPass +import WGPU.Internal.SMaybe +import WGPU.Internal.Shader +import WGPU.Internal.Surface +import WGPU.Internal.SwapChain +import WGPU.Internal.Texture + +------------------------------------------------------------------------------- + +-- $introduction +-- +-- === Introduction to WebGPU +-- +-- WebGPU is a future web standard for graphics and compute, developed by the +-- W3C. It is currently (August 2021) an emerging technology, and not yet +-- stable. In addition to its , +-- there are also early attempts to create a native binding (ie. a C language +-- binding). Two implementations of the native binding are: +-- +-- * : a Mozilla-backed +-- WebGPU native implementation, written in Rust, used in the Firefox web +-- browser. This is the binding to which this Haskell library is currently +-- tied. +-- +-- * : a Google-backed WebGPU native +-- implementation, written in C++, used in the Chrome web browser. In the +-- future, we hope to support this backend too. +-- +-- The native bindings to WebGPU have the potential to become a portable, +-- next-generation GPU API which is easy to use. Vulkan is also currently +-- available across platforms, but it is very low-level. In the opinion of the +-- author of this package, Vulkan is very difficult to use directly from +-- Haskell. It would benefit greatly from a shim layer which performs common +-- tasks and streamlines many operations. Not unexpectedly, that is exactly the +-- role that WebGPU native can play. +-- +-- === Platform Support +-- +-- Currently, only macOS (with the Metal backend) is supported. The limitation +-- is not fundamental and only exists because, so far, only macOS surface +-- creation has been implemented. In the future, other backends should be added. +-- +-- === Dependence on GLFW-b +-- +-- This package currently uses only +-- +-- for windowing and event processing. Clearly, it is undesirable to be +-- tied to only a single library for this purpose, when options like +-- are available and might be +-- preferred by many users. +-- +-- GFLW is used because it is the windowing library used in the C examples from +-- @wgpu-native@ and it exposes an API to obtain a pointer to the underlying +-- windowing system's native window. In the future, other options will be +-- investigated as time permits. +-- +-- === Structure of Bindings +-- +-- The bindings to @wgpu-native@ are structured in three packages: +-- +-- 1. The @wgpu-raw-hs-codegen@ package is a code generator for the raw +-- bindings. It creates all the packages named @WGPU.Raw.Generated.*@ +-- (without exception!), using a custom code generator based on +-- `langage-c`. This package is not in Hackage, since it is only used +-- offline. +-- +-- 2. The +-- package provides raw bindings to @wgpu-native@. These raw bindings are +-- mostly auto-generated, but have some manual curation of top-level types +-- and function aliases. They are "raw" in the sense that they contain raw +-- pointers and are not usable without manual management of memory to +-- construct all the C structs that must be passed to the API. +-- +-- 3. The @wgpu-hs@ package (this one) provides high-level bindings. These +-- bindings are written manually. They are improvements on the raw +-- bindings in the following ways: +-- +-- - There are no more raw @Ptr@ types. Memory for structs passed to the +-- raw API is managed using a type class (@ToRaw@) that encapsulates a +-- mapping between high-level API types and raw types. The possibility +-- to allocate memory as part of this conversion (and later free it) is +-- achieved by embedding conversion to the raw types inside the @ContT@ +-- continuation monad. +-- +-- - There are no callbacks. Several WebGPU native calls use callbacks to +-- indicate completion rather than blocking. The author decided that, in +-- the Haskell context, blocking was probably preferable. So, +-- internally, these calls are converted into a blocking form by waiting +-- on @MVar@s that are set by the callbacks. +-- +-- - Several parts of the API are tweaked slightly to more closely +-- resemble the Rust API. This is done in cases where, for example, a +-- parameter to the C API is unused except in one branch of a sum type. +-- When this can be done easily enough, it is preferred to using the +-- flattened "union" approach. +-- +-- - Names are de-duplicated. Where possible, names are identical to the C +-- API (sometimes with prefixes removed). However, where name conflicts +-- exist, names are changed to somewhat-idiomatic Haskell variants. +-- +-- === Native Library Handling +-- +-- The native library for @wgpu-native@ is not required at compile-time for this +-- package. Indeed, other packages containing executables that depend on this +-- one can be compiled without the native library! Instead, the library is +-- loaded dynamically and its symbols bound at runtime. This has the benefit +-- that the Haskell tooling need not be concerned with handling a Rust library +-- (yay!), but it is a point of common failure at runtime. To achieve this +-- independence, the header files for @wgpu-native@ are packaged inside +-- @wgpu-raw-hs@. Of course, care should be taken to ensure that a +-- fully-compatible version of the library is used at runtime. + +------------------------------------------------------------------------------- + +-- $initialization +-- +-- The first step in using these Haskell bindings is to obtain an 'Instance'. +-- This acts as a handle to the rest of the API. An 'Instance' is obtained at +-- runtime by loading a dynamic library containing the WGPU binding symbols. +-- Currently, only the C\/Rust library from +-- is supported. +-- +-- To load the dynamic library and obtain an instance, use the +-- 'withInstance' bracketing function: +-- +-- @ +-- 'withInstance' "libwgpu_native.dylib" (Just 'logStdout') $ \inst -> do +-- -- set the logging level (optional) +-- 'setLogLevel' inst 'Warn' +-- -- run the rest of the program... +-- @ +-- +-- After creating an 'Instance', you may next want to +-- . + +------------------------------------------------------------------------------- + +-- $surface +-- +-- A 'Surface' is a handle to a platform-specific presentable surface, like a +-- window. Currently, only GLFW windows are supported for surface creation. +-- Once you have a GLFW window, you may create a 'Surface' for it using the +-- 'createGLFWSurface' function. +-- +-- Once you have a 'Surface', the next step is usually to +-- that is compatible with it. + +------------------------------------------------------------------------------- + +-- $adapter +-- +-- An 'Adapter' is a handle to a physical device. For example, a physical +-- display adaptor (GPU) or a software renderer. Currently you obtain an adapter +-- using 'requestAdapter', which requests an adapter that is compatible with an +-- existing 'Surface'. +-- +-- After obtaining an adapter, you will typically want to +-- . + +------------------------------------------------------------------------------- + +-- $device +-- +-- A 'Device' is an open connection to a graphics and/or compute device. A +-- 'Device' is created using the 'requestDevice' function. +-- +-- (According to the WebGPU API documentation, a 'Device' may also be "lost". +-- However, it's not yet clear how that event will be signalled to the C API, +-- nor how to handle it.) diff --git a/wgpu-hs.cabal b/wgpu-hs.cabal new file mode 100644 --- /dev/null +++ b/wgpu-hs.cabal @@ -0,0 +1,91 @@ +cabal-version: 3.0 +name: wgpu-hs +version: 0.1.0.0 +synopsis: WGPU +description: A high-level binding to WGPU. +bug-reports: https://github.com/lancelet/wgpu-hs/issues +license: BSD-3-Clause +author: Jonathan Merritt +maintainer: j.s.merritt@gmail.com +copyright: Copyright (C) Jonathan Merritt, 2021 +category: Graphics +extra-source-files: CHANGELOG.md + +flag examples + description: Build the examples + default: True + manual: True + +common base + default-language: Haskell2010 + build-depends: base ^>=4.14.0.0 + +common ghc-options + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + +library wgpu-hs-internal + import: base, ghc-options + hs-source-dirs: src-internal + exposed-modules: + WGPU.Internal.Adapter + WGPU.Internal.Binding + WGPU.Internal.ChainedStruct + WGPU.Internal.Color + WGPU.Internal.CommandBuffer + WGPU.Internal.CommandEncoder + WGPU.Internal.Device + WGPU.Internal.Instance + WGPU.Internal.Memory + WGPU.Internal.Multipurpose + WGPU.Internal.Pipeline + WGPU.Internal.Queue + WGPU.Internal.RenderPass + WGPU.Internal.Sampler + WGPU.Internal.Shader + WGPU.Internal.SMaybe + WGPU.Internal.Surface + WGPU.Internal.SwapChain + WGPU.Internal.Texture + + build-depends: + , bytestring + , data-default + , GLFW-b + , text + , transformers + , vector + , wgpu-raw-hs + +library + import: base, ghc-options + hs-source-dirs: src + build-depends: + , bytestring ^>=0.10.12 + , data-default ^>=0.7.1.1 + , GLFW-b ^>=3.3.0 + , text ^>=1.2.4 + , transformers ^>=0.5.6 + , vector ^>=0.12.3 + , wgpu-hs-internal + , wgpu-raw-hs ==0.1.0.3 + + exposed-modules: WGPU + +executable triangle + import: base, ghc-options + + if flag(examples) + build-depends: + , data-default ^>=0.7.1.1 + , GLFW-b ^>=3.3.0 + , text ^>=1.2.4 + , transformers ^>=0.5.6 + , wgpu-hs + + else + buildable: False + + hs-source-dirs: examples/triangle + main-is: Main.hs