Skip to content

Commit a6d7222

Browse files
lanceletlancelet
committed
Initial high-level API
- Added `wgpu-hs` package. - Added enough of the API to build the triangle example.
1 parent 841937c commit a6d7222

30 files changed

+4200
-632
lines changed

‎.gitignore

+1
Original file line numberDiff line numberDiff line change
@@ -4,3 +4,4 @@
44
tmp/
55

66
**/dist-newstyle
7+
**/.ghc.environment.*

‎README.md

+14-12
Original file line numberDiff line numberDiff line change
@@ -39,17 +39,19 @@ To build and run an example:
3939
1. Clone the repository and make sure that all git submodules are checked
4040
out:
4141

42-
```
43-
git clone https://github.com/lancelet/wgpu-hs.git
44-
cd wgpu-hs
45-
git submodule update --init --recursive
46-
```
42+
```
43+
git clone https://github.com/lancelet/wgpu-hs.git
44+
cd wgpu-hs
45+
git submodule update --init --recursive
46+
```
4747
48-
2. Build the Rust libraries:
48+
2. Build the Rust libraries. The `WGPU_NATIVE_VERSION` environment variable
49+
is optional, but if it is supplied, it bakes the specified version number
50+
into the dynamic library binary.
4951
5052
```
5153
pushd wgpu-raw-hs-codegen/wgpu-native
52-
make lib-native # you will need a Rust toolchain
54+
WGPU_NATIVE_VERSION='v0.9.2.2' make lib-native
5355
popd
5456
```
5557
@@ -66,13 +68,13 @@ To build and run an example:
6668
4. Build and run the `triangle` example:
6769
6870
```
71+
export METAL_DEVICE_WRAPPER_TYPE=1
6972
cabal run triangle
7073
```
7174
72-
If everything went well, you should see a really rubbish triangle demo:
75+
The environment variable `METAL_DEVICE_WRAPPER_TYPE` enables Metal API
76+
validation.
77+
78+
If everything went well, you should see the initial triangle demo:
7379
7480
![triangle demo](triangle-demo.png)
75-
76-
(The demo is so rubbish that something is wrong with the background color.
77-
These are early days, and it simply demonstrates that we can get something on
78-
the screen!)

‎cabal.project

+3
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,9 @@
11
packages:
22
./wgpu-raw-hs-codegen/wgpu-raw-hs-codegen.cabal
33
./wgpu-raw-hs/wgpu-raw-hs.cabal
4+
./wgpu-hs/wgpu-hs.cabal
45

56
constraints:
67
bindings-GLFW +ExposeNative
8+
9+
write-ghc-environment-files: always

‎triangle-demo.png

67.8 KB
Loading

‎wgpu-hs/CHANGELOG.md

+6
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
# Revision history for wgpu-hs
2+
3+
## 0.1.0.0 -- YYYY-mm-dd
4+
5+
- Initial (incomplete) API bindings started.
6+
- Working `triangle` example.

‎wgpu-hs/examples/triangle/Main.hs

+190
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,190 @@
1+
{-# LANGUAGE OverloadedLists #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
5+
-- | Let's draw a triangle!
6+
module Main (main) where
7+
8+
import Control.Monad (unless)
9+
import Control.Monad.Trans.Class (lift)
10+
import Control.Monad.Trans.Except (runExceptT)
11+
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT)
12+
import Data.Default (def)
13+
import Data.Text (Text)
14+
import qualified Data.Text as Text
15+
import qualified Data.Text.IO as TextIO
16+
import qualified Graphics.UI.GLFW as GLFW
17+
import System.Exit (exitFailure)
18+
import qualified WGPU
19+
20+
main :: IO ()
21+
main = do
22+
TextIO.putStrLn "Triangle Example"
23+
24+
-- start GLFW
25+
initResult <- GLFW.init
26+
unless initResult $ do
27+
TextIO.putStrLn "Failed to initialize GLFW"
28+
exitFailure
29+
30+
-- create the GLFW window without a "client API"
31+
let initWidth, initHeight :: Int
32+
initWidth = 640
33+
initHeight = 480
34+
GLFW.windowHint (GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI)
35+
window <- do
36+
mWin <- GLFW.createWindow initWidth initHeight "Triangle" Nothing Nothing
37+
case mWin of
38+
Just w -> pure w
39+
Nothing -> do
40+
TextIO.putStrLn "Failed to create GLFW window"
41+
exitFailure
42+
43+
WGPU.withInstance "libwgpu_native.dylib" (Just WGPU.logStdout) $ \inst -> do
44+
-- set the logging level
45+
WGPU.setLogLevel inst WGPU.Warn
46+
47+
-- print the version of the WGPU library
48+
version <- WGPU.getVersion inst
49+
TextIO.putStrLn $ "WGPU version: " <> WGPU.versionToText version
50+
51+
-- fetch resources (surface, adpater, device)
52+
Resources {..} <- getResources inst window >>= getOrFail
53+
54+
shader <- WGPU.createShaderModuleWGSL device "shader" shaderSrc
55+
swapChainFormat <- WGPU.getSwapChainPreferredFormat surface adapter
56+
swapChain <-
57+
WGPU.createSwapChain
58+
device
59+
surface
60+
WGPU.SwapChainDescriptor
61+
{ swapChainLabel = "SwapChain",
62+
usage = WGPU.TextureUsageRenderAttachment,
63+
swapChainFormat = swapChainFormat,
64+
width = fromIntegral initWidth,
65+
height = fromIntegral initHeight,
66+
presentMode = WGPU.PresentModeFifo
67+
}
68+
pipelineLayout <-
69+
WGPU.createPipelineLayout
70+
device
71+
(WGPU.PipelineLayoutDescriptor "Pipeline" [])
72+
pipeline <-
73+
WGPU.createRenderPipeline
74+
device
75+
WGPU.RenderPipelineDescriptor
76+
{ renderPipelineLabel = "Render Pipeline",
77+
layout = WGPU.SJust pipelineLayout,
78+
vertex = WGPU.VertexState shader "vs_main" [],
79+
primitive = def,
80+
depthStencil = WGPU.SNothing,
81+
multisample = WGPU.MultisampleState 1 0xFFFFFFFF False,
82+
fragment =
83+
WGPU.SJust $
84+
WGPU.FragmentState
85+
shader
86+
"fs_main"
87+
[ WGPU.ColorTargetState
88+
swapChainFormat
89+
(WGPU.SJust (WGPU.BlendState def def))
90+
WGPU.colorWriteMaskAll
91+
]
92+
}
93+
94+
let loop = do
95+
-- render
96+
nextTexture <- WGPU.getSwapChainCurrentTextureView swapChain
97+
encoder <- WGPU.createCommandEncoder device "Command Encoder"
98+
renderPass <-
99+
WGPU.beginRenderPass
100+
encoder
101+
( WGPU.RenderPassDescriptor
102+
{ renderPassLabel = "Render Pass",
103+
colorAttachments =
104+
[ WGPU.RenderPassColorAttachment
105+
nextTexture
106+
WGPU.SNothing
107+
( WGPU.Operations
108+
(WGPU.LoadOpClear (WGPU.Color 0 0 0 1))
109+
WGPU.StoreOpStore
110+
)
111+
],
112+
depthStencilAttachment = WGPU.SNothing
113+
}
114+
)
115+
WGPU.renderPassSetPipeline renderPass pipeline
116+
WGPU.renderPassDraw renderPass (WGPU.Range 0 3) (WGPU.Range 0 1)
117+
WGPU.endRenderPass renderPass
118+
commandBuffer <- WGPU.commandEncoderFinish encoder "Command Buffer"
119+
WGPU.queueSubmit queue [commandBuffer]
120+
WGPU.swapChainPresent swapChain
121+
122+
-- handle GLFW quit event
123+
GLFW.pollEvents
124+
shouldClose <- GLFW.windowShouldClose window
125+
unless shouldClose loop
126+
127+
loop
128+
129+
-- close down GLFW
130+
GLFW.destroyWindow window
131+
GLFW.terminate
132+
133+
newtype Error = Error Text deriving (Eq, Show)
134+
135+
getOrFail :: Either Error a -> IO a
136+
getOrFail ma =
137+
case ma of
138+
Right x -> pure x
139+
Left err -> failWith err
140+
141+
failWith :: Error -> IO a
142+
failWith (Error err) = do
143+
TextIO.putStrLn err
144+
exitFailure
145+
146+
data Resources = Resources
147+
{ surface :: WGPU.Surface,
148+
adapter :: WGPU.Adapter,
149+
device :: WGPU.Device,
150+
queue :: WGPU.Queue
151+
}
152+
153+
getResources :: WGPU.Instance -> GLFW.Window -> IO (Either Error Resources)
154+
getResources inst window = runExceptT $ do
155+
-- fetch a surface for the window
156+
surface <- lift $ WGPU.createGLFWSurface inst window
157+
-- fetch an adapter for the surface
158+
adapter <-
159+
maybeToExceptT
160+
(Error "Failed to obtain WGPU Adapter")
161+
(MaybeT $ WGPU.requestAdapter surface)
162+
-- fetch a device for the adapter
163+
let deviceDescriptor :: WGPU.DeviceDescriptor
164+
deviceDescriptor = def {WGPU.limits = def {WGPU.maxBindGroups = 1}}
165+
device <-
166+
maybeToExceptT
167+
(Error "Failed to obtain WGPU Device")
168+
(MaybeT $ WGPU.requestDevice adapter deviceDescriptor)
169+
170+
queue <- lift $ WGPU.getQueue device
171+
172+
pure Resources {..}
173+
174+
shaderSrc :: WGPU.WGSL
175+
shaderSrc =
176+
WGPU.WGSL $
177+
Text.intercalate
178+
"\n"
179+
[ "[[stage(vertex)]]",
180+
"fn vs_main([[builtin(vertex_index)]] in_vertex_index: u32) -> [[builtin(position)]] vec4<f32> {",
181+
" let x = f32(i32(in_vertex_index) - 1);",
182+
" let y = f32(i32(in_vertex_index & 1u) * 2 - 1);",
183+
" return vec4<f32>(x, y, 0.0, 1.0);",
184+
"}",
185+
"",
186+
"[[stage(fragment)]]",
187+
"fn fs_main([[builtin(position)]] in: vec4<f32>) -> [[location(0)]] vec4<f32> {",
188+
" return vec4<f32>(in.x/640.0, in.y/480.0, 1.0, 1.0);",
189+
"}"
190+
]

‎wgpu-hs/src-internal/WGPU/Internal/Adapter.hs

+109
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,109 @@
1+
{-# LANGUAGE ForeignFunctionInterface #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
6+
-- |
7+
-- Module : WGPU.Internal.Adapter
8+
-- Description : Adapter (physical device).
9+
module WGPU.Internal.Adapter
10+
( -- * Types
11+
Adapter (..),
12+
13+
-- * Functions
14+
requestAdapter,
15+
)
16+
where
17+
18+
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
19+
import Control.Monad.IO.Class (liftIO)
20+
import Control.Monad.Trans.Cont (evalContT)
21+
import Foreign (freeHaskellFunPtr, nullPtr)
22+
import Foreign.Ptr (Ptr)
23+
import WGPU.Internal.Instance (Instance, wgpuHsInstance)
24+
import WGPU.Internal.Memory (ToRaw, raw, rawPtr, showWithPtr)
25+
import WGPU.Internal.Surface (Surface, surfaceInst)
26+
import qualified WGPU.Raw.Generated.Fun as RawFun
27+
import WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions
28+
( WGPURequestAdapterOptions,
29+
)
30+
import qualified WGPU.Raw.Generated.Struct.WGPURequestAdapterOptions as WGPURequestAdapterOptions
31+
import WGPU.Raw.Types
32+
( WGPUAdapter (WGPUAdapter),
33+
WGPUInstance (WGPUInstance),
34+
WGPURequestAdapterCallback,
35+
)
36+
37+
-------------------------------------------------------------------------------
38+
39+
-- | Handle to a physical graphics and/or compute device.
40+
--
41+
-- Request an 'Adapter' for a 'Surface' using the 'requestAdapter' function.
42+
data Adapter = Adapter
43+
{ adapterInst :: !Instance,
44+
wgpuAdapter :: !WGPUAdapter
45+
}
46+
47+
instance Show Adapter where
48+
show a =
49+
let Adapter _ (WGPUAdapter ptr) = a
50+
in showWithPtr "Adapter" ptr
51+
52+
instance Eq Adapter where
53+
(==) a1 a2 =
54+
let Adapter _ (WGPUAdapter a1_ptr) = a1
55+
Adapter _ (WGPUAdapter a2_ptr) = a2
56+
in a1_ptr == a2_ptr
57+
58+
instance ToRaw Adapter WGPUAdapter where
59+
raw = pure . wgpuAdapter
60+
61+
-------------------------------------------------------------------------------
62+
63+
-- | Request an 'Adapter' that is compatible with a given 'Surface'.
64+
--
65+
-- This action blocks until an available adapter is returned.
66+
requestAdapter ::
67+
-- | Existing surface for which to request an @Adapter@.
68+
Surface ->
69+
-- | The returned @Adapter@, if it could be retrieved.
70+
IO (Maybe Adapter)
71+
requestAdapter surface = evalContT $ do
72+
let inst = surfaceInst surface
73+
74+
adapterMVar :: MVar WGPUAdapter <- liftIO newEmptyMVar
75+
76+
let adapterCallback :: WGPUAdapter -> Ptr () -> IO ()
77+
adapterCallback adapter _ = putMVar adapterMVar adapter
78+
adapterCallback_c <- liftIO $ mkAdapterCallback adapterCallback
79+
80+
requestAdapterOptions_ptr <- rawPtr (RequestAdapterOptions surface)
81+
liftIO $
82+
RawFun.wgpuInstanceRequestAdapter
83+
(wgpuHsInstance inst)
84+
(WGPUInstance nullPtr)
85+
requestAdapterOptions_ptr
86+
adapterCallback_c
87+
nullPtr
88+
89+
adapter <- liftIO $ takeMVar adapterMVar
90+
liftIO $ freeHaskellFunPtr adapterCallback_c
91+
92+
pure $ case adapter of
93+
WGPUAdapter ptr | ptr == nullPtr -> Nothing
94+
WGPUAdapter _ -> Just (Adapter inst adapter)
95+
96+
foreign import ccall "wrapper"
97+
mkAdapterCallback ::
98+
(WGPUAdapter -> Ptr () -> IO ()) -> IO WGPURequestAdapterCallback
99+
100+
newtype RequestAdapterOptions = RequestAdapterOptions {compatibleSurface :: Surface}
101+
102+
instance ToRaw RequestAdapterOptions WGPURequestAdapterOptions where
103+
raw RequestAdapterOptions {..} = do
104+
n_surface <- raw compatibleSurface
105+
pure
106+
WGPURequestAdapterOptions.WGPURequestAdapterOptions
107+
{ nextInChain = nullPtr,
108+
compatibleSurface = n_surface
109+
}

0 commit comments

Comments
 (0)