{-# 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 =
FilePath -> m ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
readFile FilePath
file m ByteString -> (ByteString -> m Module) -> m Module
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> m Module
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
(BlockSignature -> BlockSignature -> Bool)
-> (BlockSignature -> BlockSignature -> Bool) -> Eq BlockSignature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockSignature -> BlockSignature -> Bool
== :: BlockSignature -> BlockSignature -> Bool
$c/= :: BlockSignature -> BlockSignature -> Bool
/= :: BlockSignature -> BlockSignature -> Bool
Eq, Eq BlockSignature
Eq BlockSignature
-> (BlockSignature -> BlockSignature -> Ordering)
-> (BlockSignature -> BlockSignature -> Bool)
-> (BlockSignature -> BlockSignature -> Bool)
-> (BlockSignature -> BlockSignature -> Bool)
-> (BlockSignature -> BlockSignature -> Bool)
-> (BlockSignature -> BlockSignature -> BlockSignature)
-> (BlockSignature -> BlockSignature -> BlockSignature)
-> Ord 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
$ccompare :: BlockSignature -> BlockSignature -> Ordering
compare :: BlockSignature -> BlockSignature -> Ordering
$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
>= :: BlockSignature -> BlockSignature -> Bool
$cmax :: BlockSignature -> BlockSignature -> BlockSignature
max :: BlockSignature -> BlockSignature -> BlockSignature
$cmin :: BlockSignature -> BlockSignature -> BlockSignature
min :: BlockSignature -> BlockSignature -> BlockSignature
Ord, Int -> BlockSignature -> ShowS
[BlockSignature] -> ShowS
BlockSignature -> FilePath
(Int -> BlockSignature -> ShowS)
-> (BlockSignature -> FilePath)
-> ([BlockSignature] -> ShowS)
-> Show BlockSignature
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockSignature -> ShowS
showsPrec :: Int -> BlockSignature -> ShowS
$cshow :: BlockSignature -> FilePath
show :: BlockSignature -> FilePath
$cshowList :: [BlockSignature] -> ShowS
showList :: [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 = (([Text], BindMap BlockBinding) -> BindMap BlockBinding)
-> m ([Text], BindMap BlockBinding) -> m (BindMap BlockBinding)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text], BindMap BlockBinding) -> BindMap BlockBinding
forall a b. (a, b) -> b
snd (m ([Text], BindMap BlockBinding) -> m (BindMap BlockBinding))
-> (stages (Maybe Module) -> m ([Text], BindMap BlockBinding))
-> stages (Maybe Module)
-> m (BindMap BlockBinding)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Text], BindMap BlockBinding)
-> (Text, Maybe Module) -> m ([Text], BindMap BlockBinding))
-> ([Text], BindMap BlockBinding)
-> stages (Text, Maybe Module)
-> m ([Text], BindMap BlockBinding)
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], BindMap BlockBinding
forall a. Monoid a => a
mempty) (stages (Text, Maybe Module) -> m ([Text], BindMap BlockBinding))
-> (stages (Maybe Module) -> stages (Text, Maybe Module))
-> stages (Maybe Module)
-> m ([Text], BindMap BlockBinding)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. stages (Maybe Module) -> stages (Text, Maybe Module)
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 = (,)
(a -> a -> (a, a)) -> f a -> f (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall label. IsString label => f label
forall (t :: * -> *) label.
(StageInfo t, IsString label) =>
t label
stageNames
f (a -> (a, a)) -> f a -> f (a, a)
forall a b. f (a -> b) -> f a -> f b
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 ->
([Text], BindMap BlockBinding) -> m ([Text], BindMap BlockBinding)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text], BindMap BlockBinding)
acc
Just Module
new ->
case BindMap BlockBinding
-> BindMap BlockBinding
-> Either
(Int, Int, BlockBinding, BlockBinding) (BindMap BlockBinding)
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
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
"incompatible data at "
, Utf8Builder
"layout("
, Utf8Builder
"set=", Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
six
, Utf8Builder
", "
, Utf8Builder
"binding=", Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
bix
, Utf8Builder
")"
]
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"old: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> BlockBinding -> Utf8Builder
forall {a} {t :: * -> *}.
(Display a, Foldable t, Functor t) =>
(a, DescriptorType, Maybe (t ([Maybe Text], BlockSignature)))
-> Utf8Builder
displayDS BlockBinding
inAcc
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
" from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [Text]
visited
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"new: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> BlockBinding -> Utf8Builder
forall {a} {t :: * -> *}.
(Display a, Foldable t, Functor t) =>
(a, DescriptorType, Maybe (t ([Maybe Text], BlockSignature)))
-> Utf8Builder
displayDS BlockBinding
inNew
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
" from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Text
source
FilePath -> m ([Text], BindMap BlockBinding)
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"catch this"
Right BindMap BlockBinding
matching ->
([Text], BindMap BlockBinding) -> m ([Text], BindMap BlockBinding)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
visited [Text] -> [Text] -> [Text]
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 =
((a, DescriptorType, Maybe (Tree (a, BlockSignature)))
-> (a, DescriptorType, Maybe (Tree (a, BlockSignature))) -> Bool)
-> 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))))
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 DescriptorType -> DescriptorType -> Bool
forall a. Eq a => a -> a -> Bool
== DescriptorType
bdt Bool -> Bool -> Bool
&&
(Tree (a, BlockSignature) -> Tree BlockSignature)
-> Maybe (Tree (a, BlockSignature)) -> Maybe (Tree BlockSignature)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, BlockSignature) -> BlockSignature)
-> Tree (a, BlockSignature) -> Tree BlockSignature
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, BlockSignature) -> BlockSignature
forall a b. (a, b) -> b
snd) Maybe (Tree (a, BlockSignature))
asig Maybe (Tree BlockSignature) -> Maybe (Tree BlockSignature) -> Bool
forall a. Eq a => a -> a -> Bool
== (Tree (a, BlockSignature) -> Tree BlockSignature)
-> Maybe (Tree (a, BlockSignature)) -> Maybe (Tree BlockSignature)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, BlockSignature) -> BlockSignature)
-> Tree (a, BlockSignature) -> Tree BlockSignature
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, BlockSignature) -> BlockSignature
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) = [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[ a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
name
, Utf8Builder
" :: "
, Utf8Builder -> (Text -> Utf8Builder) -> Maybe Text -> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DescriptorType -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow DescriptorType
dt) Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Maybe Text -> Utf8Builder) -> Maybe Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$
forall label. IsString label => DescriptorType -> Maybe label
Enums.descriptorTypeName @Text DescriptorType
dt
, Utf8Builder
-> (t ([Maybe Text], BlockSignature) -> Utf8Builder)
-> Maybe (t ([Maybe Text], BlockSignature))
-> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Utf8Builder
forall a. Monoid a => a
mempty
( \t ([Maybe Text], BlockSignature)
sigs' ->
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Monoid a => a -> a -> a
mappend Utf8Builder
" -- " (Utf8Builder -> Utf8Builder) -> Utf8Builder -> Utf8Builder
forall a b. (a -> b) -> a -> b
$
[(Text, (Word32, Word32, [Text]), Maybe Scalar)] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow ([(Text, (Word32, Word32, [Text]), Maybe Scalar)] -> Utf8Builder)
-> (t (Text, (Word32, Word32, [Text]), Maybe Scalar)
-> [(Text, (Word32, Word32, [Text]), Maybe Scalar)])
-> t (Text, (Word32, Word32, [Text]), Maybe Scalar)
-> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Text, (Word32, Word32, [Text]), Maybe Scalar)
-> [(Text, (Word32, Word32, [Text]), Maybe Scalar)]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t (Text, (Word32, Word32, [Text]), Maybe Scalar) -> Utf8Builder)
-> t (Text, (Word32, Word32, [Text]), Maybe Scalar) -> Utf8Builder
forall a b. (a -> b) -> a -> b
$
t ([Maybe Text], BlockSignature)
sigs' t ([Maybe Text], BlockSignature)
-> (([Maybe Text], BlockSignature)
-> (Text, (Word32, Word32, [Text]), Maybe Scalar))
-> t (Text, (Word32, Word32, [Text]), Maybe Scalar)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([Maybe Text]
path, BlockSignature{Maybe Scalar
Word32
TypeFlags
$sel:offset:BlockSignature :: BlockSignature -> Word32
$sel:size:BlockSignature :: BlockSignature -> Word32
$sel:flags:BlockSignature :: BlockSignature -> TypeFlags
$sel:scalar:BlockSignature :: BlockSignature -> Maybe Scalar
offset :: Word32
size :: Word32
flags :: TypeFlags
scalar :: Maybe Scalar
..}) ->
( Text -> [Text] -> Text
Text.intercalate Text
"|" ([Maybe Text] -> [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 = [(Int, IntMap BlockBinding)] -> BindMap BlockBinding
forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
DescriptorSet
ds <- Vector DescriptorSet -> [DescriptorSet]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector DescriptorSet -> [DescriptorSet])
-> Vector DescriptorSet -> [DescriptorSet]
forall a b. (a -> b) -> a -> b
$ Module -> Vector DescriptorSet
Module.descriptor_sets Module
refl
pure
( Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ DescriptorSet -> Word32
DescriptorSet.set DescriptorSet
ds
, [(Int, BlockBinding)] -> IntMap BlockBinding
forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
DescriptorBinding
db <- Vector DescriptorBinding -> [DescriptorBinding]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector DescriptorBinding -> [DescriptorBinding])
-> Vector DescriptorBinding -> [DescriptorBinding]
forall a b. (a -> b) -> a -> b
$ DescriptorSet -> Vector DescriptorBinding
DescriptorSet.bindings DescriptorSet
ds
let
DescriptorBinding.DescriptorBinding
{Word32
binding :: Word32
$sel:binding:DescriptorBinding :: DescriptorBinding -> Word32
binding, Text
name :: Text
$sel:name:DescriptorBinding :: DescriptorBinding -> Text
name, DescriptorType
descriptor_type :: DescriptorType
$sel:descriptor_type:DescriptorBinding :: DescriptorBinding -> DescriptorType
descriptor_type, Maybe BlockVariable
block :: Maybe BlockVariable
$sel:block:DescriptorBinding :: DescriptorBinding -> Maybe BlockVariable
block} = DescriptorBinding
db
(Int, BlockBinding) -> [(Int, BlockBinding)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
binding
, ( Text
name
, DescriptorType
descriptor_type
, (BlockVariable -> Tree ([Maybe Text], BlockSignature))
-> Maybe BlockVariable
-> Maybe (Tree ([Maybe Text], BlockSignature))
forall a b. (a -> b) -> Maybe a -> Maybe b
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 = ([Maybe Text], BlockSignature)
-> [Tree ([Maybe Text], BlockSignature)]
-> Tree ([Maybe Text], BlockSignature)
forall a. a -> [Tree a] -> Tree a
Node ([Maybe Text]
path, BlockSignature
here) ([Tree ([Maybe Text], BlockSignature)]
-> Tree ([Maybe Text], BlockSignature))
-> [Tree ([Maybe Text], BlockSignature)]
-> Tree ([Maybe Text], BlockSignature)
forall a b. (a -> b) -> a -> b
$ (BlockVariable -> Tree ([Maybe Text], BlockSignature))
-> [BlockVariable] -> [Tree ([Maybe Text], BlockSignature)]
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
$sel:flags:BlockSignature :: TypeFlags
$sel:scalar:BlockSignature :: Maybe Scalar
flags :: TypeFlags
scalar :: Maybe Scalar
..
}
where
(TypeFlags
flags, Maybe Scalar
scalar) =
case BlockVariable -> Maybe TypeDescription
BlockVariable.type_description BlockVariable
bv of
Maybe TypeDescription
Nothing ->
(TypeFlags
Enums.TYPE_FLAG_UNDEFINED, Maybe Scalar
forall a. Maybe a
Nothing)
Just TypeDescription
td ->
( TypeDescription -> TypeFlags
TypeDescription.type_flags TypeDescription
td
, do
TypeDescription.Traits{Numeric
numeric :: Numeric
$sel:numeric:Traits :: Traits -> Numeric
numeric} <- TypeDescription -> Maybe Traits
TypeDescription.traits TypeDescription
td
let st :: Scalar
st@Traits.Scalar{Word32
width :: Word32
$sel:width:Scalar :: Scalar -> Word32
width} = Numeric -> Scalar
Traits.scalar Numeric
numeric
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word32
width Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
pure Scalar
st
)
path :: [Maybe Text]
path =
[Maybe Text]
ancestors [Maybe Text] -> [Maybe Text] -> [Maybe Text]
forall a. [a] -> [a] -> [a]
++ [BlockVariable -> Maybe Text
BlockVariable.name BlockVariable
bv]
there :: [BlockVariable]
there =
Vector BlockVariable -> [BlockVariable]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector BlockVariable -> [BlockVariable])
-> Vector BlockVariable -> [BlockVariable]
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 = (IntMap (Either (Int, Int, a, a) a)
-> Either (Int, Int, a, a) (IntMap a))
-> IntMap (IntMap (Either (Int, Int, a, a) a))
-> Either (Int, Int, a, a) (BindMap a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntMap a -> f (IntMap b)
traverse IntMap (Either (Int, Int, a, a) a)
-> Either (Int, Int, a, a) (IntMap a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => IntMap (m a) -> m (IntMap a)
sequence IntMap (IntMap (Either (Int, Int, a, a) a))
validated
where
validated :: IntMap (IntMap (Either (Int, Int, a, a) a))
validated =
(Int
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a))
-> IntMap (IntMap (Either (Int, Int, a, a) a))
-> IntMap (IntMap (Either (Int, Int, a, a) a))
-> IntMap (IntMap (Either (Int, Int, a, a) a))
forall a. (Int -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWithKey
((Int
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
forall a. (Int -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWithKey ((Int
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a))
-> (Int
-> Int
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a
-> Either (Int, Int, a, a) a)
-> Int
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
-> IntMap (Either (Int, Int, a, a) a)
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)
(BindMap a -> IntMap (IntMap (Either (Int, Int, a, a) a))
forall {a}.
IntMap (IntMap a) -> IntMap (IntMap (Either (Int, Int, a, a) a))
wrap BindMap a
as)
(BindMap a -> IntMap (IntMap (Either (Int, Int, a, a) a))
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 = (IntMap a -> IntMap (Either (Int, Int, a, a) a))
-> IntMap (IntMap a) -> IntMap (IntMap (Either (Int, Int, a, a) a))
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Either (Int, Int, a, a) a)
-> IntMap a -> IntMap (Either (Int, Int, a, a) a)
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either (Int, Int, a, a) a
forall a. a -> Either (Int, Int, a, a) a
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
a -> Either (Int, Int, a, a) a
forall a b. b -> Either a b
Right a
a
else
(Int, Int, a, a) -> Either (Int, Int, a, a) a
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
(InterfaceSignature -> InterfaceSignature -> Bool)
-> (InterfaceSignature -> InterfaceSignature -> Bool)
-> Eq InterfaceSignature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InterfaceSignature -> InterfaceSignature -> Bool
== :: InterfaceSignature -> InterfaceSignature -> Bool
$c/= :: InterfaceSignature -> InterfaceSignature -> Bool
/= :: InterfaceSignature -> InterfaceSignature -> Bool
Eq, Eq InterfaceSignature
Eq InterfaceSignature
-> (InterfaceSignature -> InterfaceSignature -> Ordering)
-> (InterfaceSignature -> InterfaceSignature -> Bool)
-> (InterfaceSignature -> InterfaceSignature -> Bool)
-> (InterfaceSignature -> InterfaceSignature -> Bool)
-> (InterfaceSignature -> InterfaceSignature -> Bool)
-> (InterfaceSignature -> InterfaceSignature -> InterfaceSignature)
-> (InterfaceSignature -> InterfaceSignature -> InterfaceSignature)
-> Ord 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
$ccompare :: InterfaceSignature -> InterfaceSignature -> Ordering
compare :: InterfaceSignature -> InterfaceSignature -> Ordering
$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
>= :: InterfaceSignature -> InterfaceSignature -> Bool
$cmax :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
max :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
$cmin :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
min :: InterfaceSignature -> InterfaceSignature -> InterfaceSignature
Ord, Int -> InterfaceSignature -> ShowS
[InterfaceSignature] -> ShowS
InterfaceSignature -> FilePath
(Int -> InterfaceSignature -> ShowS)
-> (InterfaceSignature -> FilePath)
-> ([InterfaceSignature] -> ShowS)
-> Show InterfaceSignature
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InterfaceSignature -> ShowS
showsPrec :: Int -> InterfaceSignature -> ShowS
$cshow :: InterfaceSignature -> FilePath
show :: InterfaceSignature -> FilePath
$cshowList :: [InterfaceSignature] -> ShowS
showList :: [InterfaceSignature] -> ShowS
Show)
stagesInterfaceMap
:: ( Traversable stages
)
=> stages (Maybe Module)
-> StageInterface stages
stagesInterfaceMap :: forall (stages :: * -> *).
Traversable stages =>
stages (Maybe Module) -> StageInterface stages
stagesInterfaceMap = (Maybe Module -> Maybe (InterfaceBinds, InterfaceBinds))
-> stages (Maybe Module)
-> stages (Maybe (InterfaceBinds, InterfaceBinds))
forall a b. (a -> b) -> stages a -> stages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Module -> (InterfaceBinds, InterfaceBinds))
-> Maybe Module -> Maybe (InterfaceBinds, InterfaceBinds)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = [(Int, (Maybe Text, [Text], InterfaceSignature))] -> InterfaceBinds
forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
var :: InterfaceVariable
var@InterfaceVariable.InterfaceVariable{Word32
location :: Word32
$sel:location:InterfaceVariable :: InterfaceVariable -> Word32
location} <- Vector InterfaceVariable -> [InterfaceVariable]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector InterfaceVariable
vars
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ InterfaceVariable -> StorageClass
InterfaceVariable.storage_class InterfaceVariable
var StorageClass -> StorageClass -> Bool
forall a. Eq a => a -> a -> Bool
== StorageClass
cls
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ InterfaceVariable -> BuiltIn
InterfaceVariable.built_in InterfaceVariable
var BuiltIn -> BuiltIn -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltIn
forall a. Bounded a => a
maxBound
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 = TypeFlags
-> (TypeDescription -> TypeFlags)
-> Maybe TypeDescription
-> TypeFlags
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
$sel:traits:TypeDescription :: TypeDescription -> Maybe Traits
traits :: Maybe Traits
traits} <- Maybe TypeDescription
td
TypeDescription.Traits{Numeric
$sel:numeric:Traits :: Traits -> Numeric
numeric :: Numeric
numeric} <- Maybe Traits
traits
let
mt :: Matrix
mt@Traits.Matrix{Word32
column_count :: Word32
$sel:column_count:Matrix :: Matrix -> Word32
column_count, Word32
row_count :: Word32
$sel:row_count:Matrix :: Matrix -> Word32
row_count} = Numeric -> Matrix
Traits.matrix Numeric
numeric
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word32
column_count Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0 Bool -> Bool -> Bool
&& Word32
row_count Word32 -> Word32 -> Bool
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 (Int32 -> Format) -> Int32 -> Format
forall a b. (a -> b) -> a -> b
$ Int -> Int32
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
}
pure
( Word32 -> Int
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 =
[((label, InterfaceBinds), (label, InterfaceBinds))]
-> (((label, InterfaceBinds), (label, InterfaceBinds))
-> Either
(IncompatibleInterfaces label) (CompatibleInterfaces label))
-> Either
(IncompatibleInterfaces label) [CompatibleInterfaces label]
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 <- [(Int, (Maybe Text, [Text], InterfaceSignature))]
-> ((Int, (Maybe Text, [Text], InterfaceSignature))
-> Either
(IncompatibleInterfaces label)
(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text))))
-> Either
(IncompatibleInterfaces label)
[(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (InterfaceBinds -> [(Int, (Maybe Text, [Text], InterfaceSignature))]
forall a. IntMap a -> [(Int, a)]
IntMap.assocs InterfaceBinds
input) \(Int
location, (Maybe Text, [Text], InterfaceSignature)
requested) ->
case Int
-> InterfaceBinds -> Maybe (Maybe Text, [Text], InterfaceSignature)
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 InterfaceSignature -> InterfaceSignature -> Bool
forall a. Eq a => a -> a -> Bool
== InterfaceSignature
pSignature then
let
names :: Either (Maybe Text, Maybe Text) (Maybe Text)
names =
if Maybe Text
rName Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
pName then
Maybe Text -> Either (Maybe Text, Maybe Text) (Maybe Text)
forall a b. b -> Either a b
Right Maybe Text
rName
else
(Maybe Text, Maybe Text)
-> Either (Maybe Text, Maybe Text) (Maybe Text)
forall a b. a -> Either a b
Left (Maybe Text
rName, Maybe Text
pName)
in
(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))
-> Either
(IncompatibleInterfaces label)
(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))
forall a b. b -> Either a b
Right (Int
location, ([Text]
rFlags, Either (Maybe Text, Maybe Text) (Maybe Text)
names))
else
IncompatibleInterfaces label
-> Either
(IncompatibleInterfaces label)
(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))
forall a b. a -> Either a b
Left
( label
inputLabel
, label
outputLabel
, Int
location
, (InterfaceSignature, InterfaceSignature)
-> Maybe (InterfaceSignature, InterfaceSignature)
forall a. a -> Maybe a
Just (InterfaceSignature
rSignature, InterfaceSignature
pSignature)
)
Maybe (Maybe Text, [Text], InterfaceSignature)
Nothing ->
IncompatibleInterfaces label
-> Either
(IncompatibleInterfaces label)
(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))
forall a b. a -> Either a b
Left
( label
inputLabel
, label
outputLabel
, Int
location
, Maybe (InterfaceSignature, InterfaceSignature)
forall a. Maybe a
Nothing
)
CompatibleInterfaces label
-> Either
(IncompatibleInterfaces label) (CompatibleInterfaces label)
forall a b. b -> Either a b
Right
( label
outputLabel
, label
inputLabel
, [(Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))]
-> IntMap ([Text], Either (Maybe Text, Maybe Text) (Maybe Text))
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 = [(label, InterfaceBinds)]
-> [(label, InterfaceBinds)]
-> [((label, InterfaceBinds), (label, InterfaceBinds))]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [(label, InterfaceBinds)] -> [(label, InterfaceBinds)]
forall a. Int -> [a] -> [a]
drop Int
1 [(label, InterfaceBinds)]
ins) [(label, InterfaceBinds)]
outs
([(label, InterfaceBinds)]
ins, [(label, InterfaceBinds)]
outs) =
[((label, InterfaceBinds), (label, InterfaceBinds))]
-> ([(label, InterfaceBinds)], [(label, InterfaceBinds)])
forall a b. [(a, b)] -> ([a], [b])
List.unzip do
(label
label, Just (InterfaceBinds, InterfaceBinds)
binds) <- stages (label, Maybe (InterfaceBinds, InterfaceBinds))
-> [(label, Maybe (InterfaceBinds, InterfaceBinds))]
forall a. stages a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (stages (label, Maybe (InterfaceBinds, InterfaceBinds))
-> [(label, Maybe (InterfaceBinds, InterfaceBinds))])
-> stages (label, Maybe (InterfaceBinds, InterfaceBinds))
-> [(label, Maybe (InterfaceBinds, InterfaceBinds))]
forall a b. (a -> b) -> a -> b
$ StageInterface stages
-> stages (label, Maybe (InterfaceBinds, InterfaceBinds))
forall {f :: * -> *} {a} {a}.
(StageInfo f, IsString a) =>
f a -> f (a, a)
withLabels StageInterface stages
staged
((label, InterfaceBinds), (label, InterfaceBinds))
-> [((label, InterfaceBinds), (label, InterfaceBinds))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (label
label, (InterfaceBinds, InterfaceBinds) -> InterfaceBinds
forall a b. (a, b) -> a
fst (InterfaceBinds, InterfaceBinds)
binds)
, (label
label, (InterfaceBinds, InterfaceBinds) -> InterfaceBinds
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 = [(label, InterfaceBinds)] -> Maybe (label, InterfaceBinds)
forall a. [a] -> Maybe a
listToMaybe [(label, InterfaceBinds)]
active
where
active :: [(label, InterfaceBinds)]
active = do
(label
label, Just (InterfaceBinds, InterfaceBinds)
binds) <- stages (label, Maybe (InterfaceBinds, InterfaceBinds))
-> [(label, Maybe (InterfaceBinds, InterfaceBinds))]
forall a. stages a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (stages (label, Maybe (InterfaceBinds, InterfaceBinds))
-> [(label, Maybe (InterfaceBinds, InterfaceBinds))])
-> stages (label, Maybe (InterfaceBinds, InterfaceBinds))
-> [(label, Maybe (InterfaceBinds, InterfaceBinds))]
forall a b. (a -> b) -> a -> b
$ StageInterface stages
-> stages (label, Maybe (InterfaceBinds, InterfaceBinds))
forall {f :: * -> *} {a} {a}.
(StageInfo f, IsString a) =>
f a -> f (a, a)
withLabels StageInterface stages
staged
(label, InterfaceBinds) -> [(label, InterfaceBinds)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (label
label, (InterfaceBinds, InterfaceBinds) -> InterfaceBinds
forall a b. (a, b) -> a
fst (InterfaceBinds, InterfaceBinds)
binds)