{-# OPTIONS_GHC -Wwarn=orphans #-}
{-# LANGUAGE OverloadedLists #-}
module Engine.Vulkan.Shader
( Shader(..)
, create
, destroy
, withSpecialization
, Specialization(..)
, SpecializationConst(..)
) where
import RIO
import Data.Vector qualified as Vector
import Data.Vector.Storable qualified as Storable
import Foreign qualified
import Vulkan.Core10 qualified as Vk
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.Zero (Zero(..))
import Unsafe.Coerce (unsafeCoerce)
import Engine.Vulkan.Pipeline.Stages (StageInfo(..))
import Engine.Vulkan.Types (HasVulkan(..))
data Shader = Shader
{ Shader -> Vector ShaderModule
sModules :: Vector Vk.ShaderModule
, Shader -> Vector (SomeStruct PipelineShaderStageCreateInfo)
sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)
}
create
:: ( MonadIO io
, HasVulkan ctx
, StageInfo t
)
=> ctx
-> t (Maybe ByteString)
-> Maybe Vk.SpecializationInfo
-> io Shader
create :: forall (io :: * -> *) ctx (t :: * -> *).
(MonadIO io, HasVulkan ctx, StageInfo t) =>
ctx
-> t (Maybe ByteString) -> Maybe SpecializationInfo -> io Shader
create ctx
context t (Maybe ByteString)
stages Maybe SpecializationInfo
spec = do
Vector (ShaderModule, SomeStruct PipelineShaderStageCreateInfo)
staged <- forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
Vector.forM Vector (ShaderStageFlagBits, ByteString)
collected \(ShaderStageFlagBits
stage, ByteString
code) -> do
ShaderModule
module_ <- forall (a :: [*]) (io :: * -> *).
(Extendss ShaderModuleCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ShaderModuleCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ShaderModule
Vk.createShaderModule
(forall a. HasVulkan a => a -> Device
getDevice ctx
context)
forall a. Zero a => a
zero
{ $sel:code:ShaderModuleCreateInfo :: ByteString
Vk.code = ByteString
code
}
forall a. Maybe a
Nothing
pure
( ShaderModule
module_
, forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct forall a. Zero a => a
zero
{ $sel:stage:PipelineShaderStageCreateInfo :: ShaderStageFlagBits
Vk.stage = ShaderStageFlagBits
stage
, $sel:module':PipelineShaderStageCreateInfo :: ShaderModule
Vk.module' = ShaderModule
module_
, $sel:name:PipelineShaderStageCreateInfo :: ByteString
Vk.name = ByteString
"main"
, $sel:specializationInfo:PipelineShaderStageCreateInfo :: Maybe SpecializationInfo
Vk.specializationInfo = Maybe SpecializationInfo
spec
}
)
let (Vector ShaderModule
modules, Vector (SomeStruct PipelineShaderStageCreateInfo)
pStages) = forall a b. Vector (a, b) -> (Vector a, Vector b)
Vector.unzip Vector (ShaderModule, SomeStruct PipelineShaderStageCreateInfo)
staged
forall (f :: * -> *) a. Applicative f => a -> f a
pure Shader
{ $sel:sModules:Shader :: Vector ShaderModule
sModules = Vector ShaderModule
modules
, $sel:sPipelineStages:Shader :: Vector (SomeStruct PipelineShaderStageCreateInfo)
sPipelineStages = Vector (SomeStruct PipelineShaderStageCreateInfo)
pStages
}
where
collected :: Vector (ShaderStageFlagBits, ByteString)
collected = forall a. [a] -> Vector a
Vector.fromList do
(ShaderStageFlagBits
stage, Just ByteString
code) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *). StageInfo t => t ShaderStageFlagBits
stageFlagBits forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (Maybe ByteString)
stages
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShaderStageFlagBits
stage, ByteString
code)
destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io ()
destroy :: forall (io :: * -> *) ctx.
(MonadIO io, HasVulkan ctx) =>
ctx -> Shader -> io ()
destroy ctx
context Shader{Vector ShaderModule
sModules :: Vector ShaderModule
$sel:sModules:Shader :: Shader -> Vector ShaderModule
sModules} =
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector ShaderModule
sModules \ShaderModule
module_ ->
forall (io :: * -> *).
MonadIO io =>
Device
-> ShaderModule
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Vk.destroyShaderModule (forall a. HasVulkan a => a -> Device
getDevice ctx
context) ShaderModule
module_ forall a. Maybe a
Nothing
withSpecialization
:: ( Specialization spec
, MonadUnliftIO m
)
=> spec
-> (Maybe Vk.SpecializationInfo -> m a)
-> m a
withSpecialization :: forall spec (m :: * -> *) a.
(Specialization spec, MonadUnliftIO m) =>
spec -> (Maybe SpecializationInfo -> m a) -> m a
withSpecialization spec
spec Maybe SpecializationInfo -> m a
action =
case Vector SpecializationMapEntry
mapEntries of
[] ->
Maybe SpecializationInfo -> m a
action forall a. Maybe a
Nothing
Vector SpecializationMapEntry
_some ->
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. m a -> IO a
run ->
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
Storable.unsafeWith Vector Word32
specData \Ptr Word32
specPtr ->
forall a. m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SpecializationInfo -> m a
action forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Vk.SpecializationInfo
{ $sel:mapEntries:SpecializationInfo :: Vector SpecializationMapEntry
mapEntries = Vector SpecializationMapEntry
mapEntries
, $sel:dataSize:SpecializationInfo :: Word64
dataSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> Int
Storable.length Vector Word32
specData forall a. Num a => a -> a -> a
* Int
4
, $sel:data':SpecializationInfo :: Ptr ()
data' = forall a b. Ptr a -> Ptr b
Foreign.castPtr @_ @() Ptr Word32
specPtr
}
where
specData :: Vector Word32
specData = forall a. Storable a => [a] -> Vector a
Storable.fromList forall a b. (a -> b) -> a -> b
$ forall a. Specialization a => a -> [Word32]
specializationData spec
spec
mapEntries :: Vector SpecializationMapEntry
mapEntries = forall a b. (Int -> a -> b) -> Vector a -> Vector b
Vector.imap
(\Int
ix Word32
_data -> Vk.SpecializationMapEntry
{ $sel:constantID:SpecializationMapEntry :: Word32
constantID = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix
, $sel:offset:SpecializationMapEntry :: Word32
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
ix forall a. Num a => a -> a -> a
* Int
4
, $sel:size:SpecializationMapEntry :: Word64
size = Word64
4
}
)
(forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
Vector.convert Vector Word32
specData)
class Specialization a where
specializationData :: a -> [Word32]
instance Specialization () where
specializationData :: () -> [Word32]
specializationData = forall a b. a -> b -> a
const []
instance Specialization [Word32] where
specializationData :: [Word32] -> [Word32]
specializationData = forall a. a -> a
id
instance Specialization Word32 where
specializationData :: Word32 -> [Word32]
specializationData Word32
x = [forall a. SpecializationConst a => a -> Word32
packConstData Word32
x]
instance Specialization Int32 where
specializationData :: Int32 -> [Word32]
specializationData Int32
x = [forall a. SpecializationConst a => a -> Word32
packConstData Int32
x]
instance Specialization Float where
specializationData :: Float -> [Word32]
specializationData Float
x = [forall a. SpecializationConst a => a -> Word32
packConstData Float
x]
instance Specialization Bool where
specializationData :: Bool -> [Word32]
specializationData Bool
x = [forall a. SpecializationConst a => a -> Word32
packConstData Bool
x]
class SpecializationConst a where
packConstData :: a -> Word32
instance SpecializationConst Word32 where
packConstData :: Word32 -> Word32
packConstData = forall a. a -> a
id
instance SpecializationConst Int32 where
packConstData :: Int32 -> Word32
packConstData = forall a b. a -> b
unsafeCoerce
instance SpecializationConst Float where
packConstData :: Float -> Word32
packConstData = forall a b. a -> b
unsafeCoerce
instance SpecializationConst Bool where
packConstData :: Bool -> Word32
packConstData = forall a. a -> a -> Bool -> a
bool Word32
0 Word32
1
instance
( SpecializationConst a
, SpecializationConst b
) => Specialization (a, b) where
specializationData :: (a, b) -> [Word32]
specializationData (a
a, b
b) =
[ forall a. SpecializationConst a => a -> Word32
packConstData a
a
, forall a. SpecializationConst a => a -> Word32
packConstData b
b
]
instance
( SpecializationConst a
, SpecializationConst b
, SpecializationConst c
) => Specialization (a, b, c) where
specializationData :: (a, b, c) -> [Word32]
specializationData (a
a, b
b, c
c) =
[ forall a. SpecializationConst a => a -> Word32
packConstData a
a
, forall a. SpecializationConst a => a -> Word32
packConstData b
b
, forall a. SpecializationConst a => a -> Word32
packConstData c
c
]
instance
( SpecializationConst a
, SpecializationConst b
, SpecializationConst c
, SpecializationConst d
) => Specialization (a, b, c, d) where
specializationData :: (a, b, c, d) -> [Word32]
specializationData (a
a, b
b, c
c, d
d) =
[ forall a. SpecializationConst a => a -> Word32
packConstData a
a
, forall a. SpecializationConst a => a -> Word32
packConstData b
b
, forall a. SpecializationConst a => a -> Word32
packConstData c
c
, forall a. SpecializationConst a => a -> Word32
packConstData d
d
]
instance
( SpecializationConst a
, SpecializationConst b
, SpecializationConst c
, SpecializationConst d
, SpecializationConst e
) => Specialization (a, b, c, d, e) where
specializationData :: (a, b, c, d, e) -> [Word32]
specializationData (a
a, b
b, c
c, d
d, e
e) =
[ forall a. SpecializationConst a => a -> Word32
packConstData a
a
, forall a. SpecializationConst a => a -> Word32
packConstData b
b
, forall a. SpecializationConst a => a -> Word32
packConstData c
c
, forall a. SpecializationConst a => a -> Word32
packConstData d
d
, forall a. SpecializationConst a => a -> Word32
packConstData e
e
]
instance
( SpecializationConst a
, SpecializationConst b
, SpecializationConst c
, SpecializationConst d
, SpecializationConst e
, SpecializationConst f
) => Specialization (a, b, c, d, e, f) where
specializationData :: (a, b, c, d, e, f) -> [Word32]
specializationData (a
a, b
b, c
c, d
d, e
e, f
f) =
[ forall a. SpecializationConst a => a -> Word32
packConstData a
a
, forall a. SpecializationConst a => a -> Word32
packConstData b
b
, forall a. SpecializationConst a => a -> Word32
packConstData c
c
, forall a. SpecializationConst a => a -> Word32
packConstData d
d
, forall a. SpecializationConst a => a -> Word32
packConstData e
e
, forall a. SpecializationConst a => a -> Word32
packConstData f
f
]