{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module WGPU.BoneYard.SimpleSDL
(
SwapChainState,
emptySwapChainState,
withSwapChain,
Buffers,
BufferName,
emptyBuffers,
createBuffer,
createBufferInit,
getBuffer,
Textures,
TextureName,
emptyTextures,
createTexture,
getTexture,
BindGroups,
BindGroupName,
emptyBindGroups,
createBindGroup,
getBindGroup,
RenderPipelineName,
RenderPipelines,
emptyRenderPipelines,
createRenderPipeline,
getRenderPipeline,
ShaderName,
Shaders,
emptyShaders,
compileWGSL,
compileWGSL_,
getShader,
Params (..),
Resources (..),
loadResources,
getWindow,
getDrawableSize,
AppException (..),
)
where
import Control.Concurrent (MVar, modifyMVar, modifyMVar_, newMVar, withMVar)
import Control.Exception.Safe (Exception, MonadThrow, throwM)
import Control.Lens (lens)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
import Control.Monad.Trans.Resource (MonadResource, allocate)
import Data.Default (def)
import Data.Has (Has, getter, hasLens)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.String (IsString)
import Data.Text (Text)
import Data.Word (Word32)
import GHC.Generics (Generic)
import SDL (Window)
import qualified SDL
import WGPU
( Adapter,
BindGroup,
BindGroupDescriptor,
Buffer,
BufferDescriptor (BufferDescriptor),
BufferUsage,
ByteSize,
Device,
DeviceDescriptor,
Extent3D,
Instance,
Queue,
ReadableMemoryBuffer,
RenderPipeline,
RenderPipelineDescriptor,
SMaybe,
ShaderModule,
Surface,
SwapChain,
Texture,
TextureDescriptor (TextureDescriptor),
TextureDimension,
TextureFormat,
TextureUsage,
WGSL,
)
import qualified WGPU
import qualified WGPU.Classy as C
import qualified WGPU.SDL.Surface
newtype SwapChainState = SwapChainState
{SwapChainState -> MVar (Maybe SwapChainDetails)
unSwapChainState :: MVar (Maybe SwapChainDetails)}
data SwapChainDetails = SwapChainDetails
{ SwapChainDetails -> (Word32, Word32)
scdSize :: !(Word32, Word32),
SwapChainDetails -> SwapChain
scdSwapChain :: !SwapChain
}
emptySwapChainState :: MonadResource m => m SwapChainState
emptySwapChainState :: m SwapChainState
emptySwapChainState = MVar (Maybe SwapChainDetails) -> SwapChainState
SwapChainState (MVar (Maybe SwapChainDetails) -> SwapChainState)
-> m (MVar (Maybe SwapChainDetails)) -> m SwapChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar (Maybe SwapChainDetails))
-> m (MVar (Maybe SwapChainDetails))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe SwapChainDetails -> IO (MVar (Maybe SwapChainDetails))
forall a. a -> IO (MVar a)
newMVar Maybe SwapChainDetails
forall a. Maybe a
Nothing)
withSwapChain ::
forall r m a.
( C.HasDevice r m,
C.HasSurface r m,
C.HasAdapter r m,
Has Window r,
Has SwapChainState r
) =>
ReaderT (SwapChain, r) m a ->
m a
withSwapChain :: ReaderT (SwapChain, r) m a -> m a
withSwapChain ReaderT (SwapChain, r) m a
action = do
r
env <- m r
forall r (m :: * -> *). MonadReader r m => m r
ask
SwapChain
swapChain <- m SwapChain
getSwapChain
ReaderT (SwapChain, r) m a -> (SwapChain, r) -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (SwapChain, r) m a
action (SwapChain
swapChain, r
env)
where
windowSize :: m (Word32, Word32)
windowSize :: m (Word32, Word32)
windowSize = do
SDL.V2 CInt
w CInt
h <- (r -> Window) -> m Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Window
forall a t. Has a t => t -> a
getter m Window -> (Window -> m (V2 CInt)) -> m (V2 CInt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> m (V2 CInt)
forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize
(Word32, Word32) -> m (Word32, Word32)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w, CInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
h)
getSwapChain :: m SwapChain
getSwapChain :: m SwapChain
getSwapChain = do
Device
device <- (r -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Device
forall a t. Has a t => t -> a
getter
Surface
surface <- (r -> Surface) -> m Surface
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Surface
forall a t. Has a t => t -> a
getter
(Word32, Word32)
windowSz <- m (Word32, Word32)
windowSize
TextureFormat
textureFormat <- m TextureFormat
forall r (m :: * -> *).
(HasSurface r m, HasAdapter r m) =>
m TextureFormat
C.getSwapChainPreferredFormat
SwapChainState
mVarMaybe <- (r -> SwapChainState) -> m SwapChainState
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> SwapChainState
forall a t. Has a t => t -> a
getter
IO SwapChain -> m SwapChain
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SwapChain -> m SwapChain) -> IO SwapChain -> m SwapChain
forall a b. (a -> b) -> a -> b
$
MVar (Maybe SwapChainDetails)
-> (Maybe SwapChainDetails
-> IO (Maybe SwapChainDetails, SwapChain))
-> IO SwapChain
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (SwapChainState -> MVar (Maybe SwapChainDetails)
unSwapChainState SwapChainState
mVarMaybe) ((Maybe SwapChainDetails -> IO (Maybe SwapChainDetails, SwapChain))
-> IO SwapChain)
-> (Maybe SwapChainDetails
-> IO (Maybe SwapChainDetails, SwapChain))
-> IO SwapChain
forall a b. (a -> b) -> a -> b
$ \case
Maybe SwapChainDetails
Nothing -> do
Device
-> Surface
-> (Word32, Word32)
-> TextureFormat
-> IO (Maybe SwapChainDetails, SwapChain)
newSwapChain Device
device Surface
surface (Word32, Word32)
windowSz TextureFormat
textureFormat
Just scd :: SwapChainDetails
scd@SwapChainDetails {(Word32, Word32)
SwapChain
scdSwapChain :: SwapChain
scdSize :: (Word32, Word32)
scdSwapChain :: SwapChainDetails -> SwapChain
scdSize :: SwapChainDetails -> (Word32, Word32)
..} -> do
if (Word32, Word32)
scdSize (Word32, Word32) -> (Word32, Word32) -> Bool
forall a. Eq a => a -> a -> Bool
== (Word32, Word32)
windowSz
then (Maybe SwapChainDetails, SwapChain)
-> IO (Maybe SwapChainDetails, SwapChain)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SwapChainDetails -> Maybe SwapChainDetails
forall a. a -> Maybe a
Just SwapChainDetails
scd, SwapChain
scdSwapChain)
else Device
-> Surface
-> (Word32, Word32)
-> TextureFormat
-> IO (Maybe SwapChainDetails, SwapChain)
newSwapChain Device
device Surface
surface (Word32, Word32)
windowSz TextureFormat
textureFormat
newSwapChain ::
Device ->
Surface ->
(Word32, Word32) ->
TextureFormat ->
IO (Maybe SwapChainDetails, SwapChain)
newSwapChain :: Device
-> Surface
-> (Word32, Word32)
-> TextureFormat
-> IO (Maybe SwapChainDetails, SwapChain)
newSwapChain Device
device Surface
surface (Word32
w, Word32
h) TextureFormat
textureFormat = do
SwapChain
swapChain <-
Device -> Surface -> SwapChainDescriptor -> IO SwapChain
forall (m :: * -> *).
MonadIO m =>
Device -> Surface -> SwapChainDescriptor -> m SwapChain
WGPU.createSwapChain
Device
device
Surface
surface
SwapChainDescriptor :: Text
-> TextureUsage
-> TextureFormat
-> Word32
-> Word32
-> PresentMode
-> SwapChainDescriptor
WGPU.SwapChainDescriptor
{ swapChainLabel :: Text
swapChainLabel = Text
"SwapChain",
usage :: TextureUsage
usage = TextureUsage
forall a. Default a => a
def {texRenderAttachment :: Bool
WGPU.texRenderAttachment = Bool
True},
swapChainFormat :: TextureFormat
swapChainFormat = TextureFormat
textureFormat,
swapChainWidth :: Word32
swapChainWidth = Word32
w,
swapChainHeight :: Word32
swapChainHeight = Word32
h,
presentMode :: PresentMode
presentMode = PresentMode
WGPU.PresentModeFifo
}
(Maybe SwapChainDetails, SwapChain)
-> IO (Maybe SwapChainDetails, SwapChain)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SwapChainDetails -> Maybe SwapChainDetails
forall a. a -> Maybe a
Just ((Word32, Word32) -> SwapChain -> SwapChainDetails
SwapChainDetails (Word32
w, Word32
h) SwapChain
swapChain), SwapChain
swapChain)
newtype BufferName = BufferName {BufferName -> Text
unBufferName :: Text}
deriving (BufferName -> BufferName -> Bool
(BufferName -> BufferName -> Bool)
-> (BufferName -> BufferName -> Bool) -> Eq BufferName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BufferName -> BufferName -> Bool
$c/= :: BufferName -> BufferName -> Bool
== :: BufferName -> BufferName -> Bool
$c== :: BufferName -> BufferName -> Bool
Eq, Eq BufferName
Eq BufferName
-> (BufferName -> BufferName -> Ordering)
-> (BufferName -> BufferName -> Bool)
-> (BufferName -> BufferName -> Bool)
-> (BufferName -> BufferName -> Bool)
-> (BufferName -> BufferName -> Bool)
-> (BufferName -> BufferName -> BufferName)
-> (BufferName -> BufferName -> BufferName)
-> Ord BufferName
BufferName -> BufferName -> Bool
BufferName -> BufferName -> Ordering
BufferName -> BufferName -> BufferName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BufferName -> BufferName -> BufferName
$cmin :: BufferName -> BufferName -> BufferName
max :: BufferName -> BufferName -> BufferName
$cmax :: BufferName -> BufferName -> BufferName
>= :: BufferName -> BufferName -> Bool
$c>= :: BufferName -> BufferName -> Bool
> :: BufferName -> BufferName -> Bool
$c> :: BufferName -> BufferName -> Bool
<= :: BufferName -> BufferName -> Bool
$c<= :: BufferName -> BufferName -> Bool
< :: BufferName -> BufferName -> Bool
$c< :: BufferName -> BufferName -> Bool
compare :: BufferName -> BufferName -> Ordering
$ccompare :: BufferName -> BufferName -> Ordering
$cp1Ord :: Eq BufferName
Ord, String -> BufferName
(String -> BufferName) -> IsString BufferName
forall a. (String -> a) -> IsString a
fromString :: String -> BufferName
$cfromString :: String -> BufferName
IsString, Int -> BufferName -> ShowS
[BufferName] -> ShowS
BufferName -> String
(Int -> BufferName -> ShowS)
-> (BufferName -> String)
-> ([BufferName] -> ShowS)
-> Show BufferName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BufferName] -> ShowS
$cshowList :: [BufferName] -> ShowS
show :: BufferName -> String
$cshow :: BufferName -> String
showsPrec :: Int -> BufferName -> ShowS
$cshowsPrec :: Int -> BufferName -> ShowS
Show)
newtype Buffers = Buffers
{Buffers -> MVarMap BufferName Buffer
unBuffers :: MVarMap BufferName Buffer}
emptyBuffers :: MonadResource m => m Buffers
emptyBuffers :: m Buffers
emptyBuffers = MVarMap BufferName Buffer -> Buffers
Buffers (MVarMap BufferName Buffer -> Buffers)
-> m (MVarMap BufferName Buffer) -> m Buffers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MVarMap BufferName Buffer)
forall (m :: * -> *) k v. MonadIO m => m (MVarMap k v)
emptyMVarMap
createBuffer ::
(MonadIO m, C.HasDevice r m, Has Buffers r) =>
BufferName ->
ByteSize ->
BufferUsage ->
m Buffer
createBuffer :: BufferName -> ByteSize -> BufferUsage -> m Buffer
createBuffer BufferName
bufferName ByteSize
bufferSize BufferUsage
bufferUsage = do
let bufferDescriptor :: BufferDescriptor
bufferDescriptor =
BufferDescriptor :: Text -> ByteSize -> BufferUsage -> Bool -> BufferDescriptor
BufferDescriptor
{ bufferLabel :: Text
bufferLabel = BufferName -> Text
unBufferName BufferName
bufferName,
bufferSize :: ByteSize
bufferSize = ByteSize
bufferSize,
bufferUsage :: BufferUsage
bufferUsage = BufferUsage
bufferUsage,
mappedAtCreation :: Bool
mappedAtCreation = Bool
False
}
Buffer
buffer <- BufferDescriptor -> m Buffer
forall r (m :: * -> *).
HasDevice r m =>
BufferDescriptor -> m Buffer
C.createBuffer BufferDescriptor
bufferDescriptor
(r -> Buffers) -> m Buffers
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Buffers
forall a t. Has a t => t -> a
getter m Buffers -> (Buffers -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferName -> Buffer -> MVarMap BufferName Buffer -> m ()
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> v -> MVarMap k v -> m ()
insertMVarMap BufferName
bufferName Buffer
buffer (MVarMap BufferName Buffer -> m ())
-> (Buffers -> MVarMap BufferName Buffer) -> Buffers -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffers -> MVarMap BufferName Buffer
unBuffers
Buffer -> m Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
buffer
createBufferInit ::
(MonadIO m, C.HasDevice r m, Has Buffers r, ReadableMemoryBuffer a) =>
BufferName ->
BufferUsage ->
a ->
m Buffer
createBufferInit :: BufferName -> BufferUsage -> a -> m Buffer
createBufferInit BufferName
bufferName BufferUsage
bufferUsage a
content = do
Buffer
buffer <- Text -> BufferUsage -> a -> m Buffer
forall r (m :: * -> *) a.
(HasDevice r m, ReadableMemoryBuffer a) =>
Text -> BufferUsage -> a -> m Buffer
C.createBufferInit (BufferName -> Text
unBufferName BufferName
bufferName) BufferUsage
bufferUsage a
content
(r -> Buffers) -> m Buffers
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Buffers
forall a t. Has a t => t -> a
getter m Buffers -> (Buffers -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferName -> Buffer -> MVarMap BufferName Buffer -> m ()
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> v -> MVarMap k v -> m ()
insertMVarMap BufferName
bufferName Buffer
buffer (MVarMap BufferName Buffer -> m ())
-> (Buffers -> MVarMap BufferName Buffer) -> Buffers -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffers -> MVarMap BufferName Buffer
unBuffers
Buffer -> m Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
buffer
getBuffer ::
(MonadIO m, Has Buffers r, MonadReader r m, MonadThrow m) =>
BufferName ->
m Buffer
getBuffer :: BufferName -> m Buffer
getBuffer BufferName
bufferName = do
Maybe Buffer
mBuffer <- (r -> Buffers) -> m Buffers
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Buffers
forall a t. Has a t => t -> a
getter m Buffers -> (Buffers -> m (Maybe Buffer)) -> m (Maybe Buffer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferName -> MVarMap BufferName Buffer -> m (Maybe Buffer)
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> MVarMap k v -> m (Maybe v)
lookupMVarMap BufferName
bufferName (MVarMap BufferName Buffer -> m (Maybe Buffer))
-> (Buffers -> MVarMap BufferName Buffer)
-> Buffers
-> m (Maybe Buffer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Buffers -> MVarMap BufferName Buffer
unBuffers
case Maybe Buffer
mBuffer of
Just Buffer
buffer -> Buffer -> m Buffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer
buffer
Maybe Buffer
Nothing -> AppException -> m Buffer
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BufferName -> AppException
UnknownBufferName BufferName
bufferName)
newtype TextureName = TextureName {TextureName -> Text
unTextureName :: Text}
deriving (TextureName -> TextureName -> Bool
(TextureName -> TextureName -> Bool)
-> (TextureName -> TextureName -> Bool) -> Eq TextureName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextureName -> TextureName -> Bool
$c/= :: TextureName -> TextureName -> Bool
== :: TextureName -> TextureName -> Bool
$c== :: TextureName -> TextureName -> Bool
Eq, Eq TextureName
Eq TextureName
-> (TextureName -> TextureName -> Ordering)
-> (TextureName -> TextureName -> Bool)
-> (TextureName -> TextureName -> Bool)
-> (TextureName -> TextureName -> Bool)
-> (TextureName -> TextureName -> Bool)
-> (TextureName -> TextureName -> TextureName)
-> (TextureName -> TextureName -> TextureName)
-> Ord TextureName
TextureName -> TextureName -> Bool
TextureName -> TextureName -> Ordering
TextureName -> TextureName -> TextureName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TextureName -> TextureName -> TextureName
$cmin :: TextureName -> TextureName -> TextureName
max :: TextureName -> TextureName -> TextureName
$cmax :: TextureName -> TextureName -> TextureName
>= :: TextureName -> TextureName -> Bool
$c>= :: TextureName -> TextureName -> Bool
> :: TextureName -> TextureName -> Bool
$c> :: TextureName -> TextureName -> Bool
<= :: TextureName -> TextureName -> Bool
$c<= :: TextureName -> TextureName -> Bool
< :: TextureName -> TextureName -> Bool
$c< :: TextureName -> TextureName -> Bool
compare :: TextureName -> TextureName -> Ordering
$ccompare :: TextureName -> TextureName -> Ordering
$cp1Ord :: Eq TextureName
Ord, String -> TextureName
(String -> TextureName) -> IsString TextureName
forall a. (String -> a) -> IsString a
fromString :: String -> TextureName
$cfromString :: String -> TextureName
IsString, Int -> TextureName -> ShowS
[TextureName] -> ShowS
TextureName -> String
(Int -> TextureName -> ShowS)
-> (TextureName -> String)
-> ([TextureName] -> ShowS)
-> Show TextureName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextureName] -> ShowS
$cshowList :: [TextureName] -> ShowS
show :: TextureName -> String
$cshow :: TextureName -> String
showsPrec :: Int -> TextureName -> ShowS
$cshowsPrec :: Int -> TextureName -> ShowS
Show)
newtype Textures = Textures
{Textures -> MVarMap TextureName Texture
unTextures :: MVarMap TextureName Texture}
emptyTextures :: MonadResource m => m Textures
emptyTextures :: m Textures
emptyTextures = MVarMap TextureName Texture -> Textures
Textures (MVarMap TextureName Texture -> Textures)
-> m (MVarMap TextureName Texture) -> m Textures
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MVarMap TextureName Texture)
forall (m :: * -> *) k v. MonadIO m => m (MVarMap k v)
emptyMVarMap
createTexture ::
(MonadIO m, C.HasDevice r m, Has Textures r) =>
TextureName ->
Extent3D ->
Word32 ->
Word32 ->
TextureDimension ->
TextureFormat ->
TextureUsage ->
m Texture
createTexture :: TextureName
-> Extent3D
-> Word32
-> Word32
-> TextureDimension
-> TextureFormat
-> TextureUsage
-> m Texture
createTexture
TextureName
name
Extent3D
size
Word32
mipLevelCount
Word32
sampleCount
TextureDimension
dimension
TextureFormat
format
TextureUsage
textureUsage = do
let textureDescriptor :: TextureDescriptor
textureDescriptor =
TextureDescriptor :: Text
-> Extent3D
-> Word32
-> Word32
-> TextureDimension
-> TextureFormat
-> TextureUsage
-> TextureDescriptor
TextureDescriptor
{ textureLabel :: Text
textureLabel = TextureName -> Text
unTextureName TextureName
name,
textureSize :: Extent3D
textureSize = Extent3D
size,
mipLevelCount :: Word32
mipLevelCount = Word32
mipLevelCount,
sampleCount :: Word32
sampleCount = Word32
sampleCount,
dimension :: TextureDimension
dimension = TextureDimension
dimension,
format :: TextureFormat
format = TextureFormat
format,
textureUsage :: TextureUsage
textureUsage = TextureUsage
textureUsage
}
Texture
texture <- TextureDescriptor -> m Texture
forall r (m :: * -> *).
HasDevice r m =>
TextureDescriptor -> m Texture
C.createTexture TextureDescriptor
textureDescriptor
(r -> Textures) -> m Textures
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Textures
forall a t. Has a t => t -> a
getter m Textures -> (Textures -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextureName -> Texture -> MVarMap TextureName Texture -> m ()
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> v -> MVarMap k v -> m ()
insertMVarMap TextureName
name Texture
texture (MVarMap TextureName Texture -> m ())
-> (Textures -> MVarMap TextureName Texture) -> Textures -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Textures -> MVarMap TextureName Texture
unTextures
Texture -> m Texture
forall (f :: * -> *) a. Applicative f => a -> f a
pure Texture
texture
getTexture ::
(MonadIO m, Has Textures r, MonadReader r m, MonadThrow m) =>
TextureName ->
m Texture
getTexture :: TextureName -> m Texture
getTexture TextureName
name = do
Maybe Texture
mTexture <- (r -> Textures) -> m Textures
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Textures
forall a t. Has a t => t -> a
getter m Textures -> (Textures -> m (Maybe Texture)) -> m (Maybe Texture)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextureName -> MVarMap TextureName Texture -> m (Maybe Texture)
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> MVarMap k v -> m (Maybe v)
lookupMVarMap TextureName
name (MVarMap TextureName Texture -> m (Maybe Texture))
-> (Textures -> MVarMap TextureName Texture)
-> Textures
-> m (Maybe Texture)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Textures -> MVarMap TextureName Texture
unTextures
case Maybe Texture
mTexture of
Just Texture
texture -> Texture -> m Texture
forall (f :: * -> *) a. Applicative f => a -> f a
pure Texture
texture
Maybe Texture
Nothing -> AppException -> m Texture
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureName -> AppException
UnknownTextureName TextureName
name)
newtype BindGroupName = BindGroupName {BindGroupName -> Text
unBindGroupName :: Text}
deriving (BindGroupName -> BindGroupName -> Bool
(BindGroupName -> BindGroupName -> Bool)
-> (BindGroupName -> BindGroupName -> Bool) -> Eq BindGroupName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BindGroupName -> BindGroupName -> Bool
$c/= :: BindGroupName -> BindGroupName -> Bool
== :: BindGroupName -> BindGroupName -> Bool
$c== :: BindGroupName -> BindGroupName -> Bool
Eq, Eq BindGroupName
Eq BindGroupName
-> (BindGroupName -> BindGroupName -> Ordering)
-> (BindGroupName -> BindGroupName -> Bool)
-> (BindGroupName -> BindGroupName -> Bool)
-> (BindGroupName -> BindGroupName -> Bool)
-> (BindGroupName -> BindGroupName -> Bool)
-> (BindGroupName -> BindGroupName -> BindGroupName)
-> (BindGroupName -> BindGroupName -> BindGroupName)
-> Ord BindGroupName
BindGroupName -> BindGroupName -> Bool
BindGroupName -> BindGroupName -> Ordering
BindGroupName -> BindGroupName -> BindGroupName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BindGroupName -> BindGroupName -> BindGroupName
$cmin :: BindGroupName -> BindGroupName -> BindGroupName
max :: BindGroupName -> BindGroupName -> BindGroupName
$cmax :: BindGroupName -> BindGroupName -> BindGroupName
>= :: BindGroupName -> BindGroupName -> Bool
$c>= :: BindGroupName -> BindGroupName -> Bool
> :: BindGroupName -> BindGroupName -> Bool
$c> :: BindGroupName -> BindGroupName -> Bool
<= :: BindGroupName -> BindGroupName -> Bool
$c<= :: BindGroupName -> BindGroupName -> Bool
< :: BindGroupName -> BindGroupName -> Bool
$c< :: BindGroupName -> BindGroupName -> Bool
compare :: BindGroupName -> BindGroupName -> Ordering
$ccompare :: BindGroupName -> BindGroupName -> Ordering
$cp1Ord :: Eq BindGroupName
Ord, String -> BindGroupName
(String -> BindGroupName) -> IsString BindGroupName
forall a. (String -> a) -> IsString a
fromString :: String -> BindGroupName
$cfromString :: String -> BindGroupName
IsString, Int -> BindGroupName -> ShowS
[BindGroupName] -> ShowS
BindGroupName -> String
(Int -> BindGroupName -> ShowS)
-> (BindGroupName -> String)
-> ([BindGroupName] -> ShowS)
-> Show BindGroupName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BindGroupName] -> ShowS
$cshowList :: [BindGroupName] -> ShowS
show :: BindGroupName -> String
$cshow :: BindGroupName -> String
showsPrec :: Int -> BindGroupName -> ShowS
$cshowsPrec :: Int -> BindGroupName -> ShowS
Show)
newtype BindGroups = BindGroups
{BindGroups -> MVarMap BindGroupName BindGroup
unBindGroups :: MVarMap BindGroupName BindGroup}
emptyBindGroups :: MonadResource m => m BindGroups
emptyBindGroups :: m BindGroups
emptyBindGroups = MVarMap BindGroupName BindGroup -> BindGroups
BindGroups (MVarMap BindGroupName BindGroup -> BindGroups)
-> m (MVarMap BindGroupName BindGroup) -> m BindGroups
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MVarMap BindGroupName BindGroup)
forall (m :: * -> *) k v. MonadIO m => m (MVarMap k v)
emptyMVarMap
createBindGroup ::
(MonadIO m, C.HasDevice r m, Has BindGroups r) =>
BindGroupName ->
BindGroupDescriptor ->
m BindGroup
createBindGroup :: BindGroupName -> BindGroupDescriptor -> m BindGroup
createBindGroup BindGroupName
name BindGroupDescriptor
bindGroupDescriptor = do
BindGroup
bindGroup <- BindGroupDescriptor -> m BindGroup
forall r (m :: * -> *).
HasDevice r m =>
BindGroupDescriptor -> m BindGroup
C.createBindGroup BindGroupDescriptor
bindGroupDescriptor
(r -> BindGroups) -> m BindGroups
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> BindGroups
forall a t. Has a t => t -> a
getter m BindGroups -> (BindGroups -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BindGroupName
-> BindGroup -> MVarMap BindGroupName BindGroup -> m ()
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> v -> MVarMap k v -> m ()
insertMVarMap BindGroupName
name BindGroup
bindGroup (MVarMap BindGroupName BindGroup -> m ())
-> (BindGroups -> MVarMap BindGroupName BindGroup)
-> BindGroups
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindGroups -> MVarMap BindGroupName BindGroup
unBindGroups
BindGroup -> m BindGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure BindGroup
bindGroup
getBindGroup ::
(MonadIO m, Has BindGroups r, MonadReader r m, MonadThrow m) =>
BindGroupName ->
m BindGroup
getBindGroup :: BindGroupName -> m BindGroup
getBindGroup BindGroupName
bindGroupName = do
Maybe BindGroup
mBindGroup <- (r -> BindGroups) -> m BindGroups
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> BindGroups
forall a t. Has a t => t -> a
getter m BindGroups
-> (BindGroups -> m (Maybe BindGroup)) -> m (Maybe BindGroup)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BindGroupName
-> MVarMap BindGroupName BindGroup -> m (Maybe BindGroup)
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> MVarMap k v -> m (Maybe v)
lookupMVarMap BindGroupName
bindGroupName (MVarMap BindGroupName BindGroup -> m (Maybe BindGroup))
-> (BindGroups -> MVarMap BindGroupName BindGroup)
-> BindGroups
-> m (Maybe BindGroup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindGroups -> MVarMap BindGroupName BindGroup
unBindGroups
case Maybe BindGroup
mBindGroup of
Just BindGroup
bindGroup -> BindGroup -> m BindGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure BindGroup
bindGroup
Maybe BindGroup
Nothing -> AppException -> m BindGroup
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BindGroupName -> AppException
UnknownBindGroupName BindGroupName
bindGroupName)
newtype RenderPipelineName = RenderPipelineName {RenderPipelineName -> Text
unRenderPipelineName :: Text}
deriving (RenderPipelineName -> RenderPipelineName -> Bool
(RenderPipelineName -> RenderPipelineName -> Bool)
-> (RenderPipelineName -> RenderPipelineName -> Bool)
-> Eq RenderPipelineName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenderPipelineName -> RenderPipelineName -> Bool
$c/= :: RenderPipelineName -> RenderPipelineName -> Bool
== :: RenderPipelineName -> RenderPipelineName -> Bool
$c== :: RenderPipelineName -> RenderPipelineName -> Bool
Eq, Eq RenderPipelineName
Eq RenderPipelineName
-> (RenderPipelineName -> RenderPipelineName -> Ordering)
-> (RenderPipelineName -> RenderPipelineName -> Bool)
-> (RenderPipelineName -> RenderPipelineName -> Bool)
-> (RenderPipelineName -> RenderPipelineName -> Bool)
-> (RenderPipelineName -> RenderPipelineName -> Bool)
-> (RenderPipelineName -> RenderPipelineName -> RenderPipelineName)
-> (RenderPipelineName -> RenderPipelineName -> RenderPipelineName)
-> Ord RenderPipelineName
RenderPipelineName -> RenderPipelineName -> Bool
RenderPipelineName -> RenderPipelineName -> Ordering
RenderPipelineName -> RenderPipelineName -> RenderPipelineName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RenderPipelineName -> RenderPipelineName -> RenderPipelineName
$cmin :: RenderPipelineName -> RenderPipelineName -> RenderPipelineName
max :: RenderPipelineName -> RenderPipelineName -> RenderPipelineName
$cmax :: RenderPipelineName -> RenderPipelineName -> RenderPipelineName
>= :: RenderPipelineName -> RenderPipelineName -> Bool
$c>= :: RenderPipelineName -> RenderPipelineName -> Bool
> :: RenderPipelineName -> RenderPipelineName -> Bool
$c> :: RenderPipelineName -> RenderPipelineName -> Bool
<= :: RenderPipelineName -> RenderPipelineName -> Bool
$c<= :: RenderPipelineName -> RenderPipelineName -> Bool
< :: RenderPipelineName -> RenderPipelineName -> Bool
$c< :: RenderPipelineName -> RenderPipelineName -> Bool
compare :: RenderPipelineName -> RenderPipelineName -> Ordering
$ccompare :: RenderPipelineName -> RenderPipelineName -> Ordering
$cp1Ord :: Eq RenderPipelineName
Ord, String -> RenderPipelineName
(String -> RenderPipelineName) -> IsString RenderPipelineName
forall a. (String -> a) -> IsString a
fromString :: String -> RenderPipelineName
$cfromString :: String -> RenderPipelineName
IsString, Int -> RenderPipelineName -> ShowS
[RenderPipelineName] -> ShowS
RenderPipelineName -> String
(Int -> RenderPipelineName -> ShowS)
-> (RenderPipelineName -> String)
-> ([RenderPipelineName] -> ShowS)
-> Show RenderPipelineName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenderPipelineName] -> ShowS
$cshowList :: [RenderPipelineName] -> ShowS
show :: RenderPipelineName -> String
$cshow :: RenderPipelineName -> String
showsPrec :: Int -> RenderPipelineName -> ShowS
$cshowsPrec :: Int -> RenderPipelineName -> ShowS
Show)
newtype RenderPipelines = RenderPipelines
{RenderPipelines -> MVarMap RenderPipelineName RenderPipeline
unRenderPipelines :: MVarMap RenderPipelineName RenderPipeline}
emptyRenderPipelines :: MonadResource m => m RenderPipelines
emptyRenderPipelines :: m RenderPipelines
emptyRenderPipelines = MVarMap RenderPipelineName RenderPipeline -> RenderPipelines
RenderPipelines (MVarMap RenderPipelineName RenderPipeline -> RenderPipelines)
-> m (MVarMap RenderPipelineName RenderPipeline)
-> m RenderPipelines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MVarMap RenderPipelineName RenderPipeline)
forall (m :: * -> *) k v. MonadIO m => m (MVarMap k v)
emptyMVarMap
createRenderPipeline ::
( MonadIO m,
C.HasDevice r m,
Has RenderPipelines r
) =>
RenderPipelineName ->
RenderPipelineDescriptor ->
m RenderPipeline
createRenderPipeline :: RenderPipelineName -> RenderPipelineDescriptor -> m RenderPipeline
createRenderPipeline RenderPipelineName
name RenderPipelineDescriptor
renderPipelineDescriptor = do
RenderPipeline
renderPipeline <- RenderPipelineDescriptor -> m RenderPipeline
forall r (m :: * -> *).
HasDevice r m =>
RenderPipelineDescriptor -> m RenderPipeline
C.createRenderPipeline RenderPipelineDescriptor
renderPipelineDescriptor
(r -> RenderPipelines) -> m RenderPipelines
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> RenderPipelines
forall a t. Has a t => t -> a
getter m RenderPipelines -> (RenderPipelines -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RenderPipelineName
-> RenderPipeline
-> MVarMap RenderPipelineName RenderPipeline
-> m ()
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> v -> MVarMap k v -> m ()
insertMVarMap RenderPipelineName
name RenderPipeline
renderPipeline (MVarMap RenderPipelineName RenderPipeline -> m ())
-> (RenderPipelines -> MVarMap RenderPipelineName RenderPipeline)
-> RenderPipelines
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderPipelines -> MVarMap RenderPipelineName RenderPipeline
unRenderPipelines
RenderPipeline -> m RenderPipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderPipeline
renderPipeline
getRenderPipeline ::
(Has RenderPipelines r, MonadReader r m, MonadIO m, MonadThrow m) =>
RenderPipelineName ->
m RenderPipeline
getRenderPipeline :: RenderPipelineName -> m RenderPipeline
getRenderPipeline RenderPipelineName
name = do
Maybe RenderPipeline
mRenderPipeline <- (r -> RenderPipelines) -> m RenderPipelines
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> RenderPipelines
forall a t. Has a t => t -> a
getter m RenderPipelines
-> (RenderPipelines -> m (Maybe RenderPipeline))
-> m (Maybe RenderPipeline)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RenderPipelineName
-> MVarMap RenderPipelineName RenderPipeline
-> m (Maybe RenderPipeline)
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> MVarMap k v -> m (Maybe v)
lookupMVarMap RenderPipelineName
name (MVarMap RenderPipelineName RenderPipeline
-> m (Maybe RenderPipeline))
-> (RenderPipelines -> MVarMap RenderPipelineName RenderPipeline)
-> RenderPipelines
-> m (Maybe RenderPipeline)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderPipelines -> MVarMap RenderPipelineName RenderPipeline
unRenderPipelines
case Maybe RenderPipeline
mRenderPipeline of
Just RenderPipeline
renderPipeline -> RenderPipeline -> m RenderPipeline
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderPipeline
renderPipeline
Maybe RenderPipeline
Nothing -> AppException -> m RenderPipeline
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (RenderPipelineName -> AppException
UnknownRenderPipelineName RenderPipelineName
name)
newtype ShaderName = ShaderName {ShaderName -> Text
unShaderName :: Text}
deriving (ShaderName -> ShaderName -> Bool
(ShaderName -> ShaderName -> Bool)
-> (ShaderName -> ShaderName -> Bool) -> Eq ShaderName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShaderName -> ShaderName -> Bool
$c/= :: ShaderName -> ShaderName -> Bool
== :: ShaderName -> ShaderName -> Bool
$c== :: ShaderName -> ShaderName -> Bool
Eq, Eq ShaderName
Eq ShaderName
-> (ShaderName -> ShaderName -> Ordering)
-> (ShaderName -> ShaderName -> Bool)
-> (ShaderName -> ShaderName -> Bool)
-> (ShaderName -> ShaderName -> Bool)
-> (ShaderName -> ShaderName -> Bool)
-> (ShaderName -> ShaderName -> ShaderName)
-> (ShaderName -> ShaderName -> ShaderName)
-> Ord ShaderName
ShaderName -> ShaderName -> Bool
ShaderName -> ShaderName -> Ordering
ShaderName -> ShaderName -> ShaderName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShaderName -> ShaderName -> ShaderName
$cmin :: ShaderName -> ShaderName -> ShaderName
max :: ShaderName -> ShaderName -> ShaderName
$cmax :: ShaderName -> ShaderName -> ShaderName
>= :: ShaderName -> ShaderName -> Bool
$c>= :: ShaderName -> ShaderName -> Bool
> :: ShaderName -> ShaderName -> Bool
$c> :: ShaderName -> ShaderName -> Bool
<= :: ShaderName -> ShaderName -> Bool
$c<= :: ShaderName -> ShaderName -> Bool
< :: ShaderName -> ShaderName -> Bool
$c< :: ShaderName -> ShaderName -> Bool
compare :: ShaderName -> ShaderName -> Ordering
$ccompare :: ShaderName -> ShaderName -> Ordering
$cp1Ord :: Eq ShaderName
Ord, String -> ShaderName
(String -> ShaderName) -> IsString ShaderName
forall a. (String -> a) -> IsString a
fromString :: String -> ShaderName
$cfromString :: String -> ShaderName
IsString, Int -> ShaderName -> ShowS
[ShaderName] -> ShowS
ShaderName -> String
(Int -> ShaderName -> ShowS)
-> (ShaderName -> String)
-> ([ShaderName] -> ShowS)
-> Show ShaderName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShaderName] -> ShowS
$cshowList :: [ShaderName] -> ShowS
show :: ShaderName -> String
$cshow :: ShaderName -> String
showsPrec :: Int -> ShaderName -> ShowS
$cshowsPrec :: Int -> ShaderName -> ShowS
Show)
newtype Shaders = Shaders {Shaders -> MVarMap ShaderName ShaderModule
unShaders :: MVarMap ShaderName ShaderModule}
emptyShaders :: MonadResource m => m Shaders
emptyShaders :: m Shaders
emptyShaders = MVarMap ShaderName ShaderModule -> Shaders
Shaders (MVarMap ShaderName ShaderModule -> Shaders)
-> m (MVarMap ShaderName ShaderModule) -> m Shaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (MVarMap ShaderName ShaderModule)
forall (m :: * -> *) k v. MonadIO m => m (MVarMap k v)
emptyMVarMap
compileWGSL_ ::
(Has Device r, Has Shaders r, MonadReader r m, MonadResource m) =>
ShaderName ->
WGSL ->
m ()
compileWGSL_ :: ShaderName -> WGSL -> m ()
compileWGSL_ ShaderName
shaderName WGSL
wgsl = ShaderName -> WGSL -> m ShaderModule
forall r (m :: * -> *).
(Has Device r, Has Shaders r, MonadReader r m, MonadResource m) =>
ShaderName -> WGSL -> m ShaderModule
compileWGSL ShaderName
shaderName WGSL
wgsl m ShaderModule -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileWGSL ::
(Has Device r, Has Shaders r, MonadReader r m, MonadResource m) =>
ShaderName ->
WGSL ->
m ShaderModule
compileWGSL :: ShaderName -> WGSL -> m ShaderModule
compileWGSL ShaderName
shaderName WGSL
wgsl = do
ShaderModule
shaderModule <- Text -> WGSL -> m ShaderModule
forall r (m :: * -> *).
HasDevice r m =>
Text -> WGSL -> m ShaderModule
C.createShaderModuleWGSL (ShaderName -> Text
unShaderName ShaderName
shaderName) WGSL
wgsl
(r -> Shaders) -> m Shaders
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Shaders
forall a t. Has a t => t -> a
getter m Shaders -> (Shaders -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ShaderName
-> ShaderModule -> MVarMap ShaderName ShaderModule -> m ()
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> v -> MVarMap k v -> m ()
insertMVarMap ShaderName
shaderName ShaderModule
shaderModule (MVarMap ShaderName ShaderModule -> m ())
-> (Shaders -> MVarMap ShaderName ShaderModule) -> Shaders -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shaders -> MVarMap ShaderName ShaderModule
unShaders
ShaderModule -> m ShaderModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShaderModule
shaderModule
getShader ::
(Has Shaders r, MonadReader r m, MonadIO m, MonadThrow m) =>
ShaderName ->
m ShaderModule
getShader :: ShaderName -> m ShaderModule
getShader ShaderName
shaderName = do
Maybe ShaderModule
mShaderModule <- (r -> Shaders) -> m Shaders
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Shaders
forall a t. Has a t => t -> a
getter m Shaders
-> (Shaders -> m (Maybe ShaderModule)) -> m (Maybe ShaderModule)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ShaderName
-> MVarMap ShaderName ShaderModule -> m (Maybe ShaderModule)
forall k (m :: * -> *) v.
(Ord k, MonadIO m) =>
k -> MVarMap k v -> m (Maybe v)
lookupMVarMap ShaderName
shaderName (MVarMap ShaderName ShaderModule -> m (Maybe ShaderModule))
-> (Shaders -> MVarMap ShaderName ShaderModule)
-> Shaders
-> m (Maybe ShaderModule)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shaders -> MVarMap ShaderName ShaderModule
unShaders
case Maybe ShaderModule
mShaderModule of
Just ShaderModule
shaderModule -> ShaderModule -> m ShaderModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShaderModule
shaderModule
Maybe ShaderModule
Nothing -> AppException -> m ShaderModule
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ShaderName -> AppException
UnknownShaderName ShaderName
shaderName)
data Params = Params
{
Params -> Text
title :: !Text,
Params -> SMaybe DeviceDescriptor
mDeviceDescriptor :: !(SMaybe DeviceDescriptor)
}
loadResources ::
forall m.
(MonadResource m, MonadThrow m) =>
Params ->
m Resources
loadResources :: Params -> m Resources
loadResources Params {Text
SMaybe DeviceDescriptor
mDeviceDescriptor :: SMaybe DeviceDescriptor
title :: Text
mDeviceDescriptor :: Params -> SMaybe DeviceDescriptor
title :: Params -> Text
..} = do
Instance
inst <- m Instance
createInstance
Window
window <- m Window
createWindow
Surface
surface <- Instance -> Window -> m Surface
forall (m :: * -> *). MonadIO m => Instance -> Window -> m Surface
WGPU.SDL.Surface.createSurface Instance
inst Window
window
Adapter
adapter <- Surface -> m Adapter
requestAdapter Surface
surface
Device
device <- Adapter -> m Device
requestDevice Adapter
adapter
Queue
queue <- Device -> m Queue
forall (m :: * -> *). MonadIO m => Device -> m Queue
WGPU.getQueue Device
device
Resources -> m Resources
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resources :: Instance
-> Window -> Surface -> Adapter -> Device -> Queue -> Resources
Resources {Window
Queue
Device
Adapter
Surface
Instance
queue :: Queue
device :: Device
adapter :: Adapter
surface :: Surface
window :: Window
inst :: Instance
queue :: Queue
device :: Device
adapter :: Adapter
surface :: Surface
window :: Window
inst :: Instance
..}
where
createInstance :: m Instance
createInstance :: m Instance
createInstance = (ReleaseKey, Instance) -> Instance
forall a b. (a, b) -> b
snd ((ReleaseKey, Instance) -> Instance)
-> m (ReleaseKey, Instance) -> m Instance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Instance -> (Instance -> IO ()) -> m (ReleaseKey, Instance))
-> m (ReleaseKey, Instance)
forall (m :: * -> *) r.
MonadIO m =>
(m Instance -> (Instance -> m ()) -> r) -> r
WGPU.withPlatformInstance IO Instance -> (Instance -> IO ()) -> m (ReleaseKey, Instance)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
createWindow :: m Window
createWindow :: m Window
createWindow = do
m ()
forall (m :: * -> *). (Functor m, MonadIO m) => m ()
SDL.initializeAll
let windowConfig :: WindowConfig
windowConfig = WindowConfig
SDL.defaultWindow {windowResizable :: Bool
SDL.windowResizable = Bool
True}
(ReleaseKey, Window) -> Window
forall a b. (a, b) -> b
snd
((ReleaseKey, Window) -> Window)
-> m (ReleaseKey, Window) -> m Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Window -> (Window -> IO ()) -> m (ReleaseKey, Window)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
(Text -> WindowConfig -> IO Window
forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
SDL.createWindow Text
title WindowConfig
windowConfig)
Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.destroyWindow
requestAdapter :: Surface -> m Adapter
requestAdapter :: Surface -> m Adapter
requestAdapter Surface
surface =
Surface -> m (Maybe Adapter)
forall (m :: * -> *). MonadIO m => Surface -> m (Maybe Adapter)
WGPU.requestAdapter Surface
surface m (Maybe Adapter) -> (Maybe Adapter -> m Adapter) -> m Adapter
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Adapter
Nothing -> AppException -> m Adapter
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM AppException
AdapterRequestFailed
Just Adapter
adapter -> Adapter -> m Adapter
forall (f :: * -> *) a. Applicative f => a -> f a
pure Adapter
adapter
requestDevice :: Adapter -> m Device
requestDevice :: Adapter -> m Device
requestDevice Adapter
adapter = do
let deviceDescriptor :: DeviceDescriptor
deviceDescriptor = DeviceDescriptor -> SMaybe DeviceDescriptor -> DeviceDescriptor
forall a. a -> SMaybe a -> a
WGPU.fromSMaybe DeviceDescriptor
forall a. Default a => a
def SMaybe DeviceDescriptor
mDeviceDescriptor
Adapter -> DeviceDescriptor -> m (Maybe Device)
forall (m :: * -> *).
MonadIO m =>
Adapter -> DeviceDescriptor -> m (Maybe Device)
WGPU.requestDevice Adapter
adapter DeviceDescriptor
deviceDescriptor m (Maybe Device) -> (Maybe Device -> m Device) -> m Device
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Device
Nothing -> AppException -> m Device
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM AppException
DeviceRequestFailed
Just Device
device -> Device -> m Device
forall (f :: * -> *) a. Applicative f => a -> f a
pure Device
device
data Resources = Resources
{ Resources -> Instance
inst :: !Instance,
Resources -> Window
window :: !Window,
Resources -> Surface
surface :: !Surface,
Resources -> Adapter
adapter :: !Adapter,
Resources -> Device
device :: !Device,
Resources -> Queue
queue :: !Queue
}
deriving ((forall x. Resources -> Rep Resources x)
-> (forall x. Rep Resources x -> Resources) -> Generic Resources
forall x. Rep Resources x -> Resources
forall x. Resources -> Rep Resources x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Resources x -> Resources
$cfrom :: forall x. Resources -> Rep Resources x
Generic)
instance Has Instance Resources where
hasLens :: (Instance -> f Instance) -> Resources -> f Resources
hasLens = (Resources -> Instance)
-> (Resources -> Instance -> Resources) -> Lens Resources Instance
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resources -> Instance
inst (\Resources
s Instance
x -> Resources
s {inst :: Instance
inst = Instance
x})
instance Has Window Resources where
hasLens :: (Window -> f Window) -> Resources -> f Resources
hasLens = (Resources -> Window)
-> (Resources -> Window -> Resources) -> Lens Resources Window
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resources -> Window
window (\Resources
s Window
x -> Resources
s {window :: Window
window = Window
x})
instance Has Surface Resources where
hasLens :: (Surface -> f Surface) -> Resources -> f Resources
hasLens = (Resources -> Surface)
-> (Resources -> Surface -> Resources) -> Lens Resources Surface
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resources -> Surface
surface (\Resources
s Surface
x -> Resources
s {surface :: Surface
surface = Surface
x})
instance Has Adapter Resources where
hasLens :: (Adapter -> f Adapter) -> Resources -> f Resources
hasLens = (Resources -> Adapter)
-> (Resources -> Adapter -> Resources) -> Lens Resources Adapter
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resources -> Adapter
adapter (\Resources
s Adapter
x -> Resources
s {adapter :: Adapter
adapter = Adapter
x})
instance Has Device Resources where
hasLens :: (Device -> f Device) -> Resources -> f Resources
hasLens = (Resources -> Device)
-> (Resources -> Device -> Resources) -> Lens Resources Device
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resources -> Device
device (\Resources
s Device
x -> Resources
s {device :: Device
device = Device
x})
instance Has Queue Resources where
hasLens :: (Queue -> f Queue) -> Resources -> f Resources
hasLens = (Resources -> Queue)
-> (Resources -> Queue -> Resources) -> Lens Resources Queue
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Resources -> Queue
queue (\Resources
s Queue
x -> Resources
s {queue :: Queue
queue = Queue
x})
getWindow :: (Has Window r, MonadReader r m) => m Window
getWindow :: m Window
getWindow = (r -> Window) -> m Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Window
forall a t. Has a t => t -> a
getter
getDrawableSize :: (Has Window r, MonadReader r m, MonadIO m) => m (Int, Int)
getDrawableSize :: m (Int, Int)
getDrawableSize = do
SDL.V2 CInt
w CInt
h <- m Window
forall r (m :: * -> *). (Has Window r, MonadReader r m) => m Window
getWindow m Window -> (Window -> m (V2 CInt)) -> m (V2 CInt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> m (V2 CInt)
forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize
(Int, Int) -> m (Int, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
h)
newtype MVarMap k v = MVarMap {MVarMap k v -> MVar (Map k v)
unMVarMap :: MVar (Map k v)}
emptyMVarMap :: MonadIO m => m (MVarMap k v)
emptyMVarMap :: m (MVarMap k v)
emptyMVarMap = MVar (Map k v) -> MVarMap k v
forall k v. MVar (Map k v) -> MVarMap k v
MVarMap (MVar (Map k v) -> MVarMap k v)
-> m (MVar (Map k v)) -> m (MVarMap k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar (Map k v)) -> m (MVar (Map k v))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map k v -> IO (MVar (Map k v))
forall a. a -> IO (MVar a)
newMVar Map k v
forall k a. Map k a
Map.empty)
insertMVarMap :: (Ord k, MonadIO m) => k -> v -> MVarMap k v -> m ()
insertMVarMap :: k -> v -> MVarMap k v -> m ()
insertMVarMap k
key v
value MVarMap k v
mVarMap =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Map k v) -> (Map k v -> IO (Map k v)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (MVarMap k v -> MVar (Map k v)
forall k v. MVarMap k v -> MVar (Map k v)
unMVarMap MVarMap k v
mVarMap) (Map k v -> IO (Map k v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map k v -> IO (Map k v))
-> (Map k v -> Map k v) -> Map k v -> IO (Map k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
key v
value)
lookupMVarMap :: (Ord k, MonadIO m) => k -> MVarMap k v -> m (Maybe v)
lookupMVarMap :: k -> MVarMap k v -> m (Maybe v)
lookupMVarMap k
key MVarMap k v
mVarMap =
IO (Maybe v) -> m (Maybe v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe v) -> m (Maybe v)) -> IO (Maybe v) -> m (Maybe v)
forall a b. (a -> b) -> a -> b
$ MVar (Map k v) -> (Map k v -> IO (Maybe v)) -> IO (Maybe v)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (MVarMap k v -> MVar (Map k v)
forall k v. MVarMap k v -> MVar (Map k v)
unMVarMap MVarMap k v
mVarMap) (Maybe v -> IO (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe v -> IO (Maybe v))
-> (Map k v -> Maybe v) -> Map k v -> IO (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key)
data AppException
=
AdapterRequestFailed
|
DeviceRequestFailed
|
UnknownShaderName ShaderName
|
UnknownRenderPipelineName RenderPipelineName
|
UnknownBufferName BufferName
|
UnknownTextureName TextureName
|
UnknownBindGroupName BindGroupName
deriving (Int -> AppException -> ShowS
[AppException] -> ShowS
AppException -> String
(Int -> AppException -> ShowS)
-> (AppException -> String)
-> ([AppException] -> ShowS)
-> Show AppException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppException] -> ShowS
$cshowList :: [AppException] -> ShowS
show :: AppException -> String
$cshow :: AppException -> String
showsPrec :: Int -> AppException -> ShowS
$cshowsPrec :: Int -> AppException -> ShowS
Show)
instance Exception AppException