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

-- | @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
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)

-- * 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
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
  :: ( Traversable stages
     )
  => stages (Maybe Module)
  -> StageInterface stages
stagesInterfaceMap :: forall (stages :: * -> *).
Traversable stages =>
stages (Maybe Module) -> StageInterface stages
stagesInterfaceMap = 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 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

  -- XXX: Remove vars like @gl_FragCoord@/@SV_Position@ from potential signatures.
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ InterfaceVariable -> BuiltIn
InterfaceVariable.built_in InterfaceVariable
var forall a. Eq a => a -> a -> Bool
== 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 = 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
      }

  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)