{-# LANGUAGE OverloadedLists #-}
module Vulkan.Utils.Initialization
(
createInstanceFromRequirements
, createDebugInstanceFromRequirements
, createDeviceFromRequirements
,
pickPhysicalDevice
, physicalDeviceName
) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
import Data.Foldable
import Data.Maybe
import Data.Ord
import Data.Text ( Text )
import Data.Text.Encoding ( decodeUtf8 )
import Vulkan.CStruct.Extends
import Vulkan.Core10
import qualified Vulkan.Core10 as Instance ( InstanceCreateInfo(..) )
import Vulkan.Extensions.VK_EXT_debug_utils
import Vulkan.Extensions.VK_EXT_validation_features
import Vulkan.Requirement
import Vulkan.Utils.Debug
import Vulkan.Utils.Internal
import Vulkan.Utils.Requirements
import Vulkan.Zero
createDebugInstanceFromRequirements
:: forall m es
. (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)
=> [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m Instance
createDebugInstanceFromRequirements :: forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createDebugInstanceFromRequirements [InstanceRequirement]
required [InstanceRequirement]
optional InstanceCreateInfo es
baseCreateInfo = do
let debugMessengerCreateInfo :: DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo = forall a. Zero a => a
zero
{ $sel:messageSeverity:DebugUtilsMessengerCreateInfoEXT :: DebugUtilsMessageSeverityFlagsEXT
messageSeverity = DebugUtilsMessageSeverityFlagsEXT
DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT
forall a. Bits a => a -> a -> a
.|. DebugUtilsMessageSeverityFlagsEXT
DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT
, $sel:messageType:DebugUtilsMessengerCreateInfoEXT :: DebugUtilsMessageTypeFlagsEXT
messageType = DebugUtilsMessageTypeFlagsEXT
DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT
forall a. Bits a => a -> a -> a
.|. DebugUtilsMessageTypeFlagsEXT
DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT
forall a. Bits a => a -> a -> a
.|. DebugUtilsMessageTypeFlagsEXT
DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT
, $sel:pfnUserCallback:DebugUtilsMessengerCreateInfoEXT :: PFN_vkDebugUtilsMessengerCallbackEXT
pfnUserCallback = PFN_vkDebugUtilsMessengerCallbackEXT
debugCallbackPtr
}
validationFeatures :: ValidationFeaturesEXT
validationFeatures =
Vector ValidationFeatureEnableEXT
-> Vector ValidationFeatureDisableEXT -> ValidationFeaturesEXT
ValidationFeaturesEXT [ValidationFeatureEnableEXT
VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] []
instanceCreateInfo
:: InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo :: InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo = InstanceCreateInfo es
baseCreateInfo
{ $sel:next:InstanceCreateInfo :: Chain
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
Instance.next = DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ValidationFeaturesEXT
validationFeatures
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& forall (es :: [*]). InstanceCreateInfo es -> Chain es
Instance.next InstanceCreateInfo es
baseCreateInfo
}
additionalRequirements :: l
additionalRequirements =
[ RequireInstanceExtension
{ $sel:instanceExtensionLayerName:RequireInstanceVersion :: Maybe ByteString
instanceExtensionLayerName = forall a. Maybe a
Nothing
, $sel:instanceExtensionName:RequireInstanceVersion :: ByteString
instanceExtensionName = forall a. (Eq a, IsString a) => a
EXT_DEBUG_UTILS_EXTENSION_NAME
, $sel:instanceExtensionMinVersion:RequireInstanceVersion :: Word32
instanceExtensionMinVersion = forall a. Bounded a => a
minBound
}
]
additionalOptionalRequirements :: l
additionalOptionalRequirements =
[ RequireInstanceLayer
{ $sel:instanceLayerName:RequireInstanceVersion :: ByteString
instanceLayerName = ByteString
"VK_LAYER_KHRONOS_validation"
, $sel:instanceLayerMinVersion:RequireInstanceVersion :: Word32
instanceLayerMinVersion = forall a. Bounded a => a
minBound
}
, RequireInstanceExtension
{ $sel:instanceExtensionLayerName:RequireInstanceVersion :: Maybe ByteString
instanceExtensionLayerName = forall a. a -> Maybe a
Just ByteString
"VK_LAYER_KHRONOS_validation"
, $sel:instanceExtensionName:RequireInstanceVersion :: ByteString
instanceExtensionName = forall a. (Eq a, IsString a) => a
EXT_VALIDATION_FEATURES_EXTENSION_NAME
, $sel:instanceExtensionMinVersion:RequireInstanceVersion :: Word32
instanceExtensionMinVersion = forall a. Bounded a => a
minBound
}
]
Instance
inst <- forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements
(forall {l}. (Item l ~ InstanceRequirement, IsList l) => l
additionalRequirements forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [InstanceRequirement]
required)
(forall {l}. (Item l ~ InstanceRequirement, IsList l) => l
additionalOptionalRequirements forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [InstanceRequirement]
optional)
InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo
(ReleaseKey, DebugUtilsMessengerEXT)
_ <- forall (io :: * -> *) r.
MonadIO io =>
Instance
-> DebugUtilsMessengerCreateInfoEXT
-> Maybe AllocationCallbacks
-> (io DebugUtilsMessengerEXT
-> (DebugUtilsMessengerEXT -> io ()) -> r)
-> r
withDebugUtilsMessengerEXT Instance
inst DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instance
inst
createInstanceFromRequirements
:: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)
=> [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m Instance
createInstanceFromRequirements :: forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements [InstanceRequirement]
required [InstanceRequirement]
optional InstanceCreateInfo es
baseCreateInfo = do
(Maybe (InstanceCreateInfo es)
mbICI, [RequirementResult]
rrs, [RequirementResult]
ors) <- 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 [InstanceRequirement]
required
[InstanceRequirement]
optional
InstanceCreateInfo es
baseCreateInfo
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadIO m => String -> m ()
sayErr (forall (r :: * -> *) (o :: * -> *).
(Foldable r, Foldable o) =>
r RequirementResult -> o RequirementResult -> Maybe String
requirementReport [RequirementResult]
rrs [RequirementResult]
ors)
case Maybe (InstanceCreateInfo es)
mbICI of
Maybe (InstanceCreateInfo es)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IO a
unsatisfiedConstraints String
"Failed to create instance"
Just InstanceCreateInfo es
ici -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) (io :: * -> *) r.
(Extendss InstanceCreateInfo a, PokeChain a, MonadIO io) =>
InstanceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Instance -> (Instance -> io ()) -> r)
-> r
withInstance InstanceCreateInfo es
ici forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
createDeviceFromRequirements
:: forall m
. MonadResource m
=> [DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
createDeviceFromRequirements :: forall (m :: * -> *).
MonadResource m =>
[DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
createDeviceFromRequirements [DeviceRequirement]
required [DeviceRequirement]
optional PhysicalDevice
phys DeviceCreateInfo '[]
baseCreateInfo = do
(Maybe (SomeStruct DeviceCreateInfo)
mbDCI, [RequirementResult]
rrs, [RequirementResult]
ors) <- 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 [DeviceRequirement]
required
[DeviceRequirement]
optional
PhysicalDevice
phys
DeviceCreateInfo '[]
baseCreateInfo
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadIO m => String -> m ()
sayErr (forall (r :: * -> *) (o :: * -> *).
(Foldable r, Foldable o) =>
r RequirementResult -> o RequirementResult -> Maybe String
requirementReport [RequirementResult]
rrs [RequirementResult]
ors)
case Maybe (SomeStruct DeviceCreateInfo)
mbDCI of
Maybe (SomeStruct DeviceCreateInfo)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IO a
unsatisfiedConstraints String
"Failed to create instance"
Just (SomeStruct DeviceCreateInfo es
dci) -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) (io :: * -> *) r.
(Extendss DeviceCreateInfo a, PokeChain a, MonadIO io) =>
PhysicalDevice
-> DeviceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Device -> (Device -> io ()) -> r)
-> r
withDevice PhysicalDevice
phys DeviceCreateInfo es
dci forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
pickPhysicalDevice
:: (MonadIO m, Ord b)
=> Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice :: forall (m :: * -> *) b a.
(MonadIO m, Ord b) =>
Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice Instance
inst PhysicalDevice -> m (Maybe a)
devInfo a -> b
score = do
(Result
_, "physicalDevices" ::: Vector PhysicalDevice
devs) <- forall (io :: * -> *).
MonadIO io =>
Instance
-> io (Result, "physicalDevices" ::: Vector PhysicalDevice)
enumeratePhysicalDevices Instance
inst
[(a, PhysicalDevice)]
infos <- forall a. [Maybe a] -> [a]
catMaybes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, PhysicalDevice
d) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m (Maybe a)
devInfo PhysicalDevice
d | PhysicalDevice
d <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList "physicalDevices" ::: Vector PhysicalDevice
devs ]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
maximumByMay (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a -> b
score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)) [(a, PhysicalDevice)]
infos
physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text
physicalDeviceName :: forall (m :: * -> *). MonadIO m => PhysicalDevice -> m Text
physicalDeviceName =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalDeviceProperties -> ByteString
deviceName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceProperties
getPhysicalDeviceProperties
maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a
maximumByMay :: forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
maximumByMay a -> a -> Ordering
f t a
xs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy a -> a -> Ordering
f t a
xs)