{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : WGPU.BoneYard.SimpleSDL
-- Description : Template for a simple SDL app.
--
-- This is a kind of skeleton for a very simple SDL app. It is intended for
-- bootstrapping development. A common use case is when you want a window to
-- draw in with everything configured. This provides a version of that
-- functionality that can later be replaced or refined (easily) by the app
-- developer if necessary.
module WGPU.BoneYard.SimpleSDL
  ( -- * Swap Chain

    -- ** Types
    SwapChainState,

    -- ** Functions
    emptySwapChainState,
    withSwapChain,

    -- * Render Pipelines

    -- ** Types
    RenderPipelineName,
    RenderPipelines,

    -- ** Functions
    emptyRenderPipelines,
    createRenderPipeline,
    getRenderPipeline,

    -- * Shaders

    -- ** Types
    ShaderName,
    Shaders,

    -- ** Functions
    emptyShaders,
    compileWGSL,
    compileWGSL_,
    getShader,

    -- * Resources

    -- ** Types
    Params (..),
    Resources (..),

    -- ** Functions
    loadResources,

    -- * Exceptions
    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

-------------------------------------------------------------------------------
-- SwapChain Management

-- | Contains mutable state to manage the swap chain.
newtype SwapChainState = SwapChainState
  {SwapChainState -> MVar (Maybe SwapChainDetails)
unSwapChainState :: MVar (Maybe SwapChainDetails)}

data SwapChainDetails = SwapChainDetails
  { SwapChainDetails -> (Word32, Word32)
scdSize :: !(Word32, Word32),
    SwapChainDetails -> SwapChain
scdSwapChain :: !SwapChain
  }

-- | Initialize a new 'SwapChainState'.
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)

-- | Provide a 'ReaderT' with a properly-configured 'SwapChain'.
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)

-------------------------------------------------------------------------------
-- Render Pipeline Collection

-- | Name of a render pipeline.
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)

-- | Container for mutable state that contains a map of render pipelines.
newtype RenderPipelines = RenderPipelines
  {RenderPipelines -> MVarMap RenderPipelineName RenderPipeline
unRenderPipelines :: MVarMap RenderPipelineName RenderPipeline}

-- | Create an empty 'RenderPipelines'.
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

-- | Create a 'RenderPipeline', storing it in the 'RenderPipelines' map.
--
-- A 'RenderPipeline' created this way can be fetched using
-- 'getRenderPipeline'. This calls 'C.createRenderPipeline' under the hood.
createRenderPipeline ::
  ( MonadIO m,
    C.HasDevice r m,
    Has RenderPipelines r
  ) =>
  -- | Name of the render pipeline.
  RenderPipelineName ->
  -- | Descriptor of the render pipeline.
  RenderPipelineDescriptor ->
  -- | The created render pipeline.
  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

-- | Fetch a render pipeline that was previously created using
-- 'createRenderPipeline'.
--
-- If the render pipeline is not available, this function throws an exception
-- of type 'AppException'.
getRenderPipeline ::
  (Has RenderPipelines r, MonadReader r m, MonadIO m, MonadThrow m) =>
  -- | Name of the render pipeline to fetch.
  RenderPipelineName ->
  -- | The render pipeline.
  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)

-------------------------------------------------------------------------------
-- Shader Collection

-- | Name of a shader.
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)

-- | Container for mutable state that contains a map of shaders.
newtype Shaders = Shaders {Shaders -> MVarMap ShaderName ShaderModule
unShaders :: MVarMap ShaderName ShaderModule}

-- | Create an empty 'Shaders'.
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

-- | Compile a WGSL shader, adding it to the 'Shaders' map.
compileWGSL_ ::
  (Has Device r, Has Shaders r, MonadReader r m, MonadResource m) =>
  -- | Name of the shader.
  ShaderName ->
  -- | Shader source code.
  WGSL ->
  -- | Action that compiles the shader and adds it to the 'Shaders' map.
  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 ()

-- | Compile a WGSL shader, adding it to the 'Shaders' map, and returning the
-- compiled 'ShaderModule'.
compileWGSL ::
  (Has Device r, Has Shaders r, MonadReader r m, MonadResource m) =>
  -- | Name of the shader.
  ShaderName ->
  -- | Shader source code.
  WGSL ->
  -- | Action that returns the compiled shader module, after adding it to the
  -- 'Shaders' map.
  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

-- | Fetch a shader that was previously compiled.
--
-- If the shader is not available, this function throws an exception of type
-- 'AppException'.
getShader ::
  (Has Shaders r, MonadReader r m, MonadIO m, MonadThrow m) =>
  -- | Name of the shader to fetch.
  ShaderName ->
  -- | The shader module.
  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)

-------------------------------------------------------------------------------
-- Application Static Resources

-- | Parameters for initialization.
data Params = Params
  { -- | Title of the window.
    Params -> Text
title :: !Text,
    -- | Optional device descriptor.
    Params -> SMaybe DeviceDescriptor
mDeviceDescriptor :: !(SMaybe DeviceDescriptor)
  }

-- | Load the resources for an application.
--
-- This creates:
--   - 'Instance',
--   - SDL 'Window' (which is shown)
--   - 'Surface' for the SDL window
--   - 'Adapter'
--   - 'Device'
--   - 'Queue'
loadResources ::
  forall m.
  (MonadResource m, MonadThrow m) =>
  -- | Initialization parameters.
  Params ->
  -- | Created application resources.
  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

-- | Resources for the app.
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})

-------------------------------------------------------------------------------
-- Map inside an MVar

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)

-------------------------------------------------------------------------------
-- Exceptions

-- | Exceptions from SimpleSDL.
data AppException
  = -- | Requesting an adapter failed.
    AdapterRequestFailed
  | -- | Requesting a device failed.
    DeviceRequestFailed
  | -- | Requesting a shader failed.
    UnknownShaderName ShaderName
  | -- | Requesting a render pipeline failed.
    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