{-# LANGUAGE UndecidableInstances #-}
module Engine.SpirV.Reflect where
import RIO
import Data.IntMap qualified as IntMap
import Data.List qualified as List
import Data.SpirV.Reflect.BlockVariable qualified as BlockVariable
import Data.SpirV.Reflect.DescriptorBinding qualified as DescriptorBinding
import Data.SpirV.Reflect.DescriptorSet qualified as DescriptorSet
import Data.SpirV.Reflect.Enums qualified as Enums
import Data.SpirV.Reflect.FFI qualified as Reflect
import Data.SpirV.Reflect.InterfaceVariable (InterfaceVariable)
import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable
import Data.SpirV.Reflect.Module (Module)
import Data.SpirV.Reflect.Module qualified as Module
import Data.SpirV.Reflect.Traits qualified as Traits
import Data.SpirV.Reflect.TypeDescription qualified as TypeDescription
import Data.Tree (Tree(..))
import Engine.Vulkan.Pipeline.Stages (StageInfo(..), withLabels)
import RIO.Text qualified as Text
import RIO.ByteString (readFile)
import Vulkan.Core10.Enums.Format qualified as VkFormat
invoke
:: MonadIO m
=> FilePath
-> m Module
invoke :: forall (m :: * -> *). MonadIO m => FilePath -> m Module
invoke FilePath
file =
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
readFile FilePath
file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (io :: * -> *). MonadIO io => ByteString -> io Module
Reflect.loadBytes
data Reflect stages = Reflect
{ forall (stages :: * -> *). Reflect stages -> BindMap BlockBinding
bindMap :: BindMap BlockBinding
, forall (stages :: * -> *). Reflect stages -> StageInterface stages
interfaces :: StageInterface stages
, forall (stages :: * -> *). Reflect stages -> Text
inputStage :: Text
, forall (stages :: * -> *). Reflect stages -> InterfaceBinds
inputs :: InterfaceBinds
}
type BindMap a = IntMap (IntMap a)
type StageInterface stages = stages (Maybe (InterfaceBinds, InterfaceBinds))
type InterfaceBinds = IntMap InterfaceBinding
deriving instance (Eq (StageInterface stages)) => Eq (Reflect stages)
deriving instance (Show (StageInterface stages)) => Show (Reflect stages)
type BlockBinding =
( Text
, Enums.DescriptorType
, Maybe (Tree ([Maybe Text], BlockSignature))
)
data BlockSignature = BlockSignature
{ BlockSignature -> Word32
offset :: Word32
, BlockSignature -> Word32
size :: Word32
, BlockSignature -> TypeFlags
flags :: Enums.TypeFlags
, BlockSignature -> Maybe Scalar
scalar :: Maybe Traits.Scalar
}
deriving (BlockSignature -> BlockSignature -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockSignature -> BlockSignature -> Bool
$c/= :: BlockSignature -> BlockSignature -> Bool
== :: BlockSignature -> BlockSignature -> Bool
$c== :: BlockSignature -> BlockSignature -> Bool
Eq, Eq BlockSignature
BlockSignature -> BlockSignature -> Bool
BlockSignature -> BlockSignature -> Ordering
BlockSignature -> BlockSignature -> BlockSignature
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 :: BlockSignature -> BlockSignature -> BlockSignature
$cmin :: BlockSignature -> BlockSignature -> BlockSignature
max :: BlockSignature -> BlockSignature -> BlockSignature
$cmax :: BlockSignature -> BlockSignature -> BlockSignature
>= :: BlockSignature -> BlockSignature -> Bool
$c>= :: BlockSignature -> BlockSignature -> Bool
> :: BlockSignature -> BlockSignature -> Bool
$c> :: BlockSignature -> BlockSignature -> Bool
<= :: BlockSignature -> BlockSignature -> Bool
$c<= :: BlockSignature -> BlockSignature -> Bool
< :: BlockSignature -> BlockSignature -> Bool
$c< :: BlockSignature -> BlockSignature -> Bool
compare :: BlockSignature -> BlockSignature -> Ordering
$ccompare :: BlockSignature -> BlockSignature -> Ordering
Ord, Int -> BlockSignature -> ShowS
[BlockSignature] -> ShowS
BlockSignature -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BlockSignature] -> ShowS
$cshowList :: [BlockSignature] -> ShowS
show :: BlockSignature -> FilePath
$cshow :: BlockSignature -> FilePath
showsPrec :: Int -> BlockSignature -> ShowS
$cshowsPrec :: Int -> BlockSignature -> ShowS
Show)
stagesBindMap
:: ( MonadIO m
, MonadReader env m
, HasLogFunc env
, StageInfo stages
)
=> stages (Maybe Module)
-> m (BindMap BlockBinding)
stagesBindMap :: forall (m :: * -> *) env (stages :: * -> *).
(MonadIO m, MonadReader env m, HasLogFunc env, StageInfo stages) =>
stages (Maybe Module) -> m (BindMap BlockBinding)
stagesBindMap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Text], BindMap BlockBinding)
-> (Text, Maybe Module) -> m ([Text], BindMap BlockBinding)
collect ([] :: [Text], forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *} {a} {a}.
(StageInfo f, IsString a) =>
f a -> f (a, a)
annotate
where
annotate :: f a -> f (a, a)
annotate f a
modules = (,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) label.
(StageInfo t, IsString label) =>
t label
stageNames
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
modules
collect :: ([Text], BindMap BlockBinding)
-> (Text, Maybe Module) -> m ([Text], BindMap BlockBinding)
collect acc :: ([Text], BindMap BlockBinding)
acc@([Text]
visited, BindMap BlockBinding
old) (Text
source, Maybe Module
stageModule) =
case Maybe Module
stageModule of
Maybe Module
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text], BindMap BlockBinding)
acc
Just Module
new ->
case forall {a} {a}.
BindMap (a, DescriptorType, Maybe (Tree (a, BlockSignature)))
-> BindMap (a, DescriptorType, Maybe (Tree (a, BlockSignature)))
-> Either
(Int, Int, (a, DescriptorType, Maybe (Tree (a, BlockSignature))),
(a, DescriptorType, Maybe (Tree (a, BlockSignature))))
(BindMap (a, DescriptorType, Maybe (Tree (a, BlockSignature))))
unionDS BindMap BlockBinding
old (Module -> BindMap BlockBinding
moduleBindMap Module
new) of
Left (Int
six, Int
bix, BlockBinding
inAcc, BlockBinding
inNew) -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
"incompatible data at "
, Utf8Builder
"layout("
, Utf8Builder
"set=", forall a. Display a => a -> Utf8Builder
display Int
six
, Utf8Builder
", "
, Utf8Builder
"binding=", forall a. Display a => a -> Utf8Builder
display Int
bix
, Utf8Builder
")"
]
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"old: " forall a. Semigroup a => a -> a -> a
<> forall {a} {t :: * -> *}.
(Display a, Foldable t, Functor t) =>
(a, DescriptorType, Maybe (t ([Maybe Text], BlockSignature)))
-> Utf8Builder
displayDS BlockBinding
inAcc
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
" from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow [Text]
visited
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"new: " forall a. Semigroup a => a -> a -> a
<> forall {a} {t :: * -> *}.
(Display a, Foldable t, Functor t) =>
(a, DescriptorType, Maybe (t ([Maybe Text], BlockSignature)))
-> Utf8Builder
displayDS BlockBinding
inNew
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
" from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
source
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"catch this"
Right BindMap BlockBinding
matching ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
visited forall a. Semigroup a => a -> a -> a
<> [Text
source], BindMap BlockBinding
matching)
unionDS :: BindMap (a, DescriptorType, Maybe (Tree (a, BlockSignature)))
-> BindMap (a, DescriptorType, Maybe (Tree (a, BlockSignature)))
-> Either
(Int, Int, (a, DescriptorType, Maybe (Tree (a, BlockSignature))),
(a, DescriptorType, Maybe (Tree (a, BlockSignature))))
(BindMap (a, DescriptorType, Maybe (Tree (a, BlockSignature))))
unionDS =
forall a.
(a -> a -> Bool)
-> BindMap a -> BindMap a -> Either (Int, Int, a, a) (BindMap a)
bindMapUnionWith \(a
_, DescriptorType
adt, Maybe (Tree (a, BlockSignature))
asig) (a
_, DescriptorType
bdt, Maybe (Tree (a, BlockSignature))
bsig) ->
DescriptorType
adt forall a. Eq a => a -> a -> Bool
== DescriptorType
bdt Bool -> Bool -> Bool
&&
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) Maybe (Tree (a, BlockSignature))
asig forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) Maybe (Tree (a, BlockSignature))
bsig
displayDS :: (a, DescriptorType, Maybe (t ([Maybe Text], BlockSignature)))
-> Utf8Builder
displayDS (a
name, DescriptorType
dt, Maybe (t ([Maybe Text], BlockSignature))
sigs) = forall a. Monoid a => [a] -> a
mconcat
[ forall a. Display a => a -> Utf8Builder
display a
name
, Utf8Builder
" :: "
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Show a => a -> Utf8Builder
displayShow DescriptorType
dt) forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$
forall label. IsString label => DescriptorType -> Maybe label
Enums.descriptorTypeName @Text DescriptorType
dt
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe
forall a. Monoid a => a
mempty
( \t ([Maybe Text], BlockSignature)
sigs' ->
forall a. Monoid a => a -> a -> a
mappend Utf8Builder
" -- " forall a b. (a -> b) -> a -> b
$
forall a. Show a => a -> Utf8Builder
displayShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$
t ([Maybe Text], BlockSignature)
sigs' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([Maybe Text]
path, BlockSignature{Maybe Scalar
Word32
TypeFlags
scalar :: Maybe Scalar
flags :: TypeFlags
size :: Word32
offset :: Word32
$sel:scalar:BlockSignature :: BlockSignature -> Maybe Scalar
$sel:flags:BlockSignature :: BlockSignature -> TypeFlags
$sel:size:BlockSignature :: BlockSignature -> Word32
$sel:offset:BlockSignature :: BlockSignature -> Word32
..}) ->
( Text -> [Text] -> Text
Text.intercalate Text
"|" (forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
path)
, (Word32
size, Word32
offset, forall label. IsString label => TypeFlags -> [label]
Enums.typeFlagsNames @Text TypeFlags
flags)
, Maybe Scalar
scalar
)
)
Maybe (t ([Maybe Text], BlockSignature))
sigs
]
moduleBindMap :: Module -> BindMap BlockBinding
moduleBindMap :: Module -> BindMap BlockBinding
moduleBindMap Module
refl = forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
DescriptorSet
ds <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Module -> Vector DescriptorSet
Module.descriptor_sets Module
refl
pure
( forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ DescriptorSet -> Word32
DescriptorSet.set DescriptorSet
ds
, forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
DescriptorBinding
db <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ DescriptorSet -> Vector DescriptorBinding
DescriptorSet.bindings DescriptorSet
ds
let
DescriptorBinding.DescriptorBinding
{Word32
$sel:binding:DescriptorBinding :: DescriptorBinding -> Word32
binding :: Word32
binding, Text
$sel:name:DescriptorBinding :: DescriptorBinding -> Text
name :: Text
name, DescriptorType
$sel:descriptor_type:DescriptorBinding :: DescriptorBinding -> DescriptorType
descriptor_type :: DescriptorType
descriptor_type, Maybe BlockVariable
$sel:block:DescriptorBinding :: DescriptorBinding -> Maybe BlockVariable
block :: Maybe BlockVariable
block} = DescriptorBinding
db
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
binding
, ( Text
name
, DescriptorType
descriptor_type
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe Text]
-> BlockVariable -> Tree ([Maybe Text], BlockSignature)
blockTree []) Maybe BlockVariable
block
)
)
)
blockTree
:: [Maybe Text]
-> BlockVariable.BlockVariable
-> Tree ([Maybe Text], BlockSignature)
blockTree :: [Maybe Text]
-> BlockVariable -> Tree ([Maybe Text], BlockSignature)
blockTree [Maybe Text]
ancestors BlockVariable
bv = forall a. a -> [Tree a] -> Tree a
Node ([Maybe Text]
path, BlockSignature
here) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Maybe Text]
-> BlockVariable -> Tree ([Maybe Text], BlockSignature)
blockTree [Maybe Text]
path) [BlockVariable]
there
where
here :: BlockSignature
here = BlockSignature
{ $sel:offset:BlockSignature :: Word32
offset = BlockVariable -> Word32
BlockVariable.offset BlockVariable
bv
, $sel:size:BlockSignature :: Word32
size = BlockVariable -> Word32
BlockVariable.size BlockVariable
bv
, Maybe Scalar
TypeFlags
scalar :: Maybe Scalar
flags :: TypeFlags
$sel:scalar:BlockSignature :: Maybe Scalar
$sel:flags:BlockSignature :: TypeFlags
..
}
where
(TypeFlags
flags, Maybe Scalar
scalar) =
case BlockVariable -> Maybe TypeDescription
BlockVariable.type_description BlockVariable
bv of
Maybe TypeDescription
Nothing ->
(TypeFlags
Enums.TYPE_FLAG_UNDEFINED, forall a. Maybe a
Nothing)
Just TypeDescription
td ->
( TypeDescription -> TypeFlags
TypeDescription.type_flags TypeDescription
td
, do
TypeDescription.Traits{Numeric
$sel:numeric:Traits :: Traits -> Numeric
numeric :: Numeric
numeric} <- TypeDescription -> Maybe Traits
TypeDescription.traits TypeDescription
td
let st :: Scalar
st@Traits.Scalar{Word32
$sel:width:Scalar :: Scalar -> Word32
width :: Word32
width} = Numeric -> Scalar
Traits.scalar Numeric
numeric
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word32
width forall a. Ord a => a -> a -> Bool
> Word32
0
pure Scalar
st
)
path :: [Maybe Text]
path =
[Maybe Text]
ancestors forall a. [a] -> [a] -> [a]
++ [BlockVariable -> Maybe Text
BlockVariable.name BlockVariable
bv]
there :: [BlockVariable]
there =
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ BlockVariable -> Vector BlockVariable
BlockVariable.members BlockVariable
bv
{-# INLINE bindMapUnionWith #-}
bindMapUnionWith
:: (a -> a -> Bool)
-> BindMap a
-> BindMap a
-> Either (Int, Int, a, a) (BindMap a)
bindMapUnionWith :: forall a.
(a -> a -> Bool)
-> BindMap a -> BindMap a -> Either (Int, Int, a, a) (BindMap a)
bindMapUnionWith a -> a -> Bool
compatible BindMap a
as BindMap a
bs = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence IntMap (IntMap (Either (Int, Int, a, a) a))
validated
where
validated :: IntMap (IntMap (Either (Int, Int, a, a) a))
validated =
forall a. (Int -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWithKey
(forall a. (Int -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWithKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
check)
(forall {a}.
IntMap (IntMap a) -> IntMap (IntMap (Either (Int, Int, a, a) a))
wrap BindMap a
as)
(forall {a}.
IntMap (IntMap a) -> IntMap (IntMap (Either (Int, Int, a, a) a))
wrap BindMap a
bs)
wrap :: IntMap (IntMap a) -> IntMap (IntMap (Either (Int, Int, a, a) a))
wrap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure)
check :: Int
-> Int
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
check Int
six Int
bix Either (Int, Int, a, a) a
a' Either (Int, Int, a, a) a
b' = do
a
a <- Either (Int, Int, a, a) a
a'
a
b <- Either (Int, Int, a, a) a
b'
if a -> a -> Bool
compatible a
a a
b then
forall a b. b -> Either a b
Right a
a
else
forall a b. a -> Either a b
Left (Int
six, Int
bix, a
a, a
b)
type InterfaceBinding =
( Maybe Text
, [Text]
, InterfaceSignature
)
data InterfaceSignature = InterfaceSignature
{ InterfaceSignature -> Format
format :: VkFormat.Format
, InterfaceSignature -> TypeFlags
flags :: Enums.TypeFlags
, InterfaceSignature -> Maybe Matrix
matrix :: Maybe Traits.Matrix
}
deriving (InterfaceSignature -> InterfaceSignature -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InterfaceSignature -> InterfaceSignature -> Bool
$c/= :: InterfaceSignature -> InterfaceSignature -> Bool
== :: InterfaceSignature -> InterfaceSignature -> Bool
$c== :: InterfaceSignature -> InterfaceSignature -> Bool
Eq, Eq InterfaceSignature
InterfaceSignature -> InterfaceSignature -> Bool
InterfaceSignature -> InterfaceSignature -> Ordering
InterfaceSignature -> InterfaceSignature -> InterfaceSignature
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 :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
$cmin :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
max :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
$cmax :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
>= :: InterfaceSignature -> InterfaceSignature -> Bool
$c>= :: InterfaceSignature -> InterfaceSignature -> Bool
> :: InterfaceSignature -> InterfaceSignature -> Bool
$c> :: InterfaceSignature -> InterfaceSignature -> Bool
<= :: InterfaceSignature -> InterfaceSignature -> Bool
$c<= :: InterfaceSignature -> InterfaceSignature -> Bool
< :: InterfaceSignature -> InterfaceSignature -> Bool
$c< :: InterfaceSignature -> InterfaceSignature -> Bool
compare :: InterfaceSignature -> InterfaceSignature -> Ordering
$ccompare :: InterfaceSignature -> InterfaceSignature -> Ordering
Ord, Int -> InterfaceSignature -> ShowS
[InterfaceSignature] -> ShowS
InterfaceSignature -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [InterfaceSignature] -> ShowS
$cshowList :: [InterfaceSignature] -> ShowS
show :: InterfaceSignature -> FilePath
$cshow :: InterfaceSignature -> FilePath
showsPrec :: Int -> InterfaceSignature -> ShowS
$cshowsPrec :: Int -> InterfaceSignature -> ShowS
Show)
stagesInterfaceMap
:: ( MonadIO m
, Traversable stages
)
=> stages (Maybe Module)
-> m (StageInterface stages)
stagesInterfaceMap :: forall (m :: * -> *) (stages :: * -> *).
(MonadIO m, Traversable stages) =>
stages (Maybe Module) -> m (StageInterface stages)
stagesInterfaceMap = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> (InterfaceBinds, InterfaceBinds)
moduleInterfaceBinds)
moduleInterfaceBinds :: Module -> (InterfaceBinds, InterfaceBinds)
moduleInterfaceBinds :: Module -> (InterfaceBinds, InterfaceBinds)
moduleInterfaceBinds Module
refl =
( StorageClass -> Vector InterfaceVariable -> InterfaceBinds
interfaceBinds StorageClass
Enums.StorageClassInput (Module -> Vector InterfaceVariable
Module.input_variables Module
refl)
, StorageClass -> Vector InterfaceVariable -> InterfaceBinds
interfaceBinds StorageClass
Enums.StorageClassOutput (Module -> Vector InterfaceVariable
Module.output_variables Module
refl)
)
interfaceBinds :: Enums.StorageClass -> Vector InterfaceVariable -> InterfaceBinds
interfaceBinds :: StorageClass -> Vector InterfaceVariable -> InterfaceBinds
interfaceBinds StorageClass
cls Vector InterfaceVariable
vars = forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
var :: InterfaceVariable
var@InterfaceVariable.InterfaceVariable{Word32
$sel:location:InterfaceVariable :: InterfaceVariable -> Word32
location :: Word32
location} <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector InterfaceVariable
vars
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ InterfaceVariable -> StorageClass
InterfaceVariable.storage_class InterfaceVariable
var forall a. Eq a => a -> a -> Bool
== StorageClass
cls
let
td :: Maybe TypeDescription
td = InterfaceVariable -> Maybe TypeDescription
InterfaceVariable.type_description InterfaceVariable
var
Enums.Format Int
format = InterfaceVariable -> Format
InterfaceVariable.format InterfaceVariable
var
flags :: TypeFlags
flags = forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeFlags
Enums.TYPE_FLAG_UNDEFINED TypeDescription -> TypeFlags
TypeDescription.type_flags Maybe TypeDescription
td
stuff :: Maybe Matrix
stuff = do
TypeDescription.TypeDescription{Maybe Traits
traits :: Maybe Traits
$sel:traits:TypeDescription :: TypeDescription -> Maybe Traits
traits} <- Maybe TypeDescription
td
TypeDescription.Traits{Numeric
numeric :: Numeric
$sel:numeric:Traits :: Traits -> Numeric
numeric} <- Maybe Traits
traits
let
mt :: Matrix
mt@Traits.Matrix{Word32
$sel:column_count:Matrix :: Matrix -> Word32
column_count :: Word32
column_count, Word32
$sel:row_count:Matrix :: Matrix -> Word32
row_count :: Word32
row_count} = Numeric -> Matrix
Traits.matrix Numeric
numeric
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word32
column_count forall a. Ord a => a -> a -> Bool
> Word32
0 Bool -> Bool -> Bool
&& Word32
row_count forall a. Ord a => a -> a -> Bool
> Word32
0
pure Matrix
mt
signature :: InterfaceSignature
signature = InterfaceSignature
{ $sel:format:InterfaceSignature :: Format
format = Int32 -> Format
VkFormat.Format forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
format
, $sel:flags:InterfaceSignature :: TypeFlags
flags = TypeFlags
flags
, $sel:matrix:InterfaceSignature :: Maybe Matrix
matrix = Maybe Matrix
stuff
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
location
, ( InterfaceVariable -> Maybe Text
InterfaceVariable.name InterfaceVariable
var
, forall label. IsString label => TypeFlags -> [label]
Enums.typeFlagsNames @Text TypeFlags
flags
, InterfaceSignature
signature
)
)
type IncompatibleInterfaces label = (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
type CompatibleInterfaces label = (label, label, IntMap ([Text], Matching (Maybe Text)))
type Matching a = Either (a, a) a
interfaceCompatible
:: ( StageInfo stages
, IsString label
)
=> StageInterface stages
-> Either (IncompatibleInterfaces label) [CompatibleInterfaces label]
interfaceCompatible :: forall (stages :: * -> *) label.
(StageInfo stages, IsString label) =>
StageInterface stages
-> Either
(IncompatibleInterfaces label) [CompatibleInterfaces label]
interfaceCompatible StageInterface stages
staged =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [((label, InterfaceBinds), (label, InterfaceBinds))]
chained \((label
inputLabel, InterfaceBinds
input), (label
outputLabel, InterfaceBinds
output)) -> do
[(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))]
checked <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a. IntMap a -> [(Int, a)]
IntMap.assocs InterfaceBinds
input) \(Int
location, (Maybe Text, [Text], InterfaceSignature)
requested) ->
case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
location InterfaceBinds
output of
Just (Maybe Text, [Text], InterfaceSignature)
provided -> do
let
(Maybe Text
rName, [Text]
rFlags, InterfaceSignature
rSignature) = (Maybe Text, [Text], InterfaceSignature)
requested
(Maybe Text
pName, [Text]
_pFlags, InterfaceSignature
pSignature) = (Maybe Text, [Text], InterfaceSignature)
provided
if InterfaceSignature
rSignature forall a. Eq a => a -> a -> Bool
== InterfaceSignature
pSignature then
let
names :: Either (Maybe Text, Maybe Text) (Maybe Text)
names =
if Maybe Text
rName forall a. Eq a => a -> a -> Bool
== Maybe Text
pName then
forall a b. b -> Either a b
Right Maybe Text
rName
else
forall a b. a -> Either a b
Left (Maybe Text
rName, Maybe Text
pName)
in
forall a b. b -> Either a b
Right (Int
location, ([Text]
rFlags, Either (Maybe Text, Maybe Text) (Maybe Text)
names))
else
forall a b. a -> Either a b
Left
( label
inputLabel
, label
outputLabel
, Int
location
, forall a. a -> Maybe a
Just (InterfaceSignature
rSignature, InterfaceSignature
pSignature)
)
Maybe (Maybe Text, [Text], InterfaceSignature)
Nothing ->
forall a b. a -> Either a b
Left
( label
inputLabel
, label
outputLabel
, Int
location
, forall a. Maybe a
Nothing
)
forall a b. b -> Either a b
Right
( label
outputLabel
, label
inputLabel
, forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))]
checked
)
where
chained :: [((label, InterfaceBinds), (label, InterfaceBinds))]
chained = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Int -> [a] -> [a]
drop Int
1 [(label, InterfaceBinds)]
ins) [(label, InterfaceBinds)]
outs
([(label, InterfaceBinds)]
ins, [(label, InterfaceBinds)]
outs) =
forall a b. [(a, b)] -> ([a], [b])
List.unzip do
(label
label, Just (InterfaceBinds, InterfaceBinds)
binds) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a} {a}.
(StageInfo f, IsString a) =>
f a -> f (a, a)
withLabels StageInterface stages
staged
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (label
label, forall a b. (a, b) -> a
fst (InterfaceBinds, InterfaceBinds)
binds)
, (label
label, forall a b. (a, b) -> b
snd (InterfaceBinds, InterfaceBinds)
binds)
)
inputStageInterface
:: (StageInfo stages, IsString label)
=> StageInterface stages
-> Maybe (label, InterfaceBinds)
inputStageInterface :: forall (stages :: * -> *) label.
(StageInfo stages, IsString label) =>
StageInterface stages -> Maybe (label, InterfaceBinds)
inputStageInterface StageInterface stages
staged = forall a. [a] -> Maybe a
listToMaybe [(label, InterfaceBinds)]
active
where
active :: [(label, InterfaceBinds)]
active = do
(label
label, Just (InterfaceBinds, InterfaceBinds)
binds) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a} {a}.
(StageInfo f, IsString a) =>
f a -> f (a, a)
withLabels StageInterface stages
staged
forall (f :: * -> *) a. Applicative f => a -> f a
pure (label
label, forall a b. (a, b) -> a
fst (InterfaceBinds, InterfaceBinds)
binds)