{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Vulkan.Utils.Requirements
(
checkInstanceRequirements
,
checkDeviceRequirements
,
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(..) )
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 :: 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)
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
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 :: 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
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
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
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) #-}
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
)
-> DeviceRequirement
-> RequirementResult
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
data RequirementResult
= Satisfied
| UnattemptedProperties ByteString
| UnattemptedFeatures ByteString
| MissingLayer ByteString
| UnsatisfiedDeviceVersion (Unsatisfied Word32)
| UnsatisfiedInstanceVersion (Unsatisfied Word32)
| UnsatisfiedLayerVersion ByteString (Unsatisfied Word32)
| UnsatisfiedFeature ByteString
| UnsatisfiedProperty ByteString
| UnsatisfiedDeviceExtension ByteString
| UnsatisfiedDeviceExtensionVersion ByteString (Unsatisfied Word32)
| UnsatisfiedInstanceExtension ByteString
| UnsatisfiedInstanceExtensionVersion ByteString (Unsatisfied Word32)
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
, forall a. Unsatisfied a -> a
unsatisfiedActual :: a
}
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)
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
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
class (PeekChain xs, PokeChain xs) => KnownChain (xs :: [Type]) where
has :: forall a. Typeable a => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs))
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)
getLookupExtension
:: MonadIO m
=> Vector LayerProperties
-> Maybe PhysicalDevice
-> ["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
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
[] -> ChainCont DevicePropertyChain a
f (forall {k} (t :: k). Proxy t
Proxy @fs)
(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
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
[] -> ChainCont DeviceFeatureChain a
f (forall {k} (t :: k). Proxy t
Proxy @fs)
(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
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
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
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
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)