{-# 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,
RenderPipelineName,
RenderPipelines,
emptyRenderPipelines,
createRenderPipeline,
getRenderPipeline,
ShaderName,
Shaders,
emptyShaders,
compileWGSL,
compileWGSL_,
getShader,
Params (..),
Resources (..),
loadResources,
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,
Device,
DeviceDescriptor,
Instance,
Queue,
RenderPipeline,
RenderPipelineDescriptor,
SMaybe,
ShaderModule,
Surface,
SwapChain,
TextureFormat,
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
WGPU.TextureUsageRenderAttachment,
swapChainFormat :: TextureFormat
swapChainFormat = TextureFormat
textureFormat,
width :: Word32
width = Word32
w,
height :: Word32
height = 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 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})
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
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