{-# 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 (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
  }

-- | @layout(set=X, binding=Y) ...@
type BindMap a = IntMap (IntMap a)

type StageInterface stages = stages (Maybe (InterfaceBinds, InterfaceBinds))

-- | @layout(location=N)
type InterfaceBinds = IntMap InterfaceBinding

deriving instance (Eq (StageInterface stages)) => Eq (Reflect stages)
deriving instance (Show (StageInterface stages)) => Show (Reflect stages)

-- * Block variables

-- | @uniform Foo { ... } foo;@
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
/= :: BlockSignature -> BlockSignature -> Bool
$c/= :: BlockSignature -> BlockSignature -> Bool
== :: BlockSignature -> BlockSignature -> Bool
$c== :: 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
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
(Int -> BlockSignature -> ShowS)
-> (BlockSignature -> FilePath)
-> ([BlockSignature] -> ShowS)
-> Show BlockSignature
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 = (([Text], BindMap BlockBinding) -> BindMap BlockBinding)
-> m ([Text], BindMap BlockBinding) -> m (BindMap BlockBinding)
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 (t :: * -> *) label.
(StageInfo t, IsString label) =>
t label
stageNames
      f (a -> (a, a)) -> f a -> f (a, a)
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 (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, BlockSignature) -> BlockSignature)
-> Tree (a, BlockSignature) -> Tree BlockSignature
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, BlockSignature) -> BlockSignature)
-> Tree (a, BlockSignature) -> Tree BlockSignature
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 (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
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
"|" ([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 (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 (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
$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
        (Int, BlockBinding) -> [(Int, BlockBinding)]
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 (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 :: Word32 -> Word32 -> TypeFlags -> Maybe Scalar -> BlockSignature
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, Maybe Scalar
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
                  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 (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)
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)
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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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)

-- * Interface variables

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
/= :: InterfaceSignature -> InterfaceSignature -> Bool
$c/= :: InterfaceSignature -> InterfaceSignature -> Bool
== :: InterfaceSignature -> InterfaceSignature -> Bool
$c== :: 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
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
(Int -> InterfaceSignature -> ShowS)
-> (InterfaceSignature -> FilePath)
-> ([InterfaceSignature] -> ShowS)
-> Show InterfaceSignature
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 = (Maybe Module -> m (Maybe (InterfaceBinds, InterfaceBinds)))
-> stages (Maybe Module)
-> m (stages (Maybe (InterfaceBinds, InterfaceBinds)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Maybe Module -> m (Maybe (InterfaceBinds, InterfaceBinds)))
 -> stages (Maybe Module)
 -> m (stages (Maybe (InterfaceBinds, InterfaceBinds))))
-> (Maybe Module -> m (Maybe (InterfaceBinds, InterfaceBinds)))
-> stages (Maybe Module)
-> m (stages (Maybe (InterfaceBinds, InterfaceBinds)))
forall a b. (a -> b) -> a -> b
$ (Module -> m (InterfaceBinds, InterfaceBinds))
-> Maybe Module -> m (Maybe (InterfaceBinds, InterfaceBinds))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((InterfaceBinds, InterfaceBinds)
-> m (InterfaceBinds, InterfaceBinds)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((InterfaceBinds, InterfaceBinds)
 -> m (InterfaceBinds, InterfaceBinds))
-> (Module -> (InterfaceBinds, InterfaceBinds))
-> Module
-> m (InterfaceBinds, InterfaceBinds)
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 = [(Int, (Maybe Text, [Text], InterfaceSignature))] -> InterfaceBinds
forall a. [(Int, a)] -> IntMap a
IntMap.fromList do
  var :: InterfaceVariable
var@InterfaceVariable.InterfaceVariable{Word32
$sel:location:InterfaceVariable :: InterfaceVariable -> Word32
location :: Word32
location} <- Vector InterfaceVariable -> [InterfaceVariable]
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

  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
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
      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 :: Format -> TypeFlags -> Maybe Matrix -> InterfaceSignature
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
      }

  (Int, (Maybe Text, [Text], InterfaceSignature))
-> [(Int, (Maybe Text, [Text], InterfaceSignature))]
forall (f :: * -> *) a. Applicative f => a -> f a
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
         (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
         (label, label,
          IntMap ([Text], Either (Maybe Text, Maybe Text) (Maybe Text))))
-> Either
     (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
     [(label, label,
       IntMap ([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 [((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
         (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
         (Int, ([Text], Either (Maybe Text, Maybe Text) (Maybe Text))))
-> Either
     (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
     [(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
     (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
     (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
            (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
-> Either
     (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
     (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 ->
          (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
-> Either
     (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
     (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
            )
    (label, label,
 IntMap ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))
-> Either
     (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature))
     (label, label,
      IntMap ([Text], Either (Maybe Text, Maybe Text) (Maybe Text)))
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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (label
label, (InterfaceBinds, InterfaceBinds) -> InterfaceBinds
forall a b. (a, b) -> a
fst (InterfaceBinds, InterfaceBinds)
binds)