{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module Vulkan.Utils.Requirements
  ( -- * Instance requirements
    checkInstanceRequirements
  , -- * Device requirements
    checkDeviceRequirements
  , -- * Results
    RequirementResult(..)
  , Unsatisfied(..)
  , requirementReport
  , prettyRequirementResult
  ) where

import           Control.Arrow                  ( Arrow((***)) )
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.State
import           Data.Bifunctor
import           Data.ByteString                ( ByteString )
import qualified Data.Dependent.Map            as DMap
import           Data.Dependent.Map             ( DMap )
import           Data.Dependent.Sum             ( DSum((:=>)) )
import           Data.Foldable
import           Data.Functor.Product           ( Product(..) )
import qualified Data.HashMap.Strict           as Map
import           Data.Kind                      ( Type )
import           Data.List                      ( intercalate, intersect )
import           Data.List.Extra                ( nubOrd )
import           Data.Proxy
import           Data.Semigroup                 ( Endo(..) )
import           Data.Traversable
import           Data.Typeable                  ( eqT )
import qualified Data.Vector                   as V
import           Data.Vector                    ( Vector )
import           Data.Word
import           Foreign.Ptr                    ( FunPtr
                                                , Ptr
                                                , nullFunPtr
                                                )
import           GHC.Base                       ( Proxy# )
import           GHC.Exts                       ( proxy# )
import           Type.Reflection
import           Vulkan.CStruct                 ( FromCStruct
                                                , ToCStruct
                                                )
import           Vulkan.CStruct.Extends
import           Vulkan.Core10
import qualified Vulkan.Core10                as Device
                                                ( DeviceCreateInfo(..) )
import qualified Vulkan.Core10                as Extension
                                                ( ExtensionProperties(..) )
import qualified Vulkan.Core10                as Instance
                                                ( InstanceCreateInfo(..) )
import qualified Vulkan.Core10                as PhysicalDevice
                                                ( PhysicalDeviceProperties(..)
                                                , PhysicalDevice(instanceCmds) )
import           Vulkan.Core11.DeviceInitialization
import           Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2
import qualified Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2
                                              as PhysicalDevice
                                                ( PhysicalDeviceProperties2(..)
                                                , features )
import           Vulkan.Dynamic                 ( InstanceCmds
                                                  ( pVkGetPhysicalDeviceFeatures2
                                                  , pVkGetPhysicalDeviceProperties2
                                                  )
                                                )
import           Vulkan.NamedType
import           Vulkan.Requirement
import           Vulkan.Version
import           Vulkan.Zero                    ( Zero(..) )

----------------------------------------------------------------
-- * Instance Creation
----------------------------------------------------------------

checkInstanceRequirements
  :: forall m o r es
   . (MonadIO m, Traversable r, Traversable o)
  => r InstanceRequirement
  -- ^ Required requests
  -> o InstanceRequirement
  -- ^ Optional requests
  -> InstanceCreateInfo es
  -- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by
  -- the requirements
  -> m
       ( Maybe (InstanceCreateInfo es)
       , r RequirementResult
       , o RequirementResult
       )
checkInstanceRequirements :: forall (m :: * -> *) (o :: * -> *) (r :: * -> *) (es :: [*]).
(MonadIO m, Traversable r, Traversable o) =>
r InstanceRequirement
-> o InstanceRequirement
-> InstanceCreateInfo es
-> m (Maybe (InstanceCreateInfo es), r RequirementResult,
      o RequirementResult)
checkInstanceRequirements r InstanceRequirement
required o InstanceRequirement
optional InstanceCreateInfo es
baseCreateInfo = do
  let requiredList :: [InstanceRequirement]
requiredList = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList r InstanceRequirement
required
      allAsList :: [InstanceRequirement]
allAsList    = [InstanceRequirement]
requiredList forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o InstanceRequirement
optional
  Word32
foundVersion    <- forall (io :: * -> *). MonadIO io => io Word32
enumerateInstanceVersion
  (Result
_, "properties" ::: Vector LayerProperties
layerProps) <- forall (io :: * -> *).
MonadIO io =>
io (Result, "properties" ::: Vector LayerProperties)
enumerateInstanceLayerProperties
  ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension <- forall (m :: * -> *).
MonadIO m =>
("properties" ::: Vector LayerProperties)
-> Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension
    "properties" ::: Vector LayerProperties
layerProps
    forall a. Maybe a
Nothing
    [ "layerName" ::: Maybe ByteString
instanceExtensionLayerName
    | RequireInstanceExtension { "layerName" ::: Maybe ByteString
$sel:instanceExtensionLayerName:RequireInstanceVersion :: InstanceRequirement -> "layerName" ::: Maybe ByteString
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
instanceExtensionLayerName } <- [InstanceRequirement]
allAsList
    ]

  (r RequirementResult
r, Bool
continue) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
True forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for r InstanceRequirement
required forall a b. (a -> b) -> a -> b
$ \InstanceRequirement
r ->
    case Word32
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension InstanceRequirement
r of
      RequirementResult
res -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RequirementResult
res forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) (forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
False)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

  (o RequirementResult
o, [InstanceRequirement]
goodOptions) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for o InstanceRequirement
optional forall a b. (a -> b) -> a -> b
$ \InstanceRequirement
o ->
    case Word32
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension InstanceRequirement
o of
      RequirementResult
res -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RequirementResult
res forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (InstanceRequirement
o forall a. a -> [a] -> [a]
:)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

  let ici :: Maybe (InstanceCreateInfo es)
ici = do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
continue
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (es :: [*]).
[InstanceRequirement]
-> InstanceCreateInfo es -> InstanceCreateInfo es
makeInstanceCreateInfo ([InstanceRequirement]
requiredList forall a. Semigroup a => a -> a -> a
<> [InstanceRequirement]
goodOptions)
                                      InstanceCreateInfo es
baseCreateInfo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (InstanceCreateInfo es)
ici, r RequirementResult
r, o RequirementResult
o)

-- | Insert the settings of the requirements in to the provided instance create
-- info
makeInstanceCreateInfo
  :: forall es
   . [InstanceRequirement]
  -> InstanceCreateInfo es
  -> InstanceCreateInfo es
makeInstanceCreateInfo :: forall (es :: [*]).
[InstanceRequirement]
-> InstanceCreateInfo es -> InstanceCreateInfo es
makeInstanceCreateInfo [InstanceRequirement]
reqs InstanceCreateInfo es
baseCreateInfo =
  let
    layers :: [ByteString]
layers = [ ByteString
instanceLayerName | RequireInstanceLayer {Word32
ByteString
$sel:instanceLayerName:RequireInstanceVersion :: InstanceRequirement -> ByteString
$sel:instanceLayerMinVersion:RequireInstanceVersion :: InstanceRequirement -> Word32
instanceLayerMinVersion :: Word32
instanceLayerName :: ByteString
..} <- [InstanceRequirement]
reqs ]
    extensions :: [ByteString]
extensions =
      [ ByteString
instanceExtensionName | RequireInstanceExtension {"layerName" ::: Maybe ByteString
Word32
ByteString
$sel:instanceExtensionName:RequireInstanceVersion :: InstanceRequirement -> ByteString
$sel:instanceExtensionMinVersion:RequireInstanceVersion :: InstanceRequirement -> Word32
instanceExtensionMinVersion :: Word32
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
instanceExtensionName :: ByteString
$sel:instanceExtensionLayerName:RequireInstanceVersion :: InstanceRequirement -> "layerName" ::: Maybe ByteString
..} <- [InstanceRequirement]
reqs ]
  in
    InstanceCreateInfo es
baseCreateInfo
      { $sel:enabledLayerNames:InstanceCreateInfo :: Vector ByteString
Instance.enabledLayerNames     =
        forall (es :: [*]). InstanceCreateInfo es -> Vector ByteString
Instance.enabledLayerNames InstanceCreateInfo es
baseCreateInfo
          forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Vector a
V.fromList [ByteString]
layers
      , $sel:enabledExtensionNames:InstanceCreateInfo :: Vector ByteString
Instance.enabledExtensionNames =
        forall (es :: [*]). InstanceCreateInfo es -> Vector ByteString
Instance.enabledExtensionNames InstanceCreateInfo es
baseCreateInfo
          forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Vector a
V.fromList [ByteString]
extensions
      }

checkInstanceRequest
  :: ("apiVersion" ::: Word32)
  -> ("properties" ::: Vector LayerProperties)
  -> (  ("layerName" ::: Maybe ByteString)
     -> ByteString
     -> Maybe ExtensionProperties
     )
  -> InstanceRequirement
  -> RequirementResult
checkInstanceRequest :: Word32
-> ("properties" ::: Vector LayerProperties)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> InstanceRequirement
-> RequirementResult
checkInstanceRequest Word32
foundVersion "properties" ::: Vector LayerProperties
layerProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension = \case
  RequireInstanceVersion Word32
minVersion -> if Word32
foundVersion forall a. Ord a => a -> a -> Bool
>= Word32
minVersion
    then RequirementResult
Satisfied
    else Unsatisfied Word32 -> RequirementResult
UnsatisfiedInstanceVersion (forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
minVersion Word32
foundVersion)

  RequireInstanceLayer { ByteString
instanceLayerName :: ByteString
$sel:instanceLayerName:RequireInstanceVersion :: InstanceRequirement -> ByteString
instanceLayerName, Word32
instanceLayerMinVersion :: Word32
$sel:instanceLayerMinVersion:RequireInstanceVersion :: InstanceRequirement -> Word32
instanceLayerMinVersion }
    | Just LayerProperties
props <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== ByteString
instanceLayerName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayerProperties -> ByteString
layerName) "properties" ::: Vector LayerProperties
layerProps
    , Word32
foundLayerVersion <- LayerProperties -> Word32
implementationVersion LayerProperties
props
    -> if Word32
foundVersion forall a. Ord a => a -> a -> Bool
>= Word32
instanceLayerMinVersion
      then RequirementResult
Satisfied
      else ByteString -> Unsatisfied Word32 -> RequirementResult
UnsatisfiedLayerVersion
        ByteString
instanceLayerName
        (forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
instanceLayerMinVersion Word32
foundLayerVersion)
    | Bool
otherwise
    -> ByteString -> RequirementResult
MissingLayer ByteString
instanceLayerName

  RequireInstanceExtension { "layerName" ::: Maybe ByteString
instanceExtensionLayerName :: "layerName" ::: Maybe ByteString
$sel:instanceExtensionLayerName:RequireInstanceVersion :: InstanceRequirement -> "layerName" ::: Maybe ByteString
instanceExtensionLayerName, ByteString
instanceExtensionName :: ByteString
$sel:instanceExtensionName:RequireInstanceVersion :: InstanceRequirement -> ByteString
instanceExtensionName, Word32
instanceExtensionMinVersion :: Word32
$sel:instanceExtensionMinVersion:RequireInstanceVersion :: InstanceRequirement -> Word32
instanceExtensionMinVersion }
    | Just ExtensionProperties
eProps <- ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension "layerName" ::: Maybe ByteString
instanceExtensionLayerName
                                     ByteString
instanceExtensionName
    -> let foundInstanceExtensionVersion :: Word32
foundInstanceExtensionVersion =
             ExtensionProperties -> Word32
Extension.specVersion ExtensionProperties
eProps
       in  if Word32
foundInstanceExtensionVersion forall a. Ord a => a -> a -> Bool
>= Word32
instanceExtensionMinVersion
             then RequirementResult
Satisfied
             else ByteString -> Unsatisfied Word32 -> RequirementResult
UnsatisfiedInstanceExtensionVersion
               ByteString
instanceExtensionName
               (forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
instanceExtensionMinVersion
                            Word32
foundInstanceExtensionVersion
               )
    | Bool
otherwise
    -> ByteString -> RequirementResult
UnsatisfiedInstanceExtension ByteString
instanceExtensionName

----------------------------------------------------------------
-- Device
----------------------------------------------------------------

checkDeviceRequirements
  :: forall m o r
   . (MonadIO m, Traversable r, Traversable o)
  => r DeviceRequirement
  -- ^ Required requests
  -> o DeviceRequirement
  -- ^ Optional requests
  -> PhysicalDevice
  -> DeviceCreateInfo '[]
  -- ^ A deviceCreateInfo with no extensions. If you need elements in the
  -- struct chain you can add them later with
  -- 'Vulkan.CStruct.Extends.extendSomeStruct'
  -> m
       ( Maybe (SomeStruct DeviceCreateInfo)
       , r RequirementResult
       , o RequirementResult
       )
checkDeviceRequirements :: forall (m :: * -> *) (o :: * -> *) (r :: * -> *).
(MonadIO m, Traversable r, Traversable o) =>
r DeviceRequirement
-> o DeviceRequirement
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
      o RequirementResult)
checkDeviceRequirements r DeviceRequirement
required o DeviceRequirement
optional PhysicalDevice
phys DeviceCreateInfo '[]
baseCreateInfo = do
  let requiredList :: [DeviceRequirement]
requiredList = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList r DeviceRequirement
required
      allAsList :: [DeviceRequirement]
allAsList    = [DeviceRequirement]
requiredList forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList o DeviceRequirement
optional

  --
  -- First collect the types and properties that we'll need to query using
  -- getPhysicalDeviceProperties2 and getPhysicalDeviceFeatures2
  --
  forall a.
[DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs [DeviceRequirement]
allAsList forall a b. (a -> b) -> a -> b
$ \(Proxy es
_ :: Proxy fs) ->
    forall a.
[DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs [DeviceRequirement]
allAsList forall a b. (a -> b) -> a -> b
$ \(Proxy es
_ :: Proxy ps) -> do
      --
      -- Fetch everything
      --
      Maybe (PhysicalDeviceFeatures2 es)
feats           <- forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe @fs PhysicalDevice
phys
      Maybe (PhysicalDeviceProperties2 es)
props           <- forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs,
 Extendss PhysicalDeviceProperties2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe @ps PhysicalDevice
phys
      (Result
_, "properties" ::: Vector LayerProperties
layerProps) <- forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> io (Result, "properties" ::: Vector LayerProperties)
enumerateDeviceLayerProperties PhysicalDevice
phys
      ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension <- forall (m :: * -> *).
MonadIO m =>
("properties" ::: Vector LayerProperties)
-> Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension
        "properties" ::: Vector LayerProperties
layerProps
        (forall a. a -> Maybe a
Just PhysicalDevice
phys)
        [ "layerName" ::: Maybe ByteString
deviceExtensionLayerName
        | RequireDeviceExtension { "layerName" ::: Maybe ByteString
$sel:deviceExtensionLayerName:RequireDeviceVersion :: DeviceRequirement -> "layerName" ::: Maybe ByteString
deviceExtensionLayerName :: "layerName" ::: Maybe ByteString
deviceExtensionLayerName } <- [DeviceRequirement]
allAsList
        ]

      (r RequirementResult
r, Bool
continue) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
True forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for r DeviceRequirement
required forall a b. (a -> b) -> a -> b
$ \DeviceRequirement
r ->
        case forall (fs :: [*]) (ps :: [*]).
(KnownChain fs, KnownChain ps) =>
Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest Maybe (PhysicalDeviceFeatures2 es)
feats Maybe (PhysicalDeviceProperties2 es)
props ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension DeviceRequirement
r of
          RequirementResult
res -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RequirementResult
res forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) (forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Bool
False)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

      (o RequirementResult
o, [DeviceRequirement]
goodOptions) <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for o DeviceRequirement
optional forall a b. (a -> b) -> a -> b
$ \DeviceRequirement
o ->
        case forall (fs :: [*]) (ps :: [*]).
(KnownChain fs, KnownChain ps) =>
Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest Maybe (PhysicalDeviceFeatures2 es)
feats Maybe (PhysicalDeviceProperties2 es)
props ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension DeviceRequirement
o of
          RequirementResult
res -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RequirementResult
res forall a. Eq a => a -> a -> Bool
== RequirementResult
Satisfied) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (DeviceRequirement
o forall a. a -> [a] -> [a]
:)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure RequirementResult
res

      --
      -- Now create the types for just the available features
      --
      let dci :: Maybe (SomeStruct DeviceCreateInfo)
dci = do
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
continue
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [DeviceRequirement]
-> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo ([DeviceRequirement]
requiredList forall a. Semigroup a => a -> a -> a
<> [DeviceRequirement]
goodOptions)
                                        DeviceCreateInfo '[]
baseCreateInfo
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (SomeStruct DeviceCreateInfo)
dci, r RequirementResult
r, o RequirementResult
o)

{-# ANN makeDeviceCreateInfo ("HLint: ignore Move guards forward" :: String) #-}
-- | Generate 'DeviceCreateInfo' from some requirements.
--
-- The returned struct chain will enable all required features and extensions.
makeDeviceCreateInfo
  :: [DeviceRequirement] -> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo :: [DeviceRequirement]
-> DeviceCreateInfo '[] -> SomeStruct DeviceCreateInfo
makeDeviceCreateInfo [DeviceRequirement]
allReqs DeviceCreateInfo '[]
baseCreateInfo =
  let
    featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
    featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
featureSetters = forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> [DSum k2 f] -> DMap k2 f
DMap.fromListWithKey
      (\TypeRep v
_ Product (Has KnownFeatureStruct) Endo v
l Product (Has KnownFeatureStruct) Endo v
r -> forall {k} (f :: k -> *) (a :: k) (g :: k -> *).
(Semigroup (f a), Semigroup (g a)) =>
Product f g a -> Product f g a -> Product f g a
catProducts Product (Has KnownFeatureStruct) Endo v
l Product (Has KnownFeatureStruct) Endo v
r)
      [ forall {k} (a :: k). Typeable a => TypeRep a
typeRep forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair forall {k} (c :: k -> Constraint) (a :: k). c a => Has c a
Has (forall a. (a -> a) -> Endo a
Endo struct -> struct
enableFeature)
      | RequireDeviceFeature { struct -> struct
$sel:enableFeature:RequireDeviceVersion :: ()
enableFeature :: struct -> struct
enableFeature } <- [DeviceRequirement]
allReqs
      ]

    makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]
    makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]
makeZeroFeatureExts =
      [ forall a. (a -> a) -> Endo a
Endo (forall (a :: [*] -> *) e.
(Extensible a, Extends a e, ToCStruct e, Show e) =>
e -> SomeStruct a -> SomeStruct a
extendSomeStruct a
s)
      | TypeRep a
_ :=> Pair Has KnownFeatureStruct a
Has (Endo a
f :: Endo s) <- forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toList DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
featureSetters
      , SFeatureStruct a
ExtendedFeatureStruct        <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall feat. KnownFeatureStruct feat => SFeatureStruct feat
sFeatureStruct @s
      , let s :: a
s = forall a. Endo a -> a -> a
appEndo Endo a
f forall a. Zero a => a
zero
      ]

    addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)
    addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)
addBasicFeatures =
      case forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @PhysicalDeviceFeatures) DMap TypeRep (Product (Has KnownFeatureStruct) Endo)
featureSetters of
        Maybe
  (Product (Has KnownFeatureStruct) Endo PhysicalDeviceFeatures)
Nothing         -> forall a. Monoid a => a
mempty
        Just (Pair Has KnownFeatureStruct PhysicalDeviceFeatures
_ Endo PhysicalDeviceFeatures
s) -> forall a. (a -> a) -> Endo a
Endo
          (forall (a :: [*] -> *) e.
(Extensible a, Extends a e, ToCStruct e, Show e) =>
e -> SomeStruct a -> SomeStruct a
extendSomeStruct
            ((forall a. Zero a => a
zero :: PhysicalDeviceFeatures2 '[]) { $sel:features:PhysicalDeviceFeatures2 :: PhysicalDeviceFeatures
features = forall a. Endo a -> a -> a
appEndo Endo PhysicalDeviceFeatures
s forall a. Zero a => a
zero }
            )
          )

    extensionNames :: [ByteString]
    extensionNames :: [ByteString]
extensionNames =
      [ ByteString
deviceExtensionName
      | RequireDeviceExtension { ByteString
$sel:deviceExtensionName:RequireDeviceVersion :: DeviceRequirement -> ByteString
deviceExtensionName :: ByteString
deviceExtensionName } <- [DeviceRequirement]
allReqs
      ]

    newFeatures :: SomeStruct DeviceCreateInfo
    newFeatures :: SomeStruct DeviceCreateInfo
newFeatures = forall a. Endo a -> a -> a
appEndo
      (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Endo (SomeStruct DeviceCreateInfo)
addBasicFeatures forall a. a -> [a] -> [a]
: [Endo (SomeStruct DeviceCreateInfo)]
makeZeroFeatureExts))
      (forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct (DeviceCreateInfo '[]
baseCreateInfo :: DeviceCreateInfo '[])
        { $sel:enabledExtensionNames:DeviceCreateInfo :: Vector ByteString
Device.enabledExtensionNames = forall a. [a] -> Vector a
V.fromList [ByteString]
extensionNames
        }
      )
  in
    SomeStruct DeviceCreateInfo
newFeatures

checkDeviceRequest
  :: forall fs ps
   . (KnownChain fs, KnownChain ps)
  => Maybe (PhysicalDeviceFeatures2 fs)
  -> Maybe (PhysicalDeviceProperties2 ps)
  -> (  ("layerName" ::: Maybe ByteString)
     -> ("extensionName" ::: ByteString)
     -> Maybe ExtensionProperties
     )
  -- ^ Lookup an extension
  -> DeviceRequirement
  -- ^ The requirement to test
  -> RequirementResult
  -- ^ The result
checkDeviceRequest :: forall (fs :: [*]) (ps :: [*]).
(KnownChain fs, KnownChain ps) =>
Maybe (PhysicalDeviceFeatures2 fs)
-> Maybe (PhysicalDeviceProperties2 ps)
-> (("layerName" ::: Maybe ByteString)
    -> ByteString -> Maybe ExtensionProperties)
-> DeviceRequirement
-> RequirementResult
checkDeviceRequest Maybe (PhysicalDeviceFeatures2 fs)
mbFeats Maybe (PhysicalDeviceProperties2 ps)
mbProps ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension = \case
  RequireDeviceVersion Word32
minVersion
    | Just PhysicalDeviceProperties2 ps
props <- Maybe (PhysicalDeviceProperties2 ps)
mbProps
    , Word32
foundVersion <- PhysicalDeviceProperties -> Word32
PhysicalDevice.apiVersion (forall (es :: [*]).
PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
PhysicalDevice.properties PhysicalDeviceProperties2 ps
props)
    -> if Word32
foundVersion forall a. Ord a => a -> a -> Bool
>= Word32
minVersion
      then RequirementResult
Satisfied
      else Unsatisfied Word32 -> RequirementResult
UnsatisfiedDeviceVersion (forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
minVersion Word32
foundVersion)
    | Bool
otherwise
    -> ByteString -> RequirementResult
UnattemptedProperties ByteString
"apiVersion"

  RequireDeviceFeature { ByteString
$sel:featureName:RequireDeviceVersion :: DeviceRequirement -> ByteString
featureName :: ByteString
featureName, struct -> Bool
$sel:checkFeature:RequireDeviceVersion :: ()
checkFeature :: struct -> Bool
checkFeature }
    | Just PhysicalDeviceFeatures2 fs
feats <- Maybe (PhysicalDeviceFeatures2 fs)
mbFeats -> case forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceFeatures2 es -> Maybe s
getFeatureStruct PhysicalDeviceFeatures2 fs
feats of
      Maybe struct
Nothing ->
        forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: didn't find requested feature in struct chain"
      Just struct
s ->
        if struct -> Bool
checkFeature struct
s then RequirementResult
Satisfied else ByteString -> RequirementResult
UnsatisfiedFeature ByteString
featureName
    | Bool
otherwise -> ByteString -> RequirementResult
UnattemptedFeatures ByteString
featureName

  RequireDeviceProperty { ByteString
$sel:propertyName:RequireDeviceVersion :: DeviceRequirement -> ByteString
propertyName :: ByteString
propertyName, struct -> Bool
$sel:checkProperty:RequireDeviceVersion :: ()
checkProperty :: struct -> Bool
checkProperty }
    | Just PhysicalDeviceProperties2 ps
props <- Maybe (PhysicalDeviceProperties2 ps)
mbProps -> case forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceProperties2 es -> Maybe s
getPropertyStruct PhysicalDeviceProperties2 ps
props of
      Maybe struct
Nothing ->
        forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: didn't find requested property in struct chain"
      Just struct
s ->
        if struct -> Bool
checkProperty struct
s then RequirementResult
Satisfied else ByteString -> RequirementResult
UnsatisfiedProperty ByteString
propertyName
    | Bool
otherwise -> ByteString -> RequirementResult
UnattemptedProperties ByteString
propertyName

  RequireDeviceExtension { "layerName" ::: Maybe ByteString
deviceExtensionLayerName :: "layerName" ::: Maybe ByteString
$sel:deviceExtensionLayerName:RequireDeviceVersion :: DeviceRequirement -> "layerName" ::: Maybe ByteString
deviceExtensionLayerName, ByteString
deviceExtensionName :: ByteString
$sel:deviceExtensionName:RequireDeviceVersion :: DeviceRequirement -> ByteString
deviceExtensionName, Word32
$sel:deviceExtensionMinVersion:RequireDeviceVersion :: DeviceRequirement -> Word32
deviceExtensionMinVersion :: Word32
deviceExtensionMinVersion }
    | Just ExtensionProperties
eProps <- ("layerName" ::: Maybe ByteString)
-> ByteString -> Maybe ExtensionProperties
lookupExtension "layerName" ::: Maybe ByteString
deviceExtensionLayerName
                                     ByteString
deviceExtensionName
    -> let foundVersion :: Word32
foundVersion = ExtensionProperties -> Word32
Extension.specVersion ExtensionProperties
eProps
       in  if Word32
foundVersion forall a. Ord a => a -> a -> Bool
>= Word32
deviceExtensionMinVersion
             then RequirementResult
Satisfied
             else ByteString -> Unsatisfied Word32 -> RequirementResult
UnsatisfiedDeviceExtensionVersion
               ByteString
deviceExtensionName
               (forall a. a -> a -> Unsatisfied a
Unsatisfied Word32
deviceExtensionMinVersion Word32
foundVersion)
    | Bool
otherwise
    -> ByteString -> RequirementResult
UnsatisfiedDeviceExtension ByteString
deviceExtensionName


----------------------------------------------------------------
-- Results
----------------------------------------------------------------

-- TODO, better version reporting for extensions
-- TODO, better reporting for properties
data RequirementResult
  = Satisfied
    -- ^ All the requirements were met
  | UnattemptedProperties ByteString
    -- ^ Didn't attempt this check because it required
    -- getPhysicalDeviceProperties2 which wasn't loaded
  | UnattemptedFeatures ByteString
    -- ^ Didn't attempt this check because it required
    -- getPhysicalDeviceFeatures2 which wasn't loaded
  | MissingLayer ByteString
    -- ^ A Layer was not found
  | UnsatisfiedDeviceVersion (Unsatisfied Word32)
    -- ^ A device version didn't meet the minimum requested
  | UnsatisfiedInstanceVersion (Unsatisfied Word32)
    -- ^ The instance version didn't meet the minimum requested
  | UnsatisfiedLayerVersion ByteString (Unsatisfied Word32)
    -- ^ A layer version didn't meet the minimum requested
  | UnsatisfiedFeature ByteString
    -- ^ A feature was missing
  | UnsatisfiedProperty ByteString
    -- ^ A propery was not an appropriate value
  | UnsatisfiedDeviceExtension ByteString
    -- ^ A device extension was missing
  | UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32)
    -- ^ A device extension was found but the version didn't meet requirements
  | UnsatisfiedInstanceExtension ByteString
    -- ^ An instance extension was missing
  | UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32)
    -- ^ An instance extension was found but the version didn't meet requirements
  deriving (RequirementResult -> RequirementResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequirementResult -> RequirementResult -> Bool
$c/= :: RequirementResult -> RequirementResult -> Bool
== :: RequirementResult -> RequirementResult -> Bool
$c== :: RequirementResult -> RequirementResult -> Bool
Eq, Eq RequirementResult
RequirementResult -> RequirementResult -> Bool
RequirementResult -> RequirementResult -> Ordering
RequirementResult -> RequirementResult -> RequirementResult
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 :: RequirementResult -> RequirementResult -> RequirementResult
$cmin :: RequirementResult -> RequirementResult -> RequirementResult
max :: RequirementResult -> RequirementResult -> RequirementResult
$cmax :: RequirementResult -> RequirementResult -> RequirementResult
>= :: RequirementResult -> RequirementResult -> Bool
$c>= :: RequirementResult -> RequirementResult -> Bool
> :: RequirementResult -> RequirementResult -> Bool
$c> :: RequirementResult -> RequirementResult -> Bool
<= :: RequirementResult -> RequirementResult -> Bool
$c<= :: RequirementResult -> RequirementResult -> Bool
< :: RequirementResult -> RequirementResult -> Bool
$c< :: RequirementResult -> RequirementResult -> Bool
compare :: RequirementResult -> RequirementResult -> Ordering
$ccompare :: RequirementResult -> RequirementResult -> Ordering
Ord)

data Unsatisfied a = Unsatisfied
  { forall a. Unsatisfied a -> a
unsatisfiedMinimum :: a
    -- ^ The minimum value to be accepted
  , forall a. Unsatisfied a -> a
unsatisfiedActual  :: a
    -- ^ The value we got, less than 'unsatisfiedMinumum'
  }
  deriving (Unsatisfied a -> Unsatisfied a -> Bool
forall a. Eq a => Unsatisfied a -> Unsatisfied a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unsatisfied a -> Unsatisfied a -> Bool
$c/= :: forall a. Eq a => Unsatisfied a -> Unsatisfied a -> Bool
== :: Unsatisfied a -> Unsatisfied a -> Bool
$c== :: forall a. Eq a => Unsatisfied a -> Unsatisfied a -> Bool
Eq, Unsatisfied a -> Unsatisfied a -> Bool
Unsatisfied a -> Unsatisfied a -> Ordering
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
forall {a}. Ord a => Eq (Unsatisfied a)
forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Ordering
forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
min :: Unsatisfied a -> Unsatisfied a -> Unsatisfied a
$cmin :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
max :: Unsatisfied a -> Unsatisfied a -> Unsatisfied a
$cmax :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Unsatisfied a
>= :: Unsatisfied a -> Unsatisfied a -> Bool
$c>= :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
> :: Unsatisfied a -> Unsatisfied a -> Bool
$c> :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
<= :: Unsatisfied a -> Unsatisfied a -> Bool
$c<= :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
< :: Unsatisfied a -> Unsatisfied a -> Bool
$c< :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Bool
compare :: Unsatisfied a -> Unsatisfied a -> Ordering
$ccompare :: forall a. Ord a => Unsatisfied a -> Unsatisfied a -> Ordering
Ord)

-- | Generate a string describing which requirements were not met, if
-- everything was satisfied return 'Nothing'.
requirementReport
  :: (Foldable r, Foldable o)
  => r RequirementResult
  -> o RequirementResult
  -> Maybe String
requirementReport :: forall (r :: * -> *) (o :: * -> *).
(Foldable r, Foldable o) =>
r RequirementResult -> o RequirementResult -> Maybe [Char]
requirementReport r RequirementResult
required o RequirementResult
optional =
  let pList :: t RequirementResult -> [[Char]]
pList t RequirementResult
xs =
        forall a. Ord a => [a] -> [a]
nubOrd [ RequirementResult -> [Char]
prettyRequirementResult RequirementResult
r | RequirementResult
r <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t RequirementResult
xs, RequirementResult
r forall a. Eq a => a -> a -> Bool
/= RequirementResult
Satisfied ]
      reqStrings :: [[Char]]
reqStrings = forall {t :: * -> *}. Foldable t => t RequirementResult -> [[Char]]
pList r RequirementResult
required
      optStrings :: [[Char]]
optStrings = forall {t :: * -> *}. Foldable t => t RequirementResult -> [[Char]]
pList o RequirementResult
optional
      withHeader :: a -> [a] -> [a]
withHeader a
s = \case
        [] -> []
        [a]
xs -> (a
s forall a. Semigroup a => a -> a -> a
<> a
" requirements not met:") forall a. a -> [a] -> [a]
: ((a
"  " forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs)
      reportLines :: [[Char]]
reportLines =
        forall {a}. (Semigroup a, IsString a) => a -> [a] -> [a]
withHeader [Char]
"Required" [[Char]]
reqStrings forall a. Semigroup a => a -> a -> a
<> forall {a}. (Semigroup a, IsString a) => a -> [a] -> [a]
withHeader [Char]
"Optional" [[Char]]
optStrings
  in  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
reportLines then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
reportLines

prettyRequirementResult :: RequirementResult -> String
prettyRequirementResult :: RequirementResult -> [Char]
prettyRequirementResult = \case
  RequirementResult
Satisfied -> [Char]
"Satisfied"
  UnattemptedProperties ByteString
n ->
    [Char]
"Did not attempt to check "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
      forall a. Semigroup a => a -> a -> a
<> [Char]
" because the 'getPhysicalDeviceProperties' function was not loaded"
  UnattemptedFeatures ByteString
n ->
    [Char]
"Did not attempt to check "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
      forall a. Semigroup a => a -> a -> a
<> [Char]
" because the 'getPhysicalDeviceFeatures' function was not loaded"
  MissingLayer               ByteString
n -> [Char]
"Couldn't find layer: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceVersion Unsatisfied Word32
u -> [Char]
"Unsatisfied Instance version: " forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedDeviceVersion   Unsatisfied Word32
u -> [Char]
"Unsatisfied Device version: " forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedLayerVersion ByteString
n Unsatisfied Word32
u ->
    [Char]
"Unsatisfied layer version for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedFeature  ByteString
n -> [Char]
"Missing feature: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedProperty ByteString
n -> [Char]
"Unsatisfied property: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceExtension ByteString
n ->
    [Char]
"Couldn't find instance extension: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedInstanceExtensionVersion ByteString
n Unsatisfied Word32
u ->
    [Char]
"Unsatisfied Instance extension version " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  UnsatisfiedDeviceExtension ByteString
n -> [Char]
"Couldn't find device extension: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n
  UnsatisfiedDeviceExtensionVersion ByteString
n Unsatisfied Word32
u ->
    [Char]
"Unsatisfied Device extension version " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ByteString
n forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> Unsatisfied Word32 -> [Char]
p Unsatisfied Word32
u
  where p :: Unsatisfied Word32 -> [Char]
p = forall t. (t -> [Char]) -> Unsatisfied t -> [Char]
prettyUnsatisfied Word32 -> [Char]
showVersion

-- How I'm feeling after writing all this type level nonsense
prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String
prettyUnsatisfied :: forall t. (t -> [Char]) -> Unsatisfied t -> [Char]
prettyUnsatisfied t -> [Char]
s Unsatisfied {t
unsatisfiedActual :: t
unsatisfiedMinimum :: t
$sel:unsatisfiedActual:Unsatisfied :: forall a. Unsatisfied a -> a
$sel:unsatisfiedMinimum:Unsatisfied :: forall a. Unsatisfied a -> a
..} =
  [Char]
"Wanted minimum of "
    forall a. Semigroup a => a -> a -> a
<> t -> [Char]
s t
unsatisfiedMinimum
    forall a. Semigroup a => a -> a -> a
<> [Char]
", got: "
    forall a. Semigroup a => a -> a -> a
<> t -> [Char]
s t
unsatisfiedActual

----------------------------------------------------------------
-- Chain lenses
----------------------------------------------------------------

-- | Enough information to focus on any structure within a Vulkan structure chain.
class (PeekChain xs, PokeChain xs) => KnownChain (xs :: [Type]) where
  -- | If the given structure can be found within a chain, return a lens to it.
  -- Otherwise, return 'Nothing'.
  has :: forall a. Typeable a => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs))
  -- | Is this chain empty?
  knownChainNull :: Maybe (xs :~: '[])

instance KnownChain '[] where
  has :: forall a.
Typeable a =>
Proxy# a
-> Maybe (Chain '[] -> a, (a -> a) -> Chain '[] -> Chain '[])
has Proxy# a
_ = forall a. Maybe a
Nothing
  knownChainNull :: Maybe ('[] :~: '[])
knownChainNull = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl

instance (Typeable x, ToCStruct x, FromCStruct x, KnownChain xs) => KnownChain (x ': xs) where
  has :: forall a.
Typeable a =>
Proxy# a
-> Maybe
     (Chain (x : xs) -> a, (a -> a) -> Chain (x : xs) -> Chain (x : xs))
has (Proxy# a
px :: Proxy# a) | Just a :~: x
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @x = forall a. a -> Maybe a
Just (forall a b. (a, b) -> a
fst, forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first)
                       | Bool
otherwise = ((forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (xs :: [*]) a.
(KnownChain xs, Typeable a) =>
Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
has Proxy# a
px
  knownChainNull :: Maybe ((x : xs) :~: '[])
knownChainNull = forall a. Maybe a
Nothing

getPropertyStruct
  :: forall s es
   . (Typeable s, KnownChain es)
  => PhysicalDeviceProperties2 es
  -> Maybe s
getPropertyStruct :: forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceProperties2 es -> Maybe s
getPropertyStruct PhysicalDeviceProperties2 es
c = case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @PhysicalDeviceProperties @s of
  Just PhysicalDeviceProperties :~: s
Refl -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (es :: [*]).
PhysicalDeviceProperties2 es -> PhysicalDeviceProperties
PhysicalDevice.properties PhysicalDeviceProperties2 es
c
  Maybe (PhysicalDeviceProperties :~: s)
Nothing   -> forall s (h :: [*] -> *) (es :: [*]).
(Typeable h, Typeable s, KnownChain es, Extensible h) =>
h es -> Maybe s
getStruct PhysicalDeviceProperties2 es
c

getFeatureStruct
  :: forall s es
   . (Typeable s, KnownChain es)
  => PhysicalDeviceFeatures2 es
  -> Maybe s
getFeatureStruct :: forall s (es :: [*]).
(Typeable s, KnownChain es) =>
PhysicalDeviceFeatures2 es -> Maybe s
getFeatureStruct PhysicalDeviceFeatures2 es
c = case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @PhysicalDeviceFeatures @s of
  Just PhysicalDeviceFeatures :~: s
Refl -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (es :: [*]).
PhysicalDeviceFeatures2 es -> PhysicalDeviceFeatures
PhysicalDevice.features PhysicalDeviceFeatures2 es
c
  Maybe (PhysicalDeviceFeatures :~: s)
Nothing   -> forall s (h :: [*] -> *) (es :: [*]).
(Typeable h, Typeable s, KnownChain es, Extensible h) =>
h es -> Maybe s
getStruct PhysicalDeviceFeatures2 es
c

getStruct
  :: forall s h es
   . (Typeable h, Typeable s, KnownChain es, Extensible h)
  => h es
  -> Maybe s
getStruct :: forall s (h :: [*] -> *) (es :: [*]).
(Typeable h, Typeable s, KnownChain es, Extensible h) =>
h es -> Maybe s
getStruct h es
c = (forall a b. (a -> b) -> a -> b
$ forall (a :: [*] -> *) (es :: [*]).
Extensible a =>
a es -> Chain es
getNext h es
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (xs :: [*]) a.
(KnownChain xs, Typeable a) =>
Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> Chain xs -> Chain xs)
has (forall {k} (a :: k). Proxy# a
proxy# :: Proxy# s)

----------------------------------------------------------------
-- Helpers for 'Device' and 'Instance' extensions
----------------------------------------------------------------

-- | Make a lookup function for extensions in layers. Ignores layers not
-- present in the instance/device
getLookupExtension
  :: MonadIO m
  => Vector LayerProperties
  -> Maybe PhysicalDevice
  -- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for
  -- 'Device' extensions.
  -> ["layerName" ::: Maybe ByteString]
  -> m
       (  ("layerName" ::: Maybe ByteString)
       -> ByteString
       -> Maybe ExtensionProperties
       )
getLookupExtension :: forall (m :: * -> *).
MonadIO m =>
("properties" ::: Vector LayerProperties)
-> Maybe PhysicalDevice
-> ["layerName" ::: Maybe ByteString]
-> m (("layerName" ::: Maybe ByteString)
      -> ByteString -> Maybe ExtensionProperties)
getLookupExtension "properties" ::: Vector LayerProperties
layerProps Maybe PhysicalDevice
mbPhys ["layerName" ::: Maybe ByteString]
extensionLayers = do
  let enumerate :: ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
enumerate = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (io :: * -> *).
MonadIO io =>
("layerName" ::: Maybe ByteString)
-> io (Result, "properties" ::: Vector ExtensionProperties)
enumerateInstanceExtensionProperties
                        forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> io (Result, "properties" ::: Vector ExtensionProperties)
enumerateDeviceExtensionProperties
                        Maybe PhysicalDevice
mbPhys
      availableLayers :: ["layerName" ::: Maybe ByteString]
availableLayers = forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: ((forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayerProperties -> ByteString
layerName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Vector a -> [a]
V.toList "properties" ::: Vector LayerProperties
layerProps)
      searchedLayers :: ["layerName" ::: Maybe ByteString]
searchedLayers = ["layerName" ::: Maybe ByteString]
availableLayers forall a. Eq a => [a] -> [a] -> [a]
`intersect` ["layerName" ::: Maybe ByteString]
extensionLayers
  [("layerName" ::: Maybe ByteString,
  "properties" ::: Vector ExtensionProperties)]
extensions <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ["layerName" ::: Maybe ByteString]
searchedLayers forall a b. (a -> b) -> a -> b
$ \"layerName" ::: Maybe ByteString
layer -> do
    (Result
_, "properties" ::: Vector ExtensionProperties
props) <- ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
enumerate "layerName" ::: Maybe ByteString
layer
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ("layerName" ::: Maybe ByteString
layer, "properties" ::: Vector ExtensionProperties
props)
  let extensionMap :: HashMap
  ("layerName" ::: Maybe ByteString)
  ("properties" ::: Vector ExtensionProperties)
extensionMap = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) [("layerName" ::: Maybe ByteString,
  "properties" ::: Vector ExtensionProperties)]
extensions
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \"layerName" ::: Maybe ByteString
layer ByteString
name -> do
    "properties" ::: Vector ExtensionProperties
es <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup "layerName" ::: Maybe ByteString
layer HashMap
  ("layerName" ::: Maybe ByteString)
  ("properties" ::: Vector ExtensionProperties)
extensionMap
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== ByteString
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtensionProperties -> ByteString
extensionName) "properties" ::: Vector ExtensionProperties
es

----------------------------------------------------------------
-- Helpers for extracting the type of chain used by a set of requirements
----------------------------------------------------------------

withDevicePropertyStructs
  :: forall a . [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs :: forall a.
[DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
withDevicePropertyStructs = forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @'[] []
 where
  go
    :: forall (fs :: [Type])
     . DevicePropertyChain fs
    => [SomeTypeRep]
    -> [DeviceRequirement]
    -> ChainCont DevicePropertyChain a
    -> a
  go :: forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go [SomeTypeRep]
seen [DeviceRequirement]
reqs ChainCont DevicePropertyChain a
f = case [DeviceRequirement]
reqs of
    -- We've been through all the reqs, call the continuation with the types
    [] -> ChainCont DevicePropertyChain a
f (forall {k} (t :: k). Proxy t
Proxy @fs)
    -- This is a device property, add it to the list if we've not seen it before
    (RequireDeviceProperty ByteString
_ (struct -> Bool
_ :: s -> Bool)) : [DeviceRequirement]
rs
      | SPropertyStruct struct
ExtendedPropertyStruct <- forall prop. KnownPropertyStruct prop => SPropertyStruct prop
sPropertyStruct @s
      , SomeTypeRep
sRep <- forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @s)
      , SomeTypeRep
sRep forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [SomeTypeRep]
seen
      -> forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @(s:fs) (SomeTypeRep
sRep forall a. a -> [a] -> [a]
: [SomeTypeRep]
seen) [DeviceRequirement]
rs ChainCont DevicePropertyChain a
f
    -- Otherwise skip
    DeviceRequirement
_ : [DeviceRequirement]
rs -> forall (fs :: [*]).
DevicePropertyChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DevicePropertyChain a -> a
go @fs [SomeTypeRep]
seen [DeviceRequirement]
rs ChainCont DevicePropertyChain a
f

withDeviceFeatureStructs
  :: forall a . [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs :: forall a.
[DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
withDeviceFeatureStructs = forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @'[] []
 where
  go
    :: forall (fs :: [Type])
     . DeviceFeatureChain fs
    => [SomeTypeRep]
    -> [DeviceRequirement]
    -> ChainCont DeviceFeatureChain a
    -> a
  go :: forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go [SomeTypeRep]
seen [DeviceRequirement]
reqs ChainCont DeviceFeatureChain a
f = case [DeviceRequirement]
reqs of
    -- We've been through all the reqs, call the continuation with the types
    [] -> ChainCont DeviceFeatureChain a
f (forall {k} (t :: k). Proxy t
Proxy @fs)
    -- This is a device feature, add it to the list if we've not seen it before
    (RequireDeviceFeature ByteString
_ struct -> Bool
_ (struct -> struct
_ :: s -> s)) : [DeviceRequirement]
rs
      | SFeatureStruct struct
ExtendedFeatureStruct <- forall feat. KnownFeatureStruct feat => SFeatureStruct feat
sFeatureStruct @s
      , SomeTypeRep
sRep <- forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @s)
      , SomeTypeRep
sRep forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [SomeTypeRep]
seen
      -> forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @(s:fs) (SomeTypeRep
sRep forall a. a -> [a] -> [a]
: [SomeTypeRep]
seen) [DeviceRequirement]
rs ChainCont DeviceFeatureChain a
f
    -- Otherwise skip
    DeviceRequirement
_ : [DeviceRequirement]
rs -> forall (fs :: [*]).
DeviceFeatureChain fs =>
[SomeTypeRep]
-> [DeviceRequirement] -> ChainCont DeviceFeatureChain a -> a
go @fs [SomeTypeRep]
seen [DeviceRequirement]
rs ChainCont DeviceFeatureChain a
f

class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where
instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where

class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where
instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where

type ChainCont c a = forall (es :: [Type]) . (c es) => Proxy es -> a

----------------------------------------------------------------
-- Helpers for getting features and properties without using the extended
-- versions of the functions if possible.
----------------------------------------------------------------

getPhysicalDeviceFeaturesMaybe
  :: forall fs m
   . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs)
  => PhysicalDevice
  -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe :: forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceFeatures2 fs))
getPhysicalDeviceFeaturesMaybe = forall (fs :: [*]) s1 (s2 :: [*] -> *) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss s2 fs) =>
(InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe InstanceCmds
-> FunPtr
     (Ptr PhysicalDevice_T
      -> ("pFeatures" ::: Ptr (SomeStruct PhysicalDeviceFeatures2))
      -> IO ())
pVkGetPhysicalDeviceFeatures2
                                          (forall (es :: [*]).
Chain es -> PhysicalDeviceFeatures -> PhysicalDeviceFeatures2 es
PhysicalDeviceFeatures2 ())
                                          forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceFeatures
getPhysicalDeviceFeatures
                                          forall (a :: [*]) (io :: * -> *).
(Extendss PhysicalDeviceFeatures2 a, PokeChain a, PeekChain a,
 MonadIO io) =>
PhysicalDevice -> io (PhysicalDeviceFeatures2 a)
getPhysicalDeviceFeatures2

getPhysicalDevicePropertiesMaybe
  :: forall fs m
   . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceProperties2 fs)
  => PhysicalDevice
  -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe :: forall (fs :: [*]) (m :: * -> *).
(MonadIO m, KnownChain fs,
 Extendss PhysicalDeviceProperties2 fs) =>
PhysicalDevice -> m (Maybe (PhysicalDeviceProperties2 fs))
getPhysicalDevicePropertiesMaybe = forall (fs :: [*]) s1 (s2 :: [*] -> *) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss s2 fs) =>
(InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe InstanceCmds
-> FunPtr
     (Ptr PhysicalDevice_T
      -> ("pProperties" ::: Ptr (SomeStruct PhysicalDeviceProperties2))
      -> IO ())
pVkGetPhysicalDeviceProperties2
                                            (forall (es :: [*]).
Chain es
-> PhysicalDeviceProperties -> PhysicalDeviceProperties2 es
PhysicalDeviceProperties2 ())
                                            forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceProperties
getPhysicalDeviceProperties
                                            forall (a :: [*]) (io :: * -> *).
(Extendss PhysicalDeviceProperties2 a, PokeChain a, PeekChain a,
 MonadIO io) =>
PhysicalDevice -> io (PhysicalDeviceProperties2 a)
getPhysicalDeviceProperties2

getMaybe
  :: forall fs s1 s2 m
   . (MonadIO m, KnownChain fs, Extendss s2 fs)
  => (  InstanceCmds
     -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
     )
  -> (s1 -> s2 '[])
  -> (PhysicalDevice -> m s1)
  -> (PhysicalDevice -> m (s2 fs))
  -> PhysicalDevice
  -> m (Maybe (s2 fs))
getMaybe :: forall (fs :: [*]) s1 (s2 :: [*] -> *) (m :: * -> *).
(MonadIO m, KnownChain fs, Extendss s2 fs) =>
(InstanceCmds
 -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ()))
-> (s1 -> s2 '[])
-> (PhysicalDevice -> m s1)
-> (PhysicalDevice -> m (s2 fs))
-> PhysicalDevice
-> m (Maybe (s2 fs))
getMaybe InstanceCmds
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
funPtr s1 -> s2 '[]
wrapper2 PhysicalDevice -> m s1
get1 PhysicalDevice -> m (s2 fs)
get2 PhysicalDevice
phys =
  let hasFunPtr :: Bool
hasFunPtr = InstanceCmds
-> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())
funPtr (PhysicalDevice -> InstanceCmds
PhysicalDevice.instanceCmds PhysicalDevice
phys) forall a. Eq a => a -> a -> Bool
/= forall a. FunPtr a
nullFunPtr
  in  case forall (xs :: [*]). KnownChain xs => Maybe (xs :~: '[])
knownChainNull @fs of
        Just fs :~: '[]
Refl -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. s1 -> s2 '[]
wrapper2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m s1
get1 PhysicalDevice
phys
        Maybe (fs :~: '[])
Nothing   -> if Bool
hasFunPtr then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m (s2 fs)
get2 PhysicalDevice
phys else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

----------------------------------------------------------------
-- Utils
----------------------------------------------------------------

showVersion :: Word32 -> String
showVersion :: Word32 -> [Char]
showVersion Word32
ver = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." [forall a. Show a => a -> [Char]
show Word32
ma, forall a. Show a => a -> [Char]
show Word32
mi, forall a. Show a => a -> [Char]
show Word32
pa]
  where MAKE_API_VERSION Word32
ma Word32
mi Word32
pa = Word32
ver

data Has c a where
  Has ::c a => Has c a

instance Semigroup (Has c a) where
  Has c a
Has <> :: Has c a -> Has c a -> Has c a
<> Has c a
_ = forall {k} (c :: k -> Constraint) (a :: k). c a => Has c a
Has

-- | There is no Semigroup instance for 'Product' in base
catProducts
  :: (Semigroup (f a), Semigroup (g a))
  => Product f g a
  -> Product f g a
  -> Product f g a
catProducts :: forall {k} (f :: k -> *) (a :: k) (g :: k -> *).
(Semigroup (f a), Semigroup (g a)) =>
Product f g a -> Product f g a -> Product f g a
catProducts (Pair f a
a1 g a
b1) (Pair f a
a2 g a
b2) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (f a
a1 forall a. Semigroup a => a -> a -> a
<> f a
a2) (g a
b1 forall a. Semigroup a => a -> a -> a
<> g a
b2)